Merge remote-tracking branch 'origin/master' into create-parser

This commit is contained in:
Marvin Schlegel 2024-06-26 09:18:11 +02:00
commit 05a6de4a0d
25 changed files with 1274 additions and 422 deletions

1
.gitignore vendored
View File

@ -8,7 +8,6 @@ cabal-dev
*.chs.h
*.dyn_o
*.dyn_hi
*.java
*.class
*.local~*
src/Parser/JavaParser.hs

View File

@ -5,7 +5,7 @@ Written in Haskell.
# Cabal Commands
run main
```
cabal run
cabal run compiler <FILENAME>
```
run tests

View File

@ -0,0 +1,43 @@
// compile all test files using:
// ls Test/JavaSources/*.java | grep -v ".*Main.java" | xargs -I {} cabal run compiler {}
// compile (in project root) using:
// pushd Test/JavaSources; javac -g:none Main.java; popd
// afterwards, run using
// java -ea -cp Test/JavaSources/ Main
public class Main {
public static void main(String[] args)
{
TestEmpty empty = new TestEmpty();
TestFields fields = new TestFields();
TestConstructor constructor = new TestConstructor(42);
TestArithmetic arithmetic = new TestArithmetic();
TestMultipleClasses multipleClasses = new TestMultipleClasses();
TestRecursion recursion = new TestRecursion(10);
TestMalicious malicious = new TestMalicious();
// constructing a basic class works
assert empty != null;
// initializers (and default initializers to 0/null) work
assert fields.a == 0 && fields.b == 42;
// constructor parameters override initializers
assert constructor.a == 42;
// basic arithmetics
assert arithmetic.basic(1, 2, 3) == 2;
// we have boolean logic as well
assert arithmetic.logic(false, false, true) == true;
// multiple classes within one file work. Referencing another classes fields/methods works.
assert multipleClasses.a.a == 42;
// self-referencing classes work.
assert recursion.child.child.child.child.child.value == 5;
// self-referencing methods work.
assert recursion.fibonacci(15) == 610;
// intentionally dodgy expressions work
assert malicious.assignNegativeIncrement(42) == -42;
assert malicious.tripleAddition(1, 2, 3) == 6;
for(int i = 0; i < 3; i++)
{
assert malicious.cursedFormatting(i) == i;
}
}
}

View File

@ -0,0 +1,11 @@
public class TestArithmetic {
public int basic(int a, int b, int c)
{
return a + b - c * a / b % c;
}
public boolean logic(boolean a, boolean b, boolean c)
{
return !a && (c || b);
}
}

View File

@ -0,0 +1,9 @@
public class TestConstructor
{
public int a = -1;
public TestConstructor(int initial_value)
{
a = initial_value;
}
}

View File

@ -0,0 +1,4 @@
public class TestEmpty
{
}

View File

@ -0,0 +1,5 @@
public class TestFields
{
public int a;
public int b = 42;
}

View File

@ -0,0 +1,41 @@
public class TestMalicious {
public int assignNegativeIncrement(int n)
{
return n=-++n+1;
}
public int tripleAddition(int a, int b, int c)
{
return a+++b+++c++;
}
public int cursedFormatting(int n)
{
if
(n == 0)
{
return ((((0))));
}
else
if(n ==
1)
{
return
1;
}else {
return
2
;
}
}
}

View File

@ -0,0 +1,9 @@
public class TestMultipleClasses
{
public AnotherTestClass a = new AnotherTestClass();
}
class AnotherTestClass
{
public int a = 42;
}

View File

@ -0,0 +1,34 @@
public class TestRecursion {
public int value = 0;
public TestRecursion child = null;
public TestRecursion(int n)
{
this.value = n;
if(n > 0)
{
child = new TestRecursion(n - 1);
}
}
public int fibonacci(int n)
{
if(n < 2)
{
return n;
}
else
{
return fibonacci(n - 1) + this.fibonacci(n - 2);
}
}
public int ackermann(int m, int n)
{
if (m == 0) return n + 1;
if (n == 0) return ackermann(m - 1, 1);
return ackermann(m - 1, ackermann(m, n - 1));
}
}

View File

@ -1,116 +0,0 @@
module TestByteCodeGenerator where
import Test.HUnit
import ByteCode.ClassFile.Generator
import ByteCode.ClassFile
import ByteCode.Constants
import Ast
nakedClass = Class "Testklasse" [] []
expectedClass = ClassFile {
constantPool = [
ClassInfo 4,
MethodRefInfo 1 3,
NameAndTypeInfo 5 6,
Utf8Info "java/lang/Object",
Utf8Info "<init>",
Utf8Info "()V",
Utf8Info "Code",
ClassInfo 9,
Utf8Info "Testklasse"
],
accessFlags = accessPublic,
thisClass = 8,
superClass = 1,
fields = [],
methods = [],
attributes = []
}
classWithFields = Class "Testklasse" [] [VariableDeclaration "int" "testvariable" Nothing]
expectedClassWithFields = ClassFile {
constantPool = [
ClassInfo 4,
MethodRefInfo 1 3,
NameAndTypeInfo 5 6,
Utf8Info "java/lang/Object",
Utf8Info "<init>",
Utf8Info "()V",
Utf8Info "Code",
ClassInfo 9,
Utf8Info "Testklasse",
FieldRefInfo 8 11,
NameAndTypeInfo 12 13,
Utf8Info "testvariable",
Utf8Info "I"
],
accessFlags = accessPublic,
thisClass = 8,
superClass = 1,
fields = [
MemberInfo {
memberAccessFlags = accessPublic,
memberNameIndex = 12,
memberDescriptorIndex = 13,
memberAttributes = []
}
],
methods = [],
attributes = []
}
method = MethodDeclaration "int" "add_two_numbers" [
ParameterDeclaration "int" "a",
ParameterDeclaration "int" "b" ]
(Block [Return (Just (BinaryOperation Addition (Reference "a") (Reference "b")))])
classWithMethod = Class "Testklasse" [method] []
expectedClassWithMethod = ClassFile {
constantPool = [
ClassInfo 4,
MethodRefInfo 1 3,
NameAndTypeInfo 5 6,
Utf8Info "java/lang/Object",
Utf8Info "<init>",
Utf8Info "()V",
Utf8Info "Code",
ClassInfo 9,
Utf8Info "Testklasse",
FieldRefInfo 8 11,
NameAndTypeInfo 12 13,
Utf8Info "add_two_numbers",
Utf8Info "(II)I"
],
accessFlags = accessPublic,
thisClass = 8,
superClass = 1,
fields = [],
methods = [
MemberInfo {
memberAccessFlags = accessPublic,
memberNameIndex = 12,
memberDescriptorIndex = 13,
memberAttributes = [
CodeAttribute {
attributeMaxStack = 420,
attributeMaxLocals = 420,
attributeCode = [Opiadd]
}
]
}
],
attributes = []
}
testBasicConstantPool = TestCase $ assertEqual "basic constant pool" expectedClass $ classBuilder nakedClass emptyClassFile
testFields = TestCase $ assertEqual "fields in constant pool" expectedClassWithFields $ classBuilder classWithFields emptyClassFile
testMethodDescriptor = TestCase $ assertEqual "method descriptor" "(II)I" (methodDescriptor method)
testMethodAssembly = TestCase $ assertEqual "method assembly" expectedClassWithMethod (classBuilder classWithMethod emptyClassFile)
tests = TestList [
TestLabel "Basic constant pool" testBasicConstantPool,
TestLabel "Fields constant pool" testFields,
TestLabel "Method descriptor building" testMethodDescriptor,
TestLabel "Method assembly" testMethodAssembly
]

View File

@ -2,13 +2,11 @@ module Main where
import Test.HUnit
import TestLexer
import TestByteCodeGenerator
import TestParser
tests = TestList [
TestLabel "TestLexer" TestLexer.tests,
TestLabel "TestParser" TestParser.tests,
TestLabel "TestByteCodeGenerator" TestByteCodeGenerator.tests]
TestLabel "TestLexer" TestLexer.tests,
TestLabel "TestParser" TestParser.tests
]
main = do runTestTTAndExit Main.tests

79
doc/bytecode.md Normal file
View File

@ -0,0 +1,79 @@
# Bytecodegenerierung
Die Bytecodegenerierung ist letztendlich eine zweistufige Transformation:
`Getypter AST -> [ClassFile] -> [[Word8]]`
Vom AST, der bereits den Typcheck durchlaufen hat, wird zunächst eine Abbildung in die einzelnen ClassFiles vorgenommen. Diese ClassFiles werden anschließend in deren Byte-Repräsentation serialisiert. Dieser Teil der Aufgabenstellung wurde gemeinsam von Christian Brier und Matthias Raba umgesetzt.
## Codegenerierung
Für die erste der beiden Transformationen (`Getypter AST -> [ClassFile]`) werden die Konzepte der "Builder" und "Assembler" eingeführt. Sie sind wie folgt definiert:
```
type ClassFileBuilder a = a -> ClassFile -> ClassFile
type Assembler a = ([ConstantInfo], [Operation], [String]) -> a -> ([ConstantInfo], [Operation], [String])
```
Die Idee hinter beiden ist, dass sie jeweils zwei Inputs haben, wobei der Rückgabewert immer den gleichen Typ hat wie einer der inputs. Das erlaubt es, eine Faltung durchzuführen. Ein ClassFileBuilder z.B bekommt als ersten Parameter den AST, und als zweiten Parameter (und Rückgabewert) eine ClassFile. Soll nun eine Klasse gebaut werden, wird der ClassFileBuilder mit dem AST und einer leeren ClassFile aufgerufen. Der Zustand dieser anfangs leeren ClassFile wird durch alle folgenden Builder/Assembler durchgeschleift, was es erlaubt, nach und nach kleinere Transformationen auf sie anzuwenden.
Der Nutzer ruft beispielsweise die Funktion `classBuilder` auf. Diese wendet nach und nach folgende Transformationen an:
```
methodsWithInjectedConstructor = injectDefaultConstructor methods
methodsWithInjectedInitializers = injectFieldInitializers name fields methodsWithInjectedConstructor
classFileWithFields = foldr fieldBuilder nakedClassFile fields
classFileWithMethods = foldr methodBuilder classFileWithFields methodsWithInjectedInitializers
classFileWithAssembledMethods = foldr methodAssembler classFileWithMethods methodsWithInjectedInitializers
```
Zuerst wird (falls notwendig) ein leerer Defaultkonstruktor in die Classfile eingefügt. Anschließend wird der AST so modifiziert, dass die Initialisierungen für alle Klassenfelder in allen Konstruktoren stattfinden. Nun beginnen die Faltungen:
1. Hinzufügen aller Klassenfelder
2. Hinzufügen aller Methoden (nur Prototypen)
3. Hinzufügen des Bytecodes in allen Methoden
Die Unterteilung von Schritt 2 und 3 ist deswegen notwendig, weil der Code einer Methode auch eine andere, erst nachher deklarierte Methode aufrufen kann. Nach Schritt 2 sind alle Methoden der Klasse bekannt. Wie beschrieben wird auch hier der Zustand über alle Faltungen mitgenommen. Jeder Schritt hat Zugriff auf alle Daten, die aus dem vorherigen Schritt bleiben. Sukzessive wird eine korrekte ClassFile aufgebaut.
Besonders interessant ist hierbei Schritt 3. Dort wird das Verhalten jeder einzelnen Methode in Bytecode übersetzt. In diesem Schritt werden zusätzlich zu den `Buildern` noch die `Assembler` verwendet (Definition siehe oben.) Die Assembler funktionieren ähnlich wie die Builder, arbeiten allerdings nicht auf einer ClassFile, sondern auf dem Inhalt einer Methode: Sie verarbeiten jeweils ein Tupel:
`([ConstantInfo], [Operation], [String])`
Dieses repräsentiert:
`(Konstantenpool, Bytecode, Lokale Variablen)`
In der Praxis werden oft nur Bytecode und Konstanten hinzugefügt. Prinzipiell können Assembler auch Code/Konstanten entfernen oder modifizieren. Als Beispiel dient hier der Assembler `assembleExpression`:
```
assembleExpression (constants, ops, lvars) (TypedExpression _ NullLiteral) =
(constants, ops ++ [Opaconst_null], lvars)
```
Hier werden die Konstanten und lokalen Variablen des Inputs nicht berührt, dem Bytecode wird lediglich die Operation `aconst_null` hinzugefügt. Damit ist das Verhalten des gematchten Inputs - eines Nullliterals - abgebildet.
Die Assembler rufen sich teilweise rekursiv selbst auf, da ja auch der AST verschachteltes Verhalten abbilden kann. Der Startpunkt für die Assembly einer Methode ist der Builder `methodAssembler`. Dieser entspricht Schritt 3 in der obigen Übersicht.
## Serialisierung
Damit Bytecode generiert werden kann, braucht es Strukturen, die die Daten halten, die letztendlich serialisiert werden. Die JVM erwartet den kompilierten Code in handliche Pakete verpackt. Die Struktur dieser Pakete ist [so definiert](https://docs.oracle.com/javase/specs/jvms/se7/html/jvms-4.html).
Jede Struktur, die in dieser übergreifenden Class File vorkommt, haben wir in Haskell abgebildet. Es gibt z.B die Struktur "ClassFile", die wiederum weitere Strukturen wie z.B Informationen über Felder oder Methoden der Klasse beinhaltet. Alle diese Strukturen implementieren folgende TypeClass:
```
class Serializable a where
serialize :: a -> [Word8]
```
Hier ist ein Beispiel anhand der Serialisierung der einzelnen Operationen:
```
instance Serializable Operation where
serialize Opiadd = [0x60]
serialize Opisub = [0x64]
serialize Opimul = [0x68]
...
serialize (Opgetfield index) = 0xB4 : unpackWord16 index
```
Die Struktur ClassFile ruft für deren Kinder rekursiv diese `serialize` Funktion auf und konkateniert die Ergebnisse. Am Ende bleibt eine flache Word8-Liste übrig, die Serialisierung ist damit abgeschlossen. Da der Typecheck sicherstellt, dass alle referenzierten Methoden/Felder gültig sind, kann die Übersetzung der einzelnen Klassen voneinander unabhängig geschehen.

4
doc/generate.sh Executable file
View File

@ -0,0 +1,4 @@
#!/usr/bin/sh
pandoc bytecode.md -o bytecode.docx
pandoc bytecode.md -o bytecode.pdf

55
doc/typecheck.md Normal file
View File

@ -0,0 +1,55 @@
# Typcheck (Fabian Noll)
## Überblick und Struktur
Die Typprüfung beginnt mit der Funktion `typeCheckCompilationUnit`, die eine Kompilationseinheit als Eingabe erhält. Diese Kompilationseinheit besteht aus einer Liste von Klassen. Jede Klasse wird einzeln durch die Funktion `typeCheckClass` überprüft. Innerhalb dieser Funktion wird eine Symboltabelle erstellt, die den Namen der Klasse als Typ und `this` als Identifier enthält. Diese Symboltabelle wird verwendet, um Typinformationen nach dem Lokalitätsprinzip während der Typprüfung zugänglich zu machen und zu verwalten.
Die Typprüfung einer Klasse umfasst die Überprüfung aller Methoden und Felder. Die Methode `typeCheckMethodDeclaration` ist für die Typprüfung einzelner Methodendeklarationen verantwortlich. Sie überprüft den Rückgabetyp der Methode, die Parameter und den Methodenrumpf. Der Methodenrumpf wird durch rekursive Aufrufe von `typeCheckStatement` überprüft, die verschiedene Arten von Anweisungen wie If-Anweisungen, While-Schleifen, Rückgabeanweisungen und Blockanweisungen behandelt.
## Ablauf und Symboltabellen
Eine zentrale Komponente des Typecheckers ist die Symboltabelle (symtab), die Informationen über die Bezeichner und ihre zugehörigen Datentypen speichert. Die Symboltabelle wird kontinuierlich angepasst, während der Typechecker die verschiedenen Teile des Programms durchläuft.
### Anpassung der Symboltabelle
- **Klassenkontext**:
Beim Typcheck einer Klasse wird eine initiale Symboltabelle erstellt, die die `this`-Referenz enthält. Dies geschieht in der Funktion `typeCheckClass`.
- **Methodenkontext**:
Innerhalb einer Methode wird die Symboltabelle um die Parameter der Methode erweitert sowie den Rückgabetyp der Methode, um die einzelnen Returns dagegen zu prüfen. Dies geschieht in `typeCheckMethodDeclaration`.
- **Blockkontext**:
Bei der Überprüfung eines Blocks (`typeCheckStatement` für Block) wird die Symboltabelle für jede Anweisung innerhalb des Blocks aktualisiert. Lokale Variablen, die innerhalb des Blocks deklariert werden, werden zur Symboltabelle hinzugefügt. Das bedeutet, dass automatisch, sobald der Block zu Ende ist, alle dort deklarierten Variablen danach nicht mehr zugänglich sind.
### Unterscheidung zwischen lokalen und Feldvariablen
Bei der Typprüfung von Referenzen (`typeCheckExpression` für Reference) wird zuerst in der Symboltabelle nach dem Bezeichner gesucht. Sollte dieser gefunden werden, handelt es sich um eine lokale Variable. Wenn der Bezeichner nicht gefunden wird, wird angenommen, dass es sich um eine Feldvariable handelt. In diesem Fall wird die Klasse, zu der die `this`-Referenz gehört, durchsucht, um die Feldvariable zu finden. Dies ermöglicht die Unterscheidung zwischen lokalen Variablen und Feldvariablen. Dies ist auch nur möglich, da wir die Feldvariablen und Methoden nicht in die Symboltabelle gelegt haben und stattdessen nur die `this`-Referenz.
## Fehlerbehandlung
Ein zentraler Aspekt des Typecheckers ist die Fehlerbehandlung. Bei Typinkonsistenzen oder ungültigen Operationen werden aussagekräftige Fehlermeldungen generiert. Beispiele für solche Fehlermeldungen sind:
- **Typinkonsistenzen**:
Wenn der Rückgabetyp einer Methode nicht mit dem deklarierten Rückgabetyp übereinstimmt. Oder aber auch die Anzahl der Parameter nicht übereinstimmt.
- **Ungültige Operationen**:
Wenn eine arithmetische Operation auf inkompatiblen Typen durchgeführt wird.
- **Nicht gefundene Bezeichner**:
Wenn eine Referenz auf eine nicht definierte Variable verweist.
Diese Fehlermeldungen helfen Entwicklern, die Ursachen von Typfehlern schnell zu identifizieren und zu beheben. Generell sind diese oftmals sehr spezifisch, was das Problem recht schnell identifizieren sollte. Z.B. falsche Reihenfolge / falsche Typen der Parameter beim Methodenaufruf sind direkt erkennbar.
## Typprüfung von Kontrollstrukturen und Blöcken
### If-Anweisungen
Bei der Typprüfung einer If-Anweisung (`typeCheckStatement` für If) wird zuerst der Typ der Bedingung überprüft, um sicherzustellen, dass es sich um einen booleschen Ausdruck handelt. Anschließend werden die Then- und Else-Zweige geprüft. Der Typ der If-Anweisung selbst wird durch die Vereinheitlichung der Typen der Then- und Else-Zweige bestimmt. Falls einer der Zweige keinen Rückgabewert hat, wird angenommen, dass der Rückgabewert `void` ist. Dies wurde so gelöst, um im Typchecker feststellen zu können, ob beide Zweige einen Return haben. Wenn nur einer der Zweige ein Return hat, wird im umliegenden Block ein weiteres benötigt, was durch den Typ `void` erzwungen wird. Dadurch weiß der Typchecker Bescheid.
### Block-Anweisungen
Die Typprüfung eines Blocks erfolgt in `typeCheckStatement` für Block. Jede Anweisung im Block wird nacheinander überprüft und die Symboltabelle wird entsprechend aktualisiert. Der Typ des Blocks wird durch die Vereinheitlichung der Typen aller Anweisungen im Block bestimmt. Wenn der Block keine Anweisungen hat, wird der Typ `void` angenommen.
### Rückgabeanweisungen
Die Typprüfung einer Rückgabeanweisung (`typeCheckStatement` für Return) überprüft, ob der Rückgabewert der Anweisung mit dem deklarierten Rückgabetyp der Methode übereinstimmt. Dafür wurde zu Beginn der Methodentypprüfung der Rückgabetyp der Methode in die Symboltabelle eingetragen. Wenn der Rückgabewert `null` ist, wird überprüft, ob der deklarierte Rückgabetyp ein Objekttyp ist. Dies stellt sicher, dass Methoden immer den korrekten Typ zurückgeben. Generell wird bei der Prüfung nach dem UpperBound geschaut und ebenfalls wird nachgeschaut, ob, wenn der Rückgabetyp `Object` ist, der Return-Wert auch eine tatsächlich existierende Klasse ist, indem in die Klassentabelle geschaut wird.

View File

@ -10,20 +10,21 @@ executable compiler
array,
HUnit,
utf8-string,
bytestring
bytestring,
filepath
default-language: Haskell2010
hs-source-dirs: src,
src/ByteCode,
src/ByteCode/ClassFile
hs-source-dirs: src
build-tool-depends: alex:alex, happy:happy
other-modules: Parser.Lexer,
Parser.JavaParser
Parser.JavaParser,
Ast,
Example,
Typecheck,
ByteCode.Util,
ByteCode.ByteUtil,
ByteCode.ClassFile,
ByteCode.ClassFile.Generator,
ByteCode.Assembler,
ByteCode.Builder,
ByteCode.Constants
test-suite tests
@ -34,15 +35,17 @@ test-suite tests
array,
HUnit,
utf8-string,
bytestring
bytestring,
filepath
build-tool-depends: alex:alex, happy:happy
other-modules: Parser.Lexer,
Parser.JavaParser,
Ast,
TestLexer,
TestParser,
TestByteCodeGenerator,
ByteCode.Util,
ByteCode.ByteUtil,
ByteCode.ClassFile,
ByteCode.ClassFile.Generator,
ByteCode.Assembler,
ByteCode.Builder,
ByteCode.Constants

View File

@ -2,7 +2,7 @@ module Ast where
type CompilationUnit = [Class]
type DataType = String
type Identifier = String
type Identifier = String
data ParameterDeclaration = ParameterDeclaration DataType Identifier deriving (Show, Eq)
data VariableDeclaration = VariableDeclaration DataType Identifier (Maybe Expression) deriving (Show, Eq)

275
src/ByteCode/Assembler.hs Normal file
View File

@ -0,0 +1,275 @@
module ByteCode.Assembler where
import ByteCode.Constants
import ByteCode.ClassFile (ClassFile (..), ConstantInfo (..), MemberInfo(..), Operation(..), Attribute(..), opcodeEncodingLength)
import ByteCode.Util
import Ast
import Data.Char
import Data.List
import Data.Word
type Assembler a = ([ConstantInfo], [Operation], [String]) -> a -> ([ConstantInfo], [Operation], [String])
assembleExpression :: Assembler Expression
assembleExpression (constants, ops, lvars) (TypedExpression _ (BinaryOperation op a b))
| op `elem` [Addition, Subtraction, Multiplication, Division, Modulo, BitwiseAnd, BitwiseOr, BitwiseXor, And, Or] = let
(aConstants, aOps, _) = assembleExpression (constants, ops, lvars) a
(bConstants, bOps, _) = assembleExpression (aConstants, aOps, lvars) b
in
(bConstants, bOps ++ [binaryOperation op], lvars)
| op `elem` [CompareEqual, CompareNotEqual, CompareLessThan, CompareLessOrEqual, CompareGreaterThan, CompareGreaterOrEqual] = let
(aConstants, aOps, _) = assembleExpression (constants, ops, lvars) a
(bConstants, bOps, _) = assembleExpression (aConstants, aOps, lvars) b
cmp_op = comparisonOperation op 9
cmp_ops = [cmp_op, Opsipush 0, Opgoto 6, Opsipush 1]
in
(bConstants, bOps ++ cmp_ops, lvars)
assembleExpression (constants, ops, lvars) (TypedExpression _ (BinaryOperation NameResolution (TypedExpression atype a) (TypedExpression btype (FieldVariable b)))) = let
(fConstants, fieldIndex) = getFieldIndex constants (atype, b, datatypeDescriptor btype)
(aConstants, aOps, _) = assembleExpression (fConstants, ops, lvars) (TypedExpression atype a)
in
(aConstants, aOps ++ [Opgetfield (fromIntegral fieldIndex)], lvars)
assembleExpression (constants, ops, lvars) (TypedExpression _ (CharacterLiteral literal)) =
(constants, ops ++ [Opsipush (fromIntegral (ord literal))], lvars)
assembleExpression (constants, ops, lvars) (TypedExpression _ (BooleanLiteral literal)) =
(constants, ops ++ [Opsipush (if literal then 1 else 0)], lvars)
assembleExpression (constants, ops, lvars) (TypedExpression _ (IntegerLiteral literal))
| literal <= 32767 && literal >= -32768 = (constants, ops ++ [Opsipush (fromIntegral literal)], lvars)
| otherwise = (constants ++ [IntegerInfo (fromIntegral literal)], ops ++ [Opldc_w (fromIntegral (1 + length constants))], lvars)
assembleExpression (constants, ops, lvars) (TypedExpression _ NullLiteral) =
(constants, ops ++ [Opaconst_null], lvars)
assembleExpression (constants, ops, lvars) (TypedExpression etype (UnaryOperation Not expr)) = let
(exprConstants, exprOps, _) = assembleExpression (constants, ops, lvars) expr
newConstant = fromIntegral (1 + length exprConstants)
in case etype of
"int" -> (exprConstants ++ [IntegerInfo 0x7FFFFFFF], exprOps ++ [Opldc_w newConstant, Opixor], lvars)
"char" -> (exprConstants, exprOps ++ [Opsipush 0xFFFF, Opixor], lvars)
"boolean" -> (exprConstants, exprOps ++ [Opsipush 0x01, Opixor], lvars)
assembleExpression (constants, ops, lvars) (TypedExpression _ (UnaryOperation Minus expr)) = let
(exprConstants, exprOps, _) = assembleExpression (constants, ops, lvars) expr
in
(exprConstants, exprOps ++ [Opineg], lvars)
assembleExpression (constants, ops, lvars) (TypedExpression dtype (LocalVariable name))
| name == "this" = (constants, ops ++ [Opaload 0], lvars)
| otherwise = let
localIndex = elemIndex name lvars
isPrimitive = elem dtype ["char", "boolean", "int"]
in case localIndex of
Just index -> (constants, ops ++ if isPrimitive then [Opiload (fromIntegral index)] else [Opaload (fromIntegral index)], lvars)
Nothing -> error ("No such local variable found in local variable pool: " ++ name)
assembleExpression (constants, ops, lvars) (TypedExpression dtype (StatementExpressionExpression stmtexp)) =
assembleStatementExpression (constants, ops, lvars) stmtexp
assembleExpression _ expr = error ("Unknown expression: " ++ show expr)
assembleNameChain :: Assembler Expression
assembleNameChain input (TypedExpression _ (BinaryOperation NameResolution (TypedExpression atype a) (TypedExpression _ (FieldVariable _)))) =
assembleExpression input (TypedExpression atype a)
assembleNameChain input expr = assembleExpression input expr
assembleStatementExpression :: Assembler StatementExpression
assembleStatementExpression
(constants, ops, lvars)
(TypedStatementExpression _ (Assignment (TypedExpression dtype receiver) expr)) = let
target = resolveNameChain (TypedExpression dtype receiver)
in case target of
(TypedExpression dtype (LocalVariable name)) -> let
localIndex = elemIndex name lvars
(constants_a, ops_a, _) = assembleExpression (constants, ops, lvars) expr
isPrimitive = elem dtype ["char", "boolean", "int"]
in case localIndex of
Just index -> (constants_a, ops_a ++ if isPrimitive then [Opdup, Opistore (fromIntegral index)] else [Opastore (fromIntegral index)], lvars)
Nothing -> error ("No such local variable found in local variable pool: " ++ name)
(TypedExpression dtype (FieldVariable name)) -> let
owner = resolveNameChainOwner (TypedExpression dtype receiver)
in case owner of
(TypedExpression otype _) -> let
(constants_f, fieldIndex) = getFieldIndex constants (otype, name, datatypeDescriptor dtype)
(constants_r, ops_r, _) = assembleNameChain (constants_f, ops, lvars) (TypedExpression dtype receiver)
(constants_a, ops_a, _) = assembleExpression (constants_r, ops_r, lvars) expr
in
(constants_a, ops_a ++ [Opdup_x1, Opputfield (fromIntegral fieldIndex)], lvars)
something_else -> error ("Expected TypedExpression, but got: " ++ show something_else)
assembleStatementExpression
(constants, ops, lvars)
(TypedStatementExpression _ (PreIncrement (TypedExpression dtype receiver))) = let
target = resolveNameChain (TypedExpression dtype receiver)
in case target of
(TypedExpression dtype (LocalVariable name)) -> let
localIndex = elemIndex name lvars
expr = TypedExpression dtype (LocalVariable name)
(exprConstants, exprOps, _) = assembleExpression (constants, ops, lvars) expr
in case localIndex of
Just index -> (exprConstants, exprOps ++ [Opsipush 1, Opiadd, Opdup, Opistore (fromIntegral index)], lvars)
Nothing -> error ("No such local variable found in local variable pool: " ++ name)
(TypedExpression dtype (FieldVariable name)) -> let
owner = resolveNameChainOwner (TypedExpression dtype receiver)
in case owner of
(TypedExpression otype _) -> let
(constants_f, fieldIndex) = getFieldIndex constants (otype, name, datatypeDescriptor dtype)
(constants_r, ops_r, _) = assembleNameChain (constants_f, ops, lvars) (TypedExpression dtype receiver)
in
(constants_r, ops_r ++ [Opdup, Opgetfield (fromIntegral fieldIndex), Opsipush 1, Opiadd, Opdup_x1, Opputfield (fromIntegral fieldIndex)], lvars)
something_else -> error ("Expected TypedExpression, but got: " ++ show something_else)
assembleStatementExpression
(constants, ops, lvars)
(TypedStatementExpression _ (PreDecrement (TypedExpression dtype receiver))) = let
target = resolveNameChain (TypedExpression dtype receiver)
in case target of
(TypedExpression dtype (LocalVariable name)) -> let
localIndex = elemIndex name lvars
expr = TypedExpression dtype (LocalVariable name)
(exprConstants, exprOps, _) = assembleExpression (constants, ops, lvars) expr
in case localIndex of
Just index -> (exprConstants, exprOps ++ [Opsipush 1, Opisub, Opdup, Opistore (fromIntegral index)], lvars)
Nothing -> error ("No such local variable found in local variable pool: " ++ name)
(TypedExpression dtype (FieldVariable name)) -> let
owner = resolveNameChainOwner (TypedExpression dtype receiver)
in case owner of
(TypedExpression otype _) -> let
(constants_f, fieldIndex) = getFieldIndex constants (otype, name, datatypeDescriptor dtype)
(constants_r, ops_r, _) = assembleNameChain (constants_f, ops, lvars) (TypedExpression dtype receiver)
in
(constants_r, ops_r ++ [Opdup, Opgetfield (fromIntegral fieldIndex), Opsipush 1, Opisub, Opdup_x1, Opputfield (fromIntegral fieldIndex)], lvars)
something_else -> error ("Expected TypedExpression, but got: " ++ show something_else)
assembleStatementExpression
(constants, ops, lvars)
(TypedStatementExpression _ (PostIncrement (TypedExpression dtype receiver))) = let
target = resolveNameChain (TypedExpression dtype receiver)
in case target of
(TypedExpression dtype (LocalVariable name)) -> let
localIndex = elemIndex name lvars
expr = TypedExpression dtype (LocalVariable name)
(exprConstants, exprOps, _) = assembleExpression (constants, ops, lvars) expr
in case localIndex of
Just index -> (exprConstants, exprOps ++ [Opdup, Opsipush 1, Opiadd, Opistore (fromIntegral index)], lvars)
Nothing -> error ("No such local variable found in local variable pool: " ++ name)
(TypedExpression dtype (FieldVariable name)) -> let
owner = resolveNameChainOwner (TypedExpression dtype receiver)
in case owner of
(TypedExpression otype _) -> let
(constants_f, fieldIndex) = getFieldIndex constants (otype, name, datatypeDescriptor dtype)
(constants_r, ops_r, _) = assembleNameChain (constants_f, ops, lvars) (TypedExpression dtype receiver)
in
(constants_r, ops_r ++ [Opdup, Opgetfield (fromIntegral fieldIndex), Opdup_x1, Opsipush 1, Opiadd, Opputfield (fromIntegral fieldIndex)], lvars)
something_else -> error ("Expected TypedExpression, but got: " ++ show something_else)
assembleStatementExpression
(constants, ops, lvars)
(TypedStatementExpression _ (PostDecrement (TypedExpression dtype receiver))) = let
target = resolveNameChain (TypedExpression dtype receiver)
in case target of
(TypedExpression dtype (LocalVariable name)) -> let
localIndex = elemIndex name lvars
expr = TypedExpression dtype (LocalVariable name)
(exprConstants, exprOps, _) = assembleExpression (constants, ops, lvars) expr
in case localIndex of
Just index -> (exprConstants, exprOps ++ [Opdup, Opsipush 1, Opisub, Opistore (fromIntegral index)], lvars)
Nothing -> error ("No such local variable found in local variable pool: " ++ name)
(TypedExpression dtype (FieldVariable name)) -> let
owner = resolveNameChainOwner (TypedExpression dtype receiver)
in case owner of
(TypedExpression otype _) -> let
(constants_f, fieldIndex) = getFieldIndex constants (otype, name, datatypeDescriptor dtype)
(constants_r, ops_r, _) = assembleNameChain (constants_f, ops, lvars) (TypedExpression dtype receiver)
in
(constants_r, ops_r ++ [Opdup, Opgetfield (fromIntegral fieldIndex), Opdup_x1, Opsipush 1, Opisub, Opputfield (fromIntegral fieldIndex)], lvars)
something_else -> error ("Expected TypedExpression, but got: " ++ show something_else)
assembleStatementExpression
(constants, ops, lvars)
(TypedStatementExpression rtype (MethodCall (TypedExpression otype receiver) name params)) = let
(constants_r, ops_r, lvars_r) = assembleExpression (constants, ops, lvars) (TypedExpression otype receiver)
(constants_p, ops_p, lvars_p) = foldl assembleExpression (constants_r, ops_r, lvars_r) params
(constants_m, methodIndex) = getMethodIndex constants_p (otype, name, methodDescriptorFromParamlist params rtype)
in
(constants_m, ops_p ++ [Opinvokevirtual (fromIntegral methodIndex)], lvars_p)
assembleStatementExpression
(constants, ops, lvars)
(TypedStatementExpression rtype (ConstructorCall name params)) = let
(constants_c, classIndex) = getClassIndex constants name
(constants_p, ops_p, lvars_p) = foldl assembleExpression (constants_c, ops ++ [Opnew (fromIntegral classIndex), Opdup], lvars) params
(constants_m, methodIndex) = getMethodIndex constants_p (name, "<init>", methodDescriptorFromParamlist params "void")
in
(constants_m, ops_p ++ [Opinvokespecial (fromIntegral methodIndex)], lvars_p)
assembleStatement :: Assembler Statement
assembleStatement (constants, ops, lvars) (TypedStatement stype (Return expr)) = case expr of
Nothing -> (constants, ops ++ [Opreturn], lvars)
Just expr -> let
(expr_constants, expr_ops, _) = assembleExpression (constants, ops, lvars) expr
in
(expr_constants, expr_ops ++ [returnOperation stype], lvars)
assembleStatement (constants, ops, lvars) (TypedStatement _ (Block statements)) =
foldl assembleStatement (constants, ops, lvars) statements
assembleStatement (constants, ops, lvars) (TypedStatement dtype (If expr if_stmt else_stmt)) = let
(constants_cmp, ops_cmp, _) = assembleExpression (constants, [], lvars) expr
(constants_ifa, ops_ifa, _) = assembleStatement (constants_cmp, [], lvars) if_stmt
(constants_elsea, ops_elsea, _) = case else_stmt of
Nothing -> (constants_ifa, [], lvars)
Just stmt -> assembleStatement (constants_ifa, [], lvars) stmt
-- +6 because we insert 2 gotos, one for if, one for else
if_length = sum (map opcodeEncodingLength ops_ifa)
-- +3 because we need to account for the goto in the if statement.
else_length = sum (map opcodeEncodingLength ops_elsea)
in case dtype of
"void" -> (constants_ifa, ops ++ ops_cmp ++ [Opsipush 0, Opif_icmpeq (if_length + 6)] ++ ops_ifa ++ [Opgoto (else_length + 3)] ++ ops_elsea, lvars)
_ -> (constants_ifa, ops ++ ops_cmp ++ [Opsipush 0, Opif_icmpeq (if_length + 3)] ++ ops_ifa ++ ops_elsea, lvars)
assembleStatement (constants, ops, lvars) (TypedStatement _ (While expr stmt)) = let
(constants_cmp, ops_cmp, _) = assembleExpression (constants, [], lvars) expr
(constants_stmta, ops_stmta, _) = assembleStatement (constants_cmp, [], lvars) stmt
-- +3 because we insert 2 gotos, one for the comparison, one for the goto back to the comparison
stmt_length = sum (map opcodeEncodingLength ops_stmta) + 6
entire_length = stmt_length + sum (map opcodeEncodingLength ops_cmp)
in
(constants_stmta, ops ++ ops_cmp ++ [Opsipush 0, Opif_icmpeq stmt_length] ++ ops_stmta ++ [Opgoto (-entire_length)], lvars)
assembleStatement (constants, ops, lvars) (TypedStatement _ (LocalVariableDeclaration (VariableDeclaration dtype name expr))) = let
isPrimitive = elem dtype ["char", "boolean", "int"]
(constants_init, ops_init, _) = case expr of
Just exp -> assembleExpression (constants, ops, lvars) exp
Nothing -> (constants, ops ++ if isPrimitive then [Opsipush 0] else [Opaconst_null], lvars)
localIndex = fromIntegral (length lvars)
storeLocal = if isPrimitive then [Opistore localIndex] else [Opastore localIndex]
in
(constants_init, ops_init ++ storeLocal, lvars ++ [name])
assembleStatement (constants, ops, lvars) (TypedStatement _ (StatementExpressionStatement expr)) = let
(constants_e, ops_e, lvars_e) = assembleStatementExpression (constants, ops, lvars) expr
in
(constants_e, ops_e ++ [Oppop], lvars_e)
assembleStatement _ stmt = error ("Unknown statement: " ++ show stmt)
assembleMethod :: Assembler MethodDeclaration
assembleMethod (constants, ops, lvars) (MethodDeclaration returntype name _ (TypedStatement _ (Block statements)))
| name == "<init>" = let
(constants_a, ops_a, lvars_a) = foldl assembleStatement (constants, ops, lvars) statements
in
(constants_a, [Opaload 0, Opinvokespecial 2] ++ ops_a ++ [Opreturn], lvars_a)
| otherwise = case returntype of
"void" -> let
(constants_a, ops_a, lvars_a) = foldl assembleStatement (constants, ops, lvars) statements
in
(constants_a, ops_a ++ [Opreturn], lvars_a)
_ -> foldl assembleStatement (constants, ops, lvars) statements
assembleMethod _ (MethodDeclaration _ _ _ stmt) = error ("Typed block expected for method body, got: " ++ show stmt)

122
src/ByteCode/Builder.hs Normal file
View File

@ -0,0 +1,122 @@
module ByteCode.Builder where
import ByteCode.Constants
import ByteCode.ClassFile (ClassFile (..), ConstantInfo (..), MemberInfo(..), Operation(..), Attribute(..), opcodeEncodingLength)
import ByteCode.Assembler
import ByteCode.Util
import Ast
import Data.Char
import Data.List
import Data.Word
type ClassFileBuilder a = a -> ClassFile -> ClassFile
fieldBuilder :: ClassFileBuilder VariableDeclaration
fieldBuilder (VariableDeclaration datatype name _) input = let
baseIndex = 1 + length (constantPool input)
constants = [
FieldRefInfo (fromIntegral (thisClass input)) (fromIntegral (baseIndex + 1)),
NameAndTypeInfo (fromIntegral (baseIndex + 2)) (fromIntegral (baseIndex + 3)),
Utf8Info name,
Utf8Info (datatypeDescriptor datatype)
]
field = MemberInfo {
memberAccessFlags = accessPublic,
memberNameIndex = fromIntegral (baseIndex + 2),
memberDescriptorIndex = fromIntegral (baseIndex + 3),
memberAttributes = []
}
in
input {
constantPool = constantPool input ++ constants,
fields = fields input ++ [field]
}
methodBuilder :: ClassFileBuilder MethodDeclaration
methodBuilder (MethodDeclaration returntype name parameters statement) input = let
baseIndex = 1 + length (constantPool input)
constants = [
MethodRefInfo (fromIntegral (thisClass input)) (fromIntegral (baseIndex + 1)),
NameAndTypeInfo (fromIntegral (baseIndex + 2)) (fromIntegral (baseIndex + 3)),
Utf8Info name,
Utf8Info (methodDescriptor (MethodDeclaration returntype name parameters (Block [])))
]
method = MemberInfo {
memberAccessFlags = accessPublic,
memberNameIndex = fromIntegral (baseIndex + 2),
memberDescriptorIndex = fromIntegral (baseIndex + 3),
memberAttributes = []
}
in
input {
constantPool = constantPool input ++ constants,
methods = methods input ++ [method]
}
methodAssembler :: ClassFileBuilder MethodDeclaration
methodAssembler (MethodDeclaration returntype name parameters statement) input = let
methodConstantIndex = findMethodIndex input name
in case methodConstantIndex of
Nothing -> error ("Cannot find method entry in method pool for method: " ++ name)
Just index -> let
declaration = MethodDeclaration returntype name parameters statement
paramNames = "this" : [name | ParameterDeclaration _ name <- parameters]
in case splitAt index (methods input) of
(pre, []) -> input
(pre, method : post) -> let
(constants, bytecode, aParamNames) = assembleMethod (constantPool input, [], paramNames) declaration
assembledMethod = method {
memberAttributes = [
CodeAttribute {
attributeMaxStack = fromIntegral $ maxStackDepth constants bytecode,
attributeMaxLocals = fromIntegral $ length aParamNames,
attributeCode = bytecode
}
]
}
in
input {
constantPool = constants,
methods = pre ++ (assembledMethod : post)
}
classBuilder :: ClassFileBuilder Class
classBuilder (Class name methods fields) _ = let
baseConstants = [
ClassInfo 4,
MethodRefInfo 1 3,
NameAndTypeInfo 5 6,
Utf8Info "java/lang/Object",
Utf8Info "<init>",
Utf8Info "()V",
Utf8Info "Code",
ClassInfo 9,
Utf8Info name
]
nakedClassFile = ClassFile {
constantPool = baseConstants,
accessFlags = accessPublic,
thisClass = 8,
superClass = 1,
fields = [],
methods = [],
attributes = []
}
-- if a class has no constructor, inject an empty one.
methodsWithInjectedConstructor = injectDefaultConstructor methods
-- for every constructor, prepend all initialization assignments for fields.
methodsWithInjectedInitializers = injectFieldInitializers name fields methodsWithInjectedConstructor
-- add fields, then method bodies to the classfile. After all referable names are known,
-- assemble the methods into bytecode.
classFileWithFields = foldr fieldBuilder nakedClassFile fields
classFileWithMethods = foldr methodBuilder classFileWithFields methodsWithInjectedInitializers
classFileWithAssembledMethods = foldr methodAssembler classFileWithMethods methodsWithInjectedInitializers
in
classFileWithAssembledMethods

View File

@ -1,7 +1,6 @@
module ByteCode.ByteUtil(unpackWord16, unpackWord32) where
module ByteCode.ByteUtil where
import Data.Word ( Word8, Word16, Word32 )
import Data.Int
import Data.Bits
unpackWord16 :: Word16 -> [Word8]

View File

@ -1,19 +1,11 @@
module ByteCode.ClassFile(
ConstantInfo(..),
Attribute(..),
MemberInfo(..),
ClassFile(..),
Operation(..),
serialize,
emptyClassFile
) where
module ByteCode.ClassFile where
import Data.Word
import Data.Int
import Data.ByteString (unpack)
import Data.ByteString.UTF8 (fromString)
import ByteCode.ByteUtil
import ByteCode.Constants
import ByteCode.ByteUtil
data ConstantInfo = ClassInfo Word16
| FieldRefInfo Word16 Word16
@ -27,10 +19,13 @@ data Operation = Opiadd
| Opisub
| Opimul
| Opidiv
| Opirem
| Opiand
| Opior
| Opixor
| Opineg
| Opdup
| Opnew Word16
| Opif_icmplt Word16
| Opif_icmple Word16
| Opif_icmpgt Word16
@ -41,6 +36,11 @@ data Operation = Opiadd
| Opreturn
| Opireturn
| Opareturn
| Opdup_x1
| Oppop
| Opinvokespecial Word16
| Opinvokevirtual Word16
| Opgoto Word16
| Opsipush Word16
| Opldc_w Word16
| Opaload Word16
@ -48,7 +48,7 @@ data Operation = Opiadd
| Opastore Word16
| Opistore Word16
| Opputfield Word16
| OpgetField Word16
| Opgetfield Word16
deriving (Show, Eq)
@ -87,6 +87,50 @@ emptyClassFile = ClassFile {
attributes = []
}
className :: ClassFile -> String
className classFile = let
classInfo = constantPool classFile !! fromIntegral (thisClass classFile)
in case classInfo of
Utf8Info className -> className
unexpected_element -> error ("expected Utf8Info but got: " ++ show unexpected_element)
opcodeEncodingLength :: Operation -> Word16
opcodeEncodingLength Opiadd = 1
opcodeEncodingLength Opisub = 1
opcodeEncodingLength Opimul = 1
opcodeEncodingLength Opidiv = 1
opcodeEncodingLength Opirem = 1
opcodeEncodingLength Opiand = 1
opcodeEncodingLength Opior = 1
opcodeEncodingLength Opixor = 1
opcodeEncodingLength Opineg = 1
opcodeEncodingLength Opdup = 1
opcodeEncodingLength (Opnew _) = 3
opcodeEncodingLength (Opif_icmplt _) = 3
opcodeEncodingLength (Opif_icmple _) = 3
opcodeEncodingLength (Opif_icmpgt _) = 3
opcodeEncodingLength (Opif_icmpge _) = 3
opcodeEncodingLength (Opif_icmpeq _) = 3
opcodeEncodingLength (Opif_icmpne _) = 3
opcodeEncodingLength Opaconst_null = 1
opcodeEncodingLength Opreturn = 1
opcodeEncodingLength Opireturn = 1
opcodeEncodingLength Opareturn = 1
opcodeEncodingLength Opdup_x1 = 1
opcodeEncodingLength Oppop = 1
opcodeEncodingLength (Opinvokespecial _) = 3
opcodeEncodingLength (Opinvokevirtual _) = 3
opcodeEncodingLength (Opgoto _) = 3
opcodeEncodingLength (Opsipush _) = 3
opcodeEncodingLength (Opldc_w _) = 3
opcodeEncodingLength (Opaload _) = 4
opcodeEncodingLength (Opiload _) = 4
opcodeEncodingLength (Opastore _) = 4
opcodeEncodingLength (Opistore _) = 4
opcodeEncodingLength (Opputfield _) = 3
opcodeEncodingLength (Opgetfield _) = 3
class Serializable a where
serialize :: a -> [Word8]
@ -108,41 +152,49 @@ instance Serializable MemberInfo where
++ concatMap serialize (memberAttributes member)
instance Serializable Operation where
serialize Opiadd = [0x60]
serialize Opisub = [0x64]
serialize Opimul = [0x68]
serialize Opidiv = [0x6C]
serialize Opiand = [0x7E]
serialize Opior = [0x80]
serialize Opixor = [0x82]
serialize Opineg = [0x74]
serialize (Opif_icmplt branch) = 0xA1 : unpackWord16 branch
serialize (Opif_icmple branch) = 0xA4 : unpackWord16 branch
serialize (Opif_icmpgt branch) = 0xA3 : unpackWord16 branch
serialize (Opif_icmpge branch) = 0xA2 : unpackWord16 branch
serialize (Opif_icmpeq branch) = 0x9F : unpackWord16 branch
serialize (Opif_icmpne branch) = 0xA0 : unpackWord16 branch
serialize Opaconst_null = [0x01]
serialize Opreturn = [0xB1]
serialize Opireturn = [0xAC]
serialize Opareturn = [0xB0]
serialize (Opsipush index) = 0x11 : unpackWord16 index
serialize (Opldc_w index) = 0x13 : unpackWord16 index
serialize (Opaload index) = [0xC4, 0x19] ++ unpackWord16 index
serialize (Opiload index) = [0xC4, 0x15] ++ unpackWord16 index
serialize (Opastore index) = [0xC4, 0x3A] ++ unpackWord16 index
serialize (Opistore index) = [0xC4, 0x36] ++ unpackWord16 index
serialize (Opputfield index) = 0xB5 : unpackWord16 index
serialize (OpgetField index) = 0xB4 : unpackWord16 index
serialize Opiadd = [0x60]
serialize Opisub = [0x64]
serialize Opimul = [0x68]
serialize Opidiv = [0x6C]
serialize Opirem = [0x70]
serialize Opiand = [0x7E]
serialize Opior = [0x80]
serialize Opixor = [0x82]
serialize Opineg = [0x74]
serialize Opdup = [0x59]
serialize (Opnew index) = 0xBB : unpackWord16 index
serialize (Opif_icmplt branch) = 0xA1 : unpackWord16 branch
serialize (Opif_icmple branch) = 0xA4 : unpackWord16 branch
serialize (Opif_icmpgt branch) = 0xA3 : unpackWord16 branch
serialize (Opif_icmpge branch) = 0xA2 : unpackWord16 branch
serialize (Opif_icmpeq branch) = 0x9F : unpackWord16 branch
serialize (Opif_icmpne branch) = 0xA0 : unpackWord16 branch
serialize Opaconst_null = [0x01]
serialize Opreturn = [0xB1]
serialize Opireturn = [0xAC]
serialize Opareturn = [0xB0]
serialize Opdup_x1 = [0x5A]
serialize Oppop = [0x57]
serialize (Opinvokespecial index) = 0xB7 : unpackWord16 index
serialize (Opinvokevirtual index) = 0xB6 : unpackWord16 index
serialize (Opgoto index) = 0xA7 : unpackWord16 index
serialize (Opsipush index) = 0x11 : unpackWord16 index
serialize (Opldc_w index) = 0x13 : unpackWord16 index
serialize (Opaload index) = [0xC4, 0x19] ++ unpackWord16 index
serialize (Opiload index) = [0xC4, 0x15] ++ unpackWord16 index
serialize (Opastore index) = [0xC4, 0x3A] ++ unpackWord16 index
serialize (Opistore index) = [0xC4, 0x36] ++ unpackWord16 index
serialize (Opputfield index) = 0xB5 : unpackWord16 index
serialize (Opgetfield index) = 0xB4 : unpackWord16 index
instance Serializable Attribute where
serialize (CodeAttribute { attributeMaxStack = maxStack,
attributeMaxLocals = maxLocals,
attributeCode = code }) = let
assembledCode = concat (map serialize code)
assembledCode = concatMap serialize code
in
unpackWord16 7 -- attribute_name_index
++ unpackWord32 (12 + (fromIntegral (length assembledCode))) -- attribute_length
++ unpackWord32 (12 + fromIntegral (length assembledCode)) -- attribute_length
++ unpackWord16 maxStack -- max_stack
++ unpackWord16 maxLocals -- max_locals
++ unpackWord32 (fromIntegral (length assembledCode)) -- code_length
@ -151,7 +203,7 @@ instance Serializable Attribute where
++ unpackWord16 0 -- attributes_count
instance Serializable ClassFile where
serialize classfile = unpackWord32 0xC0FEBABE -- magic
serialize classfile = unpackWord32 0xCAFEBABE -- magic
++ unpackWord16 0 -- minor version
++ unpackWord16 49 -- major version
++ unpackWord16 (fromIntegral (1 + length (constantPool classfile))) -- constant pool count

View File

@ -1,169 +0,0 @@
module ByteCode.ClassFile.Generator(
classBuilder,
datatypeDescriptor,
methodParameterDescriptor,
methodDescriptor,
) where
import ByteCode.Constants
import ByteCode.ClassFile (ClassFile (..), ConstantInfo (..), MemberInfo(..), Operation(..), Attribute(..))
import Ast
import Data.Char
type ClassFileBuilder a = a -> ClassFile -> ClassFile
datatypeDescriptor :: String -> String
datatypeDescriptor "void" = "V"
datatypeDescriptor "int" = "I"
datatypeDescriptor "char" = "C"
datatypeDescriptor "boolean" = "B"
datatypeDescriptor x = "L" ++ x
methodParameterDescriptor :: String -> String
methodParameterDescriptor "void" = "V"
methodParameterDescriptor "int" = "I"
methodParameterDescriptor "char" = "C"
methodParameterDescriptor "boolean" = "B"
methodParameterDescriptor x = "L" ++ x ++ ";"
methodDescriptor :: MethodDeclaration -> String
methodDescriptor (MethodDeclaration returntype _ parameters _) = let
parameter_types = [datatype | ParameterDeclaration datatype _ <- parameters]
in
"("
++ (concat (map methodParameterDescriptor parameter_types))
++ ")"
++ datatypeDescriptor returntype
classBuilder :: ClassFileBuilder Class
classBuilder (Class name methods fields) _ = let
baseConstants = [
ClassInfo 4,
MethodRefInfo 1 3,
NameAndTypeInfo 5 6,
Utf8Info "java/lang/Object",
Utf8Info "<init>",
Utf8Info "()V",
Utf8Info "Code"
]
nameConstants = [ClassInfo 9, Utf8Info name]
nakedClassFile = ClassFile {
constantPool = baseConstants ++ nameConstants,
accessFlags = accessPublic,
thisClass = 8,
superClass = 1,
fields = [],
methods = [],
attributes = []
}
in
foldr methodBuilder (foldr fieldBuilder nakedClassFile fields) methods
fieldBuilder :: ClassFileBuilder VariableDeclaration
fieldBuilder (VariableDeclaration datatype name _) input = let
baseIndex = 1 + length (constantPool input)
constants = [
FieldRefInfo (fromIntegral (thisClass input)) (fromIntegral (baseIndex + 1)),
NameAndTypeInfo (fromIntegral (baseIndex + 2)) (fromIntegral (baseIndex + 3)),
Utf8Info name,
Utf8Info (datatypeDescriptor datatype)
]
field = MemberInfo {
memberAccessFlags = accessPublic,
memberNameIndex = (fromIntegral (baseIndex + 2)),
memberDescriptorIndex = (fromIntegral (baseIndex + 3)),
memberAttributes = []
}
in
input {
constantPool = (constantPool input) ++ constants,
fields = (fields input) ++ [field]
}
methodBuilder :: ClassFileBuilder MethodDeclaration
methodBuilder (MethodDeclaration returntype name parameters statement) input = let
baseIndex = 1 + length (constantPool input)
constants = [
FieldRefInfo (fromIntegral (thisClass input)) (fromIntegral (baseIndex + 1)),
NameAndTypeInfo (fromIntegral (baseIndex + 2)) (fromIntegral (baseIndex + 3)),
Utf8Info name,
Utf8Info (methodDescriptor (MethodDeclaration returntype name parameters (Block [])))
]
--code = assembleByteCode statement
method = MemberInfo {
memberAccessFlags = accessPublic,
memberNameIndex = (fromIntegral (baseIndex + 2)),
memberDescriptorIndex = (fromIntegral (baseIndex + 3)),
memberAttributes = [
CodeAttribute {
attributeMaxStack = 420,
attributeMaxLocals = 420,
attributeCode = [Opiadd]
}
]
}
in
input {
constantPool = (constantPool input) ++ constants,
methods = (fields input) ++ [method]
}
type Assembler a = a -> ([ConstantInfo], [Operation]) -> ([ConstantInfo], [Operation])
returnOperation :: DataType -> Operation
returnOperation dtype
| elem dtype ["int", "char", "boolean"] = Opireturn
| otherwise = Opareturn
binaryOperation :: BinaryOperator -> Operation
binaryOperation Addition = Opiadd
binaryOperation Subtraction = Opisub
binaryOperation Multiplication = Opimul
binaryOperation Division = Opidiv
binaryOperation BitwiseAnd = Opiand
binaryOperation BitwiseOr = Opior
binaryOperation BitwiseXor = Opixor
assembleMethod :: Assembler MethodDeclaration
assembleMethod (MethodDeclaration _ _ _ (Block statements)) (constants, ops) =
foldr assembleStatement (constants, ops) statements
assembleStatement :: Assembler Statement
assembleStatement (TypedStatement stype (Return expr)) (constants, ops) = case expr of
Nothing -> (constants, ops ++ [Opreturn])
Just expr -> let
(expr_constants, expr_ops) = assembleExpression expr (constants, ops)
in
(expr_constants, expr_ops ++ [returnOperation stype])
assembleExpression :: Assembler Expression
assembleExpression (TypedExpression _ (BinaryOperation op a b)) (constants, ops)
| elem op [Addition, Subtraction, Multiplication, Division, BitwiseAnd, BitwiseOr, BitwiseXor] = let
(aConstants, aOps) = assembleExpression a (constants, ops)
(bConstants, bOps) = assembleExpression b (aConstants, aOps)
in
(bConstants, bOps ++ [binaryOperation op])
assembleExpression (TypedExpression _ (CharacterLiteral literal)) (constants, ops) =
(constants, ops ++ [Opsipush (fromIntegral (ord literal))])
assembleExpression (TypedExpression _ (BooleanLiteral literal)) (constants, ops) =
(constants, ops ++ [Opsipush (if literal then 1 else 0)])
assembleExpression (TypedExpression _ (IntegerLiteral literal)) (constants, ops)
| literal <= 32767 && literal >= -32768 = (constants, ops ++ [Opsipush (fromIntegral literal)])
| otherwise = (constants ++ [IntegerInfo (fromIntegral literal)], ops ++ [Opldc_w (fromIntegral (1 + length constants))])
assembleExpression (TypedExpression _ NullLiteral) (constants, ops) =
(constants, ops ++ [Opaconst_null])
assembleExpression (TypedExpression etype (UnaryOperation Not expr)) (constants, ops) = let
(exprConstants, exprOps) = assembleExpression expr (constants, ops)
newConstant = fromIntegral (1 + length exprConstants)
in case etype of
"int" -> (exprConstants ++ [IntegerInfo 0x7FFFFFFF], exprOps ++ [Opldc_w newConstant, Opixor])
"char" -> (exprConstants, exprOps ++ [Opsipush 0xFFFF, Opixor])
"boolean" -> (exprConstants, exprOps ++ [Opsipush 0x01, Opixor])
assembleExpression (TypedExpression _ (UnaryOperation Minus expr)) (constants, ops) = let
(exprConstants, exprOps) = assembleExpression expr (constants, ops)
in
(exprConstants, exprOps ++ [Opineg])

292
src/ByteCode/Util.hs Normal file
View File

@ -0,0 +1,292 @@
module ByteCode.Util where
import Data.Int
import Ast
import ByteCode.ClassFile
import Data.List
import Data.Maybe (mapMaybe, isJust)
import Data.Word (Word8, Word16, Word32)
-- walks the name resolution chain. returns the innermost Just LocalVariable/FieldVariable or Nothing.
resolveNameChain :: Expression -> Expression
resolveNameChain (TypedExpression _ (BinaryOperation NameResolution a b)) = resolveNameChain b
resolveNameChain (TypedExpression dtype (LocalVariable name)) = TypedExpression dtype (LocalVariable name)
resolveNameChain (TypedExpression dtype (FieldVariable name)) = TypedExpression dtype (FieldVariable name)
resolveNameChain invalidExpression = error ("expected a NameResolution or Local/Field Variable but got: " ++ show invalidExpression)
-- walks the name resolution chain. returns the second-to-last item of the namechain.
resolveNameChainOwner :: Expression -> Expression
resolveNameChainOwner (TypedExpression _ (BinaryOperation NameResolution a (TypedExpression dtype (FieldVariable name)))) = a
resolveNameChainOwner (TypedExpression _ (BinaryOperation NameResolution a b)) = resolveNameChain b
resolveNameChainOwner invalidExpression = error ("expected a NameResolution or Local/Field Variable but got: " ++ show invalidExpression)
methodDescriptor :: MethodDeclaration -> String
methodDescriptor (MethodDeclaration returntype _ parameters _) = let
parameter_types = [datatype | ParameterDeclaration datatype _ <- parameters]
in
"("
++ concatMap datatypeDescriptor parameter_types
++ ")"
++ datatypeDescriptor returntype
methodDescriptorFromParamlist :: [Expression] -> String -> String
methodDescriptorFromParamlist parameters returntype = let
parameter_types = [datatype | TypedExpression datatype _ <- parameters]
in
"("
++ concatMap datatypeDescriptor parameter_types
++ ")"
++ datatypeDescriptor returntype
-- recursively parses a given type signature into a list of parameter types and the method return type.
-- As an initial parameter, you can supply ([], "void").
parseMethodType :: ([String], String) -> String -> ([String], String)
parseMethodType (params, returnType) ('(' : descriptor) = parseMethodType (params, returnType) descriptor
parseMethodType (params, returnType) ('I' : descriptor) = parseMethodType (params ++ ["I"], returnType) descriptor
parseMethodType (params, returnType) ('C' : descriptor) = parseMethodType (params ++ ["C"], returnType) descriptor
parseMethodType (params, returnType) ('Z' : descriptor) = parseMethodType (params ++ ["Z"], returnType) descriptor
parseMethodType (params, returnType) ('L' : descriptor) = let
typeLength = elemIndex ';' descriptor
in case typeLength of
Just length -> let
(typeName, semicolon : restOfDescriptor) = splitAt length descriptor
in
parseMethodType (params ++ [typeName], returnType) restOfDescriptor
Nothing -> error $ "unterminated class type in function signature: " ++ show descriptor
parseMethodType (params, _) (')' : descriptor) = (params, descriptor)
parseMethodType _ descriptor = error $ "expected start of type name (L, I, C, Z) but got: " ++ descriptor
-- given a method index (constant pool index),
-- returns the full type of the method. (i.e (LSomething;II)V)
methodTypeFromIndex :: [ConstantInfo] -> Int -> String
methodTypeFromIndex constants index = case constants !! fromIntegral (index - 1) of
MethodRefInfo _ nameAndTypeIndex -> case constants !! fromIntegral (nameAndTypeIndex - 1) of
NameAndTypeInfo _ typeIndex -> case constants !! fromIntegral (typeIndex - 1) of
Utf8Info typeLiteral -> typeLiteral
unexpectedElement -> error "Expected Utf8Info but got: " ++ show unexpectedElement
unexpectedElement -> error "Expected NameAndTypeInfo but got: " ++ show unexpectedElement
unexpectedElement -> error "Expected MethodRefInfo but got: " ++ show unexpectedElement
methodParametersFromIndex :: [ConstantInfo] -> Int -> ([String], String)
methodParametersFromIndex constants index = parseMethodType ([], "V") (methodTypeFromIndex constants index)
memberInfoIsMethod :: [ConstantInfo] -> MemberInfo -> Bool
memberInfoIsMethod constants info = '(' `elem` memberInfoDescriptor constants info
datatypeDescriptor :: String -> String
datatypeDescriptor "void" = "V"
datatypeDescriptor "int" = "I"
datatypeDescriptor "char" = "C"
datatypeDescriptor "boolean" = "Z"
datatypeDescriptor x = "L" ++ x ++ ";"
memberInfoDescriptor :: [ConstantInfo] -> MemberInfo -> String
memberInfoDescriptor constants MemberInfo { memberDescriptorIndex = descriptorIndex } = let
descriptor = constants !! (fromIntegral descriptorIndex - 1)
in case descriptor of
Utf8Info descriptorText -> descriptorText
_ -> "Invalid Item at Constant pool index " ++ show descriptorIndex
memberInfoName :: [ConstantInfo] -> MemberInfo -> String
memberInfoName constants MemberInfo { memberNameIndex = nameIndex } = let
name = constants !! (fromIntegral nameIndex - 1)
in case name of
Utf8Info nameText -> nameText
_ -> "Invalid Item at Constant pool index " ++ show nameIndex
returnOperation :: DataType -> Operation
returnOperation dtype
| dtype `elem` ["int", "char", "boolean"] = Opireturn
| otherwise = Opareturn
binaryOperation :: BinaryOperator -> Operation
binaryOperation Addition = Opiadd
binaryOperation Subtraction = Opisub
binaryOperation Multiplication = Opimul
binaryOperation Division = Opidiv
binaryOperation Modulo = Opirem
binaryOperation BitwiseAnd = Opiand
binaryOperation BitwiseOr = Opior
binaryOperation BitwiseXor = Opixor
binaryOperation And = Opiand
binaryOperation Or = Opior
comparisonOperation :: BinaryOperator -> Word16 -> Operation
comparisonOperation CompareEqual branchLocation = Opif_icmpeq branchLocation
comparisonOperation CompareNotEqual branchLocation = Opif_icmpne branchLocation
comparisonOperation CompareLessThan branchLocation = Opif_icmplt branchLocation
comparisonOperation CompareLessOrEqual branchLocation = Opif_icmple branchLocation
comparisonOperation CompareGreaterThan branchLocation = Opif_icmpgt branchLocation
comparisonOperation CompareGreaterOrEqual branchLocation = Opif_icmpge branchLocation
comparisonOffset :: Operation -> Maybe Int
comparisonOffset (Opif_icmpeq offset) = Just $ fromIntegral offset
comparisonOffset (Opif_icmpne offset) = Just $ fromIntegral offset
comparisonOffset (Opif_icmplt offset) = Just $ fromIntegral offset
comparisonOffset (Opif_icmple offset) = Just $ fromIntegral offset
comparisonOffset (Opif_icmpgt offset) = Just $ fromIntegral offset
comparisonOffset (Opif_icmpge offset) = Just $ fromIntegral offset
comparisonOffset anything_else = Nothing
isComparisonOperation :: Operation -> Bool
isComparisonOperation op = isJust (comparisonOffset op)
findMethodIndex :: ClassFile -> String -> Maybe Int
findMethodIndex classFile name = let
constants = constantPool classFile
in
findIndex (\method -> memberInfoIsMethod constants method && memberInfoName constants method == name) (methods classFile)
findClassIndex :: [ConstantInfo] -> String -> Maybe Int
findClassIndex constants name = let
classNameIndices = [(index, constants!!(fromIntegral nameIndex - 1)) | (index, ClassInfo nameIndex) <- zip [1..] constants]
classNames = map (\(index, nameInfo) -> case nameInfo of
Utf8Info className -> (index, className)
something_else -> error ("Expected UTF8Info but got " ++ show something_else))
classNameIndices
desiredClassIndex = find (\(index, className) -> className == name) classNames
in case desiredClassIndex of
Just (index, _) -> Just index
Nothing -> Nothing
getKnownMembers :: [ConstantInfo] -> [(Int, (String, String, String))]
getKnownMembers constants = let
fieldsClassAndNT = [
(index, constants!!(fromIntegral classIndex - 1), constants!!(fromIntegral nameTypeIndex - 1))
| (index, FieldRefInfo classIndex nameTypeIndex) <- zip [1..] constants
] ++ [
(index, constants!!(fromIntegral classIndex - 1), constants!!(fromIntegral nameTypeIndex - 1))
| (index, MethodRefInfo classIndex nameTypeIndex) <- zip [1..] constants
]
fieldsClassNameType = map (\(index, nameInfo, nameTypeInfo) -> case (nameInfo, nameTypeInfo) of
(ClassInfo nameIndex, NameAndTypeInfo fnameIndex ftypeIndex) -> (index, (constants!!(fromIntegral nameIndex - 1), constants!!(fromIntegral fnameIndex - 1), constants!!(fromIntegral ftypeIndex - 1)))
something_else -> error ("Expected Class and NameType info, but got: " ++ show nameInfo ++ " and " ++ show nameTypeInfo))
fieldsClassAndNT
fieldsResolved = map (\(index, (nameInfo, fnameInfo, ftypeInfo)) -> case (nameInfo, fnameInfo, ftypeInfo) of
(Utf8Info cname, Utf8Info fname, Utf8Info ftype) -> (index, (cname, fname, ftype))
something_else -> error ("Expected UTF8Infos but got " ++ show something_else))
fieldsClassNameType
in
fieldsResolved
-- same as findClassIndex, but inserts a new entry into constant pool if not existing
getClassIndex :: [ConstantInfo] -> String -> ([ConstantInfo], Int)
getClassIndex constants name = case findClassIndex constants name of
Just index -> (constants, index)
Nothing -> (constants ++ [ClassInfo (fromIntegral (length constants) + 2), Utf8Info name], fromIntegral (length constants) + 1)
-- get the index for a field within a class, creating it if it does not exist.
getFieldIndex :: [ConstantInfo] -> (String, String, String) -> ([ConstantInfo], Int)
getFieldIndex constants (cname, fname, ftype) = case findMemberIndex constants (cname, fname, ftype) of
Just index -> (constants, index)
Nothing -> let
(constantsWithClass, classIndex) = getClassIndex constants cname
baseIndex = 1 + length constantsWithClass
in
(constantsWithClass ++ [
FieldRefInfo (fromIntegral classIndex) (fromIntegral (baseIndex + 1)),
NameAndTypeInfo (fromIntegral (baseIndex + 2)) (fromIntegral (baseIndex + 3)),
Utf8Info fname,
Utf8Info (datatypeDescriptor ftype)
], baseIndex)
getMethodIndex :: [ConstantInfo] -> (String, String, String) -> ([ConstantInfo], Int)
getMethodIndex constants (cname, mname, mtype) = case findMemberIndex constants (cname, mname, mtype) of
Just index -> (constants, index)
Nothing -> let
(constantsWithClass, classIndex) = getClassIndex constants cname
baseIndex = 1 + length constantsWithClass
in
(constantsWithClass ++ [
MethodRefInfo (fromIntegral classIndex) (fromIntegral (baseIndex + 1)),
NameAndTypeInfo (fromIntegral (baseIndex + 2)) (fromIntegral (baseIndex + 3)),
Utf8Info mname,
Utf8Info mtype
], baseIndex)
findMemberIndex :: [ConstantInfo] -> (String, String, String) -> Maybe Int
findMemberIndex constants (cname, fname, ftype) = let
allMembers = getKnownMembers constants
desiredMember = find (\(index, (c, f, ft)) -> (c, f, ft) == (cname, fname, ftype)) allMembers
in
fmap (\(index, _) -> index) desiredMember
injectDefaultConstructor :: [MethodDeclaration] -> [MethodDeclaration]
injectDefaultConstructor pre
| any (\(MethodDeclaration _ name _ _) -> name == "<init>") pre = pre
| otherwise = pre ++ [MethodDeclaration "void" "<init>" [] (TypedStatement "void" (Block []))]
injectFieldInitializers :: String -> [VariableDeclaration] -> [MethodDeclaration] -> [MethodDeclaration]
injectFieldInitializers classname vars pre = let
initializers = mapMaybe (\(variable) -> case variable of
VariableDeclaration dtype name (Just initializer) -> Just (
TypedStatement dtype (
StatementExpressionStatement (
TypedStatementExpression dtype (
Assignment
(TypedExpression dtype (BinaryOperation NameResolution (TypedExpression classname (LocalVariable "this")) (TypedExpression dtype (FieldVariable name))))
initializer
)
)
)
)
otherwise -> Nothing
) vars
in
map (\method -> case method of
MethodDeclaration "void" "<init>" params (TypedStatement "void" (Block statements)) -> MethodDeclaration "void" "<init>" params (TypedStatement "void" (Block (initializers ++ statements)))
_ -> method
) pre
-- effect of one instruction/operation on the stack
operationStackCost :: [ConstantInfo] -> Operation -> Int
operationStackCost constants Opiadd = -1
operationStackCost constants Opisub = -1
operationStackCost constants Opimul = -1
operationStackCost constants Opidiv = -1
operationStackCost constants Opirem = -1
operationStackCost constants Opiand = -1
operationStackCost constants Opior = -1
operationStackCost constants Opixor = -1
operationStackCost constants Opineg = 0
operationStackCost constants Opdup = 1
operationStackCost constants (Opnew _) = 1
operationStackCost constants (Opif_icmplt _) = -2
operationStackCost constants (Opif_icmple _) = -2
operationStackCost constants (Opif_icmpgt _) = -2
operationStackCost constants (Opif_icmpge _) = -2
operationStackCost constants (Opif_icmpeq _) = -2
operationStackCost constants (Opif_icmpne _) = -2
operationStackCost constants Opaconst_null = 1
operationStackCost constants Opreturn = 0
operationStackCost constants Opireturn = -1
operationStackCost constants Opareturn = -1
operationStackCost constants Opdup_x1 = 1
operationStackCost constants Oppop = -1
operationStackCost constants (Opinvokespecial idx) = let
(params, returnType) = methodParametersFromIndex constants (fromIntegral idx)
in (length params + 1) - fromEnum (returnType /= "V")
operationStackCost constants (Opinvokevirtual idx) = let
(params, returnType) = methodParametersFromIndex constants (fromIntegral idx)
in (length params + 1) - fromEnum (returnType /= "V")
operationStackCost constants (Opgoto _) = 0
operationStackCost constants (Opsipush _) = 1
operationStackCost constants (Opldc_w _) = 1
operationStackCost constants (Opaload _) = 1
operationStackCost constants (Opiload _) = 1
operationStackCost constants (Opastore _) = -1
operationStackCost constants (Opistore _) = -1
operationStackCost constants (Opputfield _) = -2
operationStackCost constants (Opgetfield _) = -1
simulateStackOperation :: [ConstantInfo] -> Operation -> (Int, Int) -> (Int, Int)
simulateStackOperation constants op (cd, md) = let
depth = cd + operationStackCost constants op
in if depth < 0
then error ("Consuming value off of empty stack: " ++ show op)
else (depth, max depth md)
maxStackDepth :: [ConstantInfo] -> [Operation] -> Int
maxStackDepth constants ops = snd $ foldr (simulateStackOperation constants) (0, 0) (reverse ops)

View File

@ -1,8 +1,32 @@
module Main where
import Example
import Typecheck
import Parser.Lexer (alexScanTokens)
import Parser.JavaParser
import ByteCode.Builder
import ByteCode.ClassFile
import Data.ByteString (pack, writeFile)
import System.Environment
import System.FilePath.Posix (takeDirectory)
main = do
Example.runTypeCheck
args <- getArgs
let filename = if null args
then error "Missing filename, I need to know what to compile"
else head args
let outputDirectory = takeDirectory filename
print ("Compiling " ++ filename)
file <- readFile filename
let untypedAST = parse $ alexScanTokens file
let typedAST = typeCheckCompilationUnit untypedAST
let assembledClasses = map (`classBuilder` emptyClassFile) typedAST
mapM_ (\classFile -> let
fileContent = pack (serialize classFile)
fileName = outputDirectory ++ "/" ++ className classFile ++ ".class"
in Data.ByteString.writeFile fileName fileContent
) assembledClasses

View File

@ -9,25 +9,46 @@ typeCheckCompilationUnit classes = map (`typeCheckClass` classes) classes
typeCheckClass :: Class -> [Class] -> Class
typeCheckClass (Class className methods fields) classes =
let
-- Create a symbol table from class fields and method entries
-- TODO: Maybe remove method entries from the symbol table?
methodEntries = [(methodName, className) | MethodDeclaration _ methodName _ _ <- methods]
initalSymTab = ("this", className) : methodEntries
-- Fields and methods dont need to be added to the symtab because they are looked upon automatically under "this"
-- if its not a declared local variable. Also shadowing wouldnt be possible then.
initalSymTab = [("this", className)]
checkedMethods = map (\method -> typeCheckMethodDeclaration method initalSymTab classes) methods
in Class className checkedMethods fields
checkedFields = map (\field -> typeCheckVariableDeclaration field initalSymTab classes) fields
in Class className checkedMethods checkedFields
typeCheckMethodDeclaration :: MethodDeclaration -> [(Identifier, DataType)] -> [Class] -> MethodDeclaration
typeCheckMethodDeclaration (MethodDeclaration retType name params body) classFields classes =
typeCheckMethodDeclaration (MethodDeclaration retType name params body) symtab classes =
let
-- Combine class fields with method parameters to form the initial symbol table for the method
methodParams = [(identifier, dataType) | ParameterDeclaration dataType identifier <- params]
initialSymtab = classFields ++ methodParams
initialSymtab = ("thisMeth", retType) : symtab ++ methodParams
checkedBody = typeCheckStatement body initialSymtab classes
bodyType = getTypeFromStmt checkedBody
-- Check if the type of the body matches the declared return type
in if bodyType == retType || (bodyType == "void" && retType == "void") || (bodyType == "null" && isObjectType retType)
in if bodyType == retType || (bodyType == "void" && retType == "void") || (bodyType == "null" && isObjectType retType) || isSubtype bodyType retType classes
then MethodDeclaration retType name params checkedBody
else error $ "Return type mismatch in method " ++ name ++ ": expected " ++ retType ++ ", found " ++ bodyType
else error $ "Method Declaration: Return type mismatch in method " ++ name ++ ": expected " ++ retType ++ ", found " ++ bodyType
typeCheckVariableDeclaration :: VariableDeclaration -> [(Identifier, DataType)] -> [Class] -> VariableDeclaration
typeCheckVariableDeclaration (VariableDeclaration dataType identifier maybeExpr) symtab classes =
let
-- Ensure the type is valid (either a primitive type or a valid class name)
validType = dataType `elem` ["int", "boolean", "char"] || isUserDefinedClass dataType classes
-- Ensure no redefinition in the same scope
redefined = any ((== identifier) . snd) symtab
-- Type check the initializer expression if it exists
checkedExpr = fmap (\expr -> typeCheckExpression expr symtab classes) maybeExpr
exprType = fmap getTypeFromExpr checkedExpr
checkedExprWithType = case exprType of
Just "null" | isObjectType dataType -> Just (TypedExpression dataType NullLiteral)
_ -> checkedExpr
in case (validType, redefined, exprType) of
(False, _, _) -> error $ "Type '" ++ dataType ++ "' is not a valid type for variable '" ++ identifier ++ "'"
(_, True, _) -> error $ "Variable '" ++ identifier ++ "' is redefined in the same scope"
(_, _, Just t)
| t == "null" && isObjectType dataType -> VariableDeclaration dataType identifier checkedExprWithType
| t /= dataType -> error $ "Type mismatch in declaration of '" ++ identifier ++ "': expected " ++ dataType ++ ", found " ++ t
| otherwise -> VariableDeclaration dataType identifier checkedExprWithType
(_, _, Nothing) -> VariableDeclaration dataType identifier checkedExprWithType
-- ********************************** Type Checking: Expressions **********************************
@ -46,8 +67,9 @@ typeCheckExpression (Reference id) symtab classes =
in case classDetails of
Just (Class _ _ fields) ->
let fieldTypes = [dt | VariableDeclaration dt fieldId _ <- fields, fieldId == id]
-- this case only happens when its a field of its own class so the implicit this will be converted to explicit this
in case fieldTypes of
[fieldType] -> TypedExpression fieldType (FieldVariable id)
[fieldType] -> TypedExpression fieldType (BinaryOperation NameResolution (TypedExpression className (LocalVariable "this")) (TypedExpression fieldType (FieldVariable id)))
[] -> error $ "Field '" ++ id ++ "' not found in class '" ++ className ++ "'"
_ -> error $ "Ambiguous reference to field '" ++ id ++ "' in class '" ++ className ++ "'"
Nothing -> error $ "Class '" ++ className ++ "' not found for 'this'"
@ -107,35 +129,50 @@ typeCheckStatementExpression (Assignment ref expr) symtab classes =
ref' = typeCheckExpression ref symtab classes
type' = getTypeFromExpr expr'
type'' = getTypeFromExpr ref'
typeToAssign = if type' == "null" && isObjectType type'' then type'' else type'
exprWithType = if type' == "null" && isObjectType type'' then TypedExpression type'' NullLiteral else expr'
in
if type'' == type' || (type' == "null" && isObjectType type'') then
TypedStatementExpression type'' (Assignment ref' expr')
if type'' == typeToAssign then
TypedStatementExpression type'' (Assignment ref' exprWithType)
else
error $ "Type mismatch in assignment to variable: expected " ++ type'' ++ ", found " ++ type'
error $ "Type mismatch in assignment to variable: expected " ++ type'' ++ ", found " ++ typeToAssign
typeCheckStatementExpression (ConstructorCall className args) symtab classes =
case find (\(Class name _ _) -> name == className) classes of
Nothing -> error $ "Class '" ++ className ++ "' not found."
Just (Class _ methods fields) ->
-- Constructor needs the same name as the class
case find (\(MethodDeclaration retType name params _) -> name == className && retType == className) methods of
Nothing -> error $ "No valid constructor found for class '" ++ className ++ "'."
Just (Class _ methods _) ->
-- Find constructor matching the class name with void return type
case find (\(MethodDeclaration _ name params _) -> name == "<init>") methods of
-- If no constructor is found, assume standard constructor with no parameters
Nothing ->
if null args then
TypedStatementExpression className (ConstructorCall className args)
else
error $ "No valid constructor found for class '" ++ className ++ "', but arguments were provided."
Just (MethodDeclaration _ _ params _) ->
let
args' = map (\arg -> typeCheckExpression arg symtab classes) args
-- Extract expected parameter types from the constructor's parameters
expectedTypes = [dataType | ParameterDeclaration dataType _ <- params]
argTypes = map getTypeFromExpr args'
-- Check if the types of the provided arguments match the expected types
typeMatches = zipWith (\expected actual -> if expected == actual then Nothing else Just (expected, actual)) expectedTypes argTypes
mismatchErrors = map (\(exp, act) -> "Expected type '" ++ exp ++ "', found '" ++ act ++ "'.") (catMaybes typeMatches)
let args' = zipWith
(\arg (ParameterDeclaration paramType _) ->
let argTyped = typeCheckExpression arg symtab classes
in if getTypeFromExpr argTyped == "null" && isObjectType paramType
then TypedExpression paramType NullLiteral
else argTyped
) args params
expectedTypes = [dataType | ParameterDeclaration dataType _ <- params]
argTypes = map getTypeFromExpr args'
typeMatches = zipWith
(\expType argType -> (expType == argType || (argType == "null" && isObjectType expType), expType, argType))
expectedTypes argTypes
mismatches = filter (not . fst3) typeMatches
fst3 (a, _, _) = a
in
if length args /= length params then
error $ "Constructor for class '" ++ className ++ "' expects " ++ show (length params) ++ " arguments, but got " ++ show (length args) ++ "."
else if not (null mismatchErrors) then
error $ unlines $ ("Type mismatch in constructor arguments for class '" ++ className ++ "':") : mismatchErrors
else
if null mismatches && length args == length params then
TypedStatementExpression className (ConstructorCall className args')
else if not (null mismatches) then
error $ unlines $ ("Type mismatch in constructor arguments for class '" ++ className ++ "':")
: [ "Expected: " ++ expType ++ ", Found: " ++ argType | (_, expType, argType) <- mismatches ]
else
error $ "Incorrect number of arguments for constructor of class '" ++ className ++ "'. Expected " ++ show (length expectedTypes) ++ ", found " ++ show (length args) ++ "."
typeCheckStatementExpression (MethodCall expr methodName args) symtab classes =
let objExprTyped = typeCheckExpression expr symtab classes
@ -145,24 +182,30 @@ typeCheckStatementExpression (MethodCall expr methodName args) symtab classes =
Just (Class _ methods _) ->
case find (\(MethodDeclaration retType name params _) -> name == methodName) methods of
Just (MethodDeclaration retType _ params _) ->
let args' = map (\arg -> typeCheckExpression arg symtab classes) args
let args' = zipWith
(\arg (ParameterDeclaration paramType _) ->
let argTyped = typeCheckExpression arg symtab classes
in if getTypeFromExpr argTyped == "null" && isObjectType paramType
then TypedExpression paramType NullLiteral
else argTyped
) args params
expectedTypes = [dataType | ParameterDeclaration dataType _ <- params]
argTypes = map getTypeFromExpr args'
typeMatches = zipWith (\expType argType -> (expType == argType, expType, argType)) expectedTypes argTypes
typeMatches = zipWith
(\expType argType -> (expType == argType || (argType == "null" && isObjectType expType), expType, argType))
expectedTypes argTypes
mismatches = filter (not . fst3) typeMatches
where fst3 (a, _, _) = a
in
if null mismatches && length args == length params then
TypedStatementExpression retType (MethodCall objExprTyped methodName args')
else if not (null mismatches) then
error $ unlines $ ("Argument type mismatches for method '" ++ methodName ++ "':")
fst3 (a, _, _) = a
in if null mismatches && length args == length params
then TypedStatementExpression retType (MethodCall objExprTyped methodName args')
else if not (null mismatches)
then error $ unlines $ ("Argument type mismatches for method '" ++ methodName ++ "':")
: [ "Expected: " ++ expType ++ ", Found: " ++ argType | (_, expType, argType) <- mismatches ]
else
error $ "Incorrect number of arguments for method '" ++ methodName ++ "'. Expected " ++ show (length expectedTypes) ++ ", found " ++ show (length args) ++ "."
else error $ "Incorrect number of arguments for method '" ++ methodName ++ "'. Expected " ++ show (length expectedTypes) ++ ", found " ++ show (length args) ++ "."
Nothing -> error $ "Method '" ++ methodName ++ "' not found in class '" ++ objType ++ "'."
Nothing -> error $ "Class for object type '" ++ objType ++ "' not found."
_ -> error "Invalid object type for method call. Object must have a class type."
typeCheckStatementExpression (PostIncrement expr) symtab classes =
let expr' = typeCheckExpression expr symtab classes
type' = getTypeFromExpr expr'
@ -203,16 +246,22 @@ typeCheckStatementExpression (PreDecrement expr) symtab classes =
typeCheckStatement :: Statement -> [(Identifier, DataType)] -> [Class] -> Statement
typeCheckStatement (If cond thenStmt elseStmt) symtab classes =
let cond' = typeCheckExpression cond symtab classes
thenStmt' = typeCheckStatement thenStmt symtab classes
elseStmt' = case elseStmt of
Just stmt -> Just (typeCheckStatement stmt symtab classes)
Nothing -> Nothing
in if getTypeFromExpr cond' == "boolean"
then
TypedStatement (getTypeFromStmt thenStmt') (If cond' thenStmt' elseStmt')
else
error "If condition must be of type boolean"
let
cond' = typeCheckExpression cond symtab classes
thenStmt' = typeCheckStatement thenStmt symtab classes
elseStmt' = fmap (\stmt -> typeCheckStatement stmt symtab classes) elseStmt
thenType = getTypeFromStmt thenStmt'
elseType = maybe "void" getTypeFromStmt elseStmt'
ifType = if thenType == "void" || elseType == "void"
then "void"
else unifyReturnTypes thenType elseType
in if getTypeFromExpr cond' == "boolean"
then TypedStatement ifType (If cond' thenStmt' elseStmt')
else error "If condition must be of type boolean"
typeCheckStatement (LocalVariableDeclaration (VariableDeclaration dataType identifier maybeExpr)) symtab classes =
-- Check for redefinition in the current scope
@ -222,14 +271,18 @@ typeCheckStatement (LocalVariableDeclaration (VariableDeclaration dataType ident
-- If there's an initializer expression, type check it
let checkedExpr = fmap (\expr -> typeCheckExpression expr symtab classes) maybeExpr
exprType = fmap getTypeFromExpr checkedExpr
checkedExprWithType = case (exprType, dataType) of
(Just "null", _) | isObjectType dataType -> Just (TypedExpression dataType NullLiteral)
_ -> checkedExpr
in case exprType of
Just t
| t == "null" && isObjectType dataType ->
TypedStatement dataType (LocalVariableDeclaration (VariableDeclaration dataType identifier checkedExpr))
| t == "null" && isObjectType dataType ->
TypedStatement dataType (LocalVariableDeclaration (VariableDeclaration dataType identifier checkedExprWithType))
| t /= dataType -> error $ "Type mismatch in declaration of '" ++ identifier ++ "': expected " ++ dataType ++ ", found " ++ t
| otherwise -> TypedStatement dataType (LocalVariableDeclaration (VariableDeclaration dataType identifier checkedExpr))
| otherwise -> TypedStatement dataType (LocalVariableDeclaration (VariableDeclaration dataType identifier checkedExprWithType))
Nothing -> TypedStatement dataType (LocalVariableDeclaration (VariableDeclaration dataType identifier checkedExpr))
typeCheckStatement (While cond stmt) symtab classes =
let cond' = typeCheckExpression cond symtab classes
stmt' = typeCheckStatement stmt symtab classes
@ -242,37 +295,50 @@ typeCheckStatement (While cond stmt) symtab classes =
typeCheckStatement (Block statements) symtab classes =
let
processStatements (accSts, currentSymtab, types) stmt =
let
checkedStmt = typeCheckStatement stmt currentSymtab classes
stmtType = getTypeFromStmt checkedStmt
in case stmt of
case stmt of
LocalVariableDeclaration (VariableDeclaration dataType identifier maybeExpr) ->
let
alreadyDefined = any (\(id, _) -> id == identifier) currentSymtab
newSymtab = if alreadyDefined
then error ("Variable " ++ identifier ++ " already defined in this scope.")
else (identifier, dataType) : currentSymtab
checkedExpr = fmap (\expr -> typeCheckExpression expr currentSymtab classes) maybeExpr
newSymtab = (identifier, dataType) : currentSymtab
checkedStmt = typeCheckStatement stmt newSymtab classes
in (accSts ++ [checkedStmt], newSymtab, types)
If {} -> (accSts ++ [checkedStmt], currentSymtab, if stmtType /= "void" then types ++ [stmtType] else types)
While _ _ -> (accSts ++ [checkedStmt], currentSymtab, if stmtType /= "void" then types ++ [stmtType] else types)
Return _ -> (accSts ++ [checkedStmt], currentSymtab, if stmtType /= "void" then types ++ [stmtType] else types)
Block _ -> (accSts ++ [checkedStmt], currentSymtab, if stmtType /= "void" then types ++ [stmtType] else types)
_ -> (accSts ++ [checkedStmt], currentSymtab, types)
_ ->
let
checkedStmt = typeCheckStatement stmt currentSymtab classes
stmtType = getTypeFromStmt checkedStmt
in case stmt of
If {} -> (accSts ++ [checkedStmt], currentSymtab, if stmtType /= "void" then types ++ [stmtType] else types)
While _ _ -> (accSts ++ [checkedStmt], currentSymtab, if stmtType /= "void" then types ++ [stmtType] else types)
Return _ -> (accSts ++ [checkedStmt], currentSymtab, if stmtType /= "void" then types ++ [stmtType] else types)
Block _ -> (accSts ++ [checkedStmt], currentSymtab, if stmtType /= "void" then types ++ [stmtType] else types)
_ -> (accSts ++ [checkedStmt], currentSymtab, types)
-- Initial accumulator: empty statements list, initial symbol table, empty types list
(checkedStatements, finalSymtab, collectedTypes) = foldl processStatements ([], symtab, []) statements
-- Determine the block's type: unify all collected types, default to "Void" if none
-- Determine the block's type: unify all collected types, default to "void" if none (UpperBound)
blockType = if null collectedTypes then "void" else foldl1 unifyReturnTypes collectedTypes
in TypedStatement blockType (Block checkedStatements)
typeCheckStatement (Return expr) symtab classes =
let expr' = case expr of
Just e -> Just (typeCheckExpression e symtab classes)
let methodReturnType = fromMaybe (error "Method return type not found in symbol table") (lookup "thisMeth" symtab)
expr' = case expr of
Just e -> let eTyped = typeCheckExpression e symtab classes
in if getTypeFromExpr eTyped == "null" && isObjectType methodReturnType
then Just (TypedExpression methodReturnType NullLiteral)
else Just eTyped
Nothing -> Nothing
in case expr' of
Just e' -> TypedStatement (getTypeFromExpr e') (Return (Just e'))
Nothing -> TypedStatement "void" (Return Nothing)
returnType = maybe "void" getTypeFromExpr expr'
in if returnType == methodReturnType || isSubtype returnType methodReturnType classes
then TypedStatement returnType (Return expr')
else error $ "Return: Return type mismatch: expected " ++ methodReturnType ++ ", found " ++ returnType
typeCheckStatement (StatementExpressionStatement stmtExpr) symtab classes =
let stmtExpr' = typeCheckStatementExpression stmtExpr symtab classes
@ -280,6 +346,17 @@ typeCheckStatement (StatementExpressionStatement stmtExpr) symtab classes =
-- ********************************** Type Checking: Helpers **********************************
isSubtype :: DataType -> DataType -> [Class] -> Bool
isSubtype subType superType classes
| subType == superType = True
| subType == "null" && isObjectType superType = True
| superType == "Object" && isObjectType subType = True
| superType == "Object" && isUserDefinedClass subType classes = True
| otherwise = False
isUserDefinedClass :: DataType -> [Class] -> Bool
isUserDefinedClass dt classes = dt `elem` map (\(Class name _ _) -> name) classes
isObjectType :: DataType -> Bool
isObjectType dt = dt /= "int" && dt /= "boolean" && dt /= "char"
@ -297,8 +374,10 @@ getTypeFromStmtExpr _ = error "Untyped statement expression found where typed wa
unifyReturnTypes :: DataType -> DataType -> DataType
unifyReturnTypes dt1 dt2
| dt1 == dt2 = dt1
| otherwise = "Object"
| dt1 == dt2 = dt1
| dt1 == "null" = dt2
| dt2 == "null" = dt1
| otherwise = "Object"
resolveResultType :: DataType -> DataType -> DataType
resolveResultType "char" "char" = "char"
@ -319,7 +398,7 @@ checkBitwiseOperation :: BinaryOperator -> Expression -> Expression -> DataType
checkBitwiseOperation op expr1' expr2' type1 type2
| type1 == "int" && type2 == "int" =
TypedExpression "int" (BinaryOperation op expr1' expr2')
| otherwise = error $ "Bitwise operation " ++ show op ++ " requires operands of type int"
| otherwise = error $ "Bitwise operation " ++ show op ++ " requires operands of type int or char"
checkComparisonOperation :: BinaryOperator -> Expression -> Expression -> DataType -> DataType -> Expression
checkComparisonOperation op expr1' expr2' type1 type2