MisterChaos69/MiniJavaCompiler
2
2
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

else Assembly

Browse Source
This commit is contained in:
mrab 2024-05-14 13:57:20 +02:00
parent 95178366a2
commit a179dec3ea
1 changed files with 43 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

81
src/ByteCode/ClassFile/Generator.hs
View File

@ -52,7 +52,7 @@ memberInfoDescriptor constants MemberInfo {
descriptor = constants!!((fromIntegral descriptorIndex) - 1) descriptor = constants!!((fromIntegral descriptorIndex) - 1)
in case descriptor of in case descriptor of
Utf8Info descriptorText -> descriptorText Utf8Info descriptorText -> descriptorText
_ -> ("Invalid Item at Constant pool index " ++ show descriptorIndex) _ -> ("Invalid Item at Constant pool index " ++ show descriptorIndex)
memberInfoName :: [ConstantInfo] -> MemberInfo -> String memberInfoName :: [ConstantInfo] -> MemberInfo -> String
@ -64,11 +64,11 @@ memberInfoName constants MemberInfo {
name = constants!!((fromIntegral nameIndex) - 1) name = constants!!((fromIntegral nameIndex) - 1)
in case name of in case name of
Utf8Info nameText -> nameText Utf8Info nameText -> nameText
_ -> ("Invalid Item at Constant pool index " ++ show nameIndex) _ -> ("Invalid Item at Constant pool index " ++ show nameIndex)
methodDescriptor :: MethodDeclaration -> String methodDescriptor :: MethodDeclaration -> String
methodDescriptor (MethodDeclaration returntype _ parameters _) = let methodDescriptor (MethodDeclaration returntype _ parameters _) = let
parameter_types = [datatype | ParameterDeclaration datatype _ <- parameters] parameter_types = [datatype | ParameterDeclaration datatype _ <- parameters]
in in
"(" "("
@ -104,8 +104,8 @@ classBuilder (Class name methods fields) _ = let
classFileWithAssembledMethods = foldr methodAssembler classFileWithMethods methods classFileWithAssembledMethods = foldr methodAssembler classFileWithMethods methods
in in
classFileWithAssembledMethods classFileWithAssembledMethods
fieldBuilder :: ClassFileBuilder VariableDeclaration fieldBuilder :: ClassFileBuilder VariableDeclaration
fieldBuilder (VariableDeclaration datatype name _) input = let fieldBuilder (VariableDeclaration datatype name _) input = let
@ -135,7 +135,7 @@ methodBuilder (MethodDeclaration returntype name parameters statement) input = l
Utf8Info name, Utf8Info name,
Utf8Info (methodDescriptor (MethodDeclaration returntype name parameters (Block []))) Utf8Info (methodDescriptor (MethodDeclaration returntype name parameters (Block [])))
] ]
method = MemberInfo { method = MemberInfo {
memberAccessFlags = accessPublic, memberAccessFlags = accessPublic,
memberNameIndex = (fromIntegral baseIndex), memberNameIndex = (fromIntegral baseIndex),
@ -157,7 +157,7 @@ methodAssembler (MethodDeclaration returntype name parameters statement) input =
Just index -> let Just index -> let
declaration = MethodDeclaration returntype name parameters statement declaration = MethodDeclaration returntype name parameters statement
(pre, method : post) = splitAt index (methods input) (pre, method : post) = splitAt index (methods input)
(_, bytecode) = assembleMethod declaration (constantPool input, []) (_, bytecode) = assembleMethod (constantPool input, []) declaration
assembledMethod = method { assembledMethod = method {
memberAttributes = [ memberAttributes = [
CodeAttribute { CodeAttribute {
@ -171,11 +171,11 @@ methodAssembler (MethodDeclaration returntype name parameters statement) input =
input { input {
methods = pre ++ (assembledMethod : post) methods = pre ++ (assembledMethod : post)
} }
type Assembler a = a -> ([ConstantInfo], [Operation]) -> ([ConstantInfo], [Operation])
type Assembler a = ([ConstantInfo], [Operation]) -> a -> ([ConstantInfo], [Operation])
returnOperation :: DataType -> Operation returnOperation :: DataType -> Operation
returnOperation dtype returnOperation dtype
@ -201,67 +201,72 @@ comparisonOperation CompareGreaterOrEqual branchLocation = Opif_icmpge branchLoc
assembleMethod :: Assembler MethodDeclaration assembleMethod :: Assembler MethodDeclaration
assembleMethod (MethodDeclaration _ name _ (TypedStatement _ (Block statements))) (constants, ops) assembleMethod (constants, ops) (MethodDeclaration _ name _ (TypedStatement _ (Block statements)))
| name == "<init>" = let | name == "<init>" = let
(constants_a, ops_a) = foldr assembleStatement (constants, ops) statements (constants_a, ops_a) = foldl assembleStatement (constants, ops) statements
init_ops = [Opaload 0, Opinvokespecial 2] init_ops = [Opaload 0, Opinvokespecial 2]
in in
(constants_a, init_ops ++ ops_a ++ [Opreturn]) (constants_a, init_ops ++ ops_a ++ [Opreturn])
| otherwise = let | otherwise = let
(constants_a, ops_a) = foldr assembleStatement (constants, ops) statements (constants_a, ops_a) = foldl assembleStatement (constants, ops) statements
init_ops = [Opaload 0] init_ops = [Opaload 0]
in in
(constants_a, init_ops ++ ops_a) (constants_a, init_ops ++ ops_a)
assembleMethod (MethodDeclaration _ _ _ stmt) (_, _) = error ("Block expected for method body, got: " ++ show stmt) assembleMethod _ (MethodDeclaration _ _ _ stmt) = error ("Block expected for method body, got: " ++ show stmt)
assembleStatement :: Assembler Statement assembleStatement :: Assembler Statement
assembleStatement (TypedStatement stype (Return expr)) (constants, ops) = case expr of assembleStatement (constants, ops) (TypedStatement stype (Return expr)) = case expr of
Nothing -> (constants, ops ++ [Opreturn]) Nothing -> (constants, ops ++ [Opreturn])
Just expr -> let Just expr -> let
(expr_constants, expr_ops) = assembleExpression expr (constants, ops) (expr_constants, expr_ops) = assembleExpression (constants, ops) expr
in in
(expr_constants, expr_ops ++ [returnOperation stype]) (expr_constants, expr_ops ++ [returnOperation stype])
assembleStatement (TypedStatement _ (Block statements)) (constants, ops) = assembleStatement (constants, ops) (TypedStatement _ (Block statements)) =
foldr assembleStatement (constants, ops) statements foldl assembleStatement (constants, ops) statements
assembleStatement (TypedStatement _ (If expr if_stmt else_stmt)) (constants, ops) = let assembleStatement (constants, ops) (TypedStatement _ (If expr if_stmt else_stmt)) = let
(constants_cmp, ops_cmp) = assembleExpression expr (constants, []) (constants_cmp, ops_cmp) = assembleExpression (constants, []) expr
(constants_ifa, ops_ifa) = assembleStatement if_stmt (constants_cmp, []) (constants_ifa, ops_ifa) = assembleStatement (constants_cmp, []) if_stmt
skip_length = sum (map opcodeEncodingLength ops_ifa) (constants_elsea, ops_elsea) = case else_stmt of
Nothing -> (constants_ifa, [])
Just stmt -> assembleStatement (constants_ifa, []) stmt
-- +6 because we insert 2 gotos, one for if, one for else
if_length = sum (map opcodeEncodingLength ops_ifa) + 6
else_length = sum (map opcodeEncodingLength ops_ifa)
in in
(constants_ifa, ops ++ ops_cmp ++ [Opsipush 0, Opif_icmpeq skip_length] ++ ops_ifa) (constants_ifa, ops ++ ops_cmp ++ [Opsipush 0, Opif_icmpeq if_length] ++ ops_ifa ++ [Opgoto else_length] ++ ops_elsea)
assembleStatement stmt _ = error ("Not yet implemented: " ++ show stmt)
assembleExpression :: Assembler Expression assembleExpression :: Assembler Expression
assembleExpression (TypedExpression _ (BinaryOperation op a b)) (constants, ops) assembleExpression (constants, ops) (TypedExpression _ (BinaryOperation op a b))
| elem op [Addition, Subtraction, Multiplication, Division, BitwiseAnd, BitwiseOr, BitwiseXor] = let | elem op [Addition, Subtraction, Multiplication, Division, BitwiseAnd, BitwiseOr, BitwiseXor] = let
(aConstants, aOps) = assembleExpression a (constants, ops) (aConstants, aOps) = assembleExpression (constants, ops) a
(bConstants, bOps) = assembleExpression b (aConstants, aOps) (bConstants, bOps) = assembleExpression (aConstants, aOps) b
in in
(bConstants, bOps ++ [binaryOperation op]) (bConstants, bOps ++ [binaryOperation op])
| elem op [CompareEqual, CompareNotEqual, CompareLessThan, CompareLessOrEqual, CompareGreaterThan, CompareGreaterOrEqual] = let | elem op [CompareEqual, CompareNotEqual, CompareLessThan, CompareLessOrEqual, CompareGreaterThan, CompareGreaterOrEqual] = let
(aConstants, aOps) = assembleExpression a (constants, ops) (aConstants, aOps) = assembleExpression (constants, ops) a
(bConstants, bOps) = assembleExpression b (aConstants, aOps) (bConstants, bOps) = assembleExpression (aConstants, aOps) b
cmp_op = comparisonOperation op 9 cmp_op = comparisonOperation op 9
cmp_ops = [cmp_op, Opsipush 0, Opgoto 6, Opsipush 1] cmp_ops = [cmp_op, Opsipush 0, Opgoto 6, Opsipush 1]
in in
(bConstants, bOps ++ cmp_ops) (bConstants, bOps ++ cmp_ops)
assembleExpression (TypedExpression _ (CharacterLiteral literal)) (constants, ops) = assembleExpression (constants, ops) (TypedExpression _ (CharacterLiteral literal)) =
(constants, ops ++ [Opsipush (fromIntegral (ord literal))]) (constants, ops ++ [Opsipush (fromIntegral (ord literal))])
assembleExpression (TypedExpression _ (BooleanLiteral literal)) (constants, ops) = assembleExpression (constants, ops) (TypedExpression _ (BooleanLiteral literal)) =
(constants, ops ++ [Opsipush (if literal then 1 else 0)]) (constants, ops ++ [Opsipush (if literal then 1 else 0)])
assembleExpression (TypedExpression _ (IntegerLiteral literal)) (constants, ops) assembleExpression (constants, ops) (TypedExpression _ (IntegerLiteral literal))
| literal <= 32767 && literal >= -32768 = (constants, ops ++ [Opsipush (fromIntegral literal)]) | literal <= 32767 && literal >= -32768 = (constants, ops ++ [Opsipush (fromIntegral literal)])
| otherwise = (constants ++ [IntegerInfo (fromIntegral literal)], ops ++ [Opldc_w (fromIntegral (1 + length constants))]) | otherwise = (constants ++ [IntegerInfo (fromIntegral literal)], ops ++ [Opldc_w (fromIntegral (1 + length constants))])
assembleExpression (TypedExpression _ NullLiteral) (constants, ops) = assembleExpression (constants, ops) (TypedExpression _ NullLiteral) =
(constants, ops ++ [Opaconst_null]) (constants, ops ++ [Opaconst_null])
assembleExpression (TypedExpression etype (UnaryOperation Not expr)) (constants, ops) = let assembleExpression (constants, ops) (TypedExpression etype (UnaryOperation Not expr)) = let
(exprConstants, exprOps) = assembleExpression expr (constants, ops) (exprConstants, exprOps) = assembleExpression (constants, ops) expr
newConstant = fromIntegral (1 + length exprConstants) newConstant = fromIntegral (1 + length exprConstants)
in case etype of in case etype of
"int" -> (exprConstants ++ [IntegerInfo 0x7FFFFFFF], exprOps ++ [Opldc_w newConstant, Opixor]) "int" -> (exprConstants ++ [IntegerInfo 0x7FFFFFFF], exprOps ++ [Opldc_w newConstant, Opixor])
"char" -> (exprConstants, exprOps ++ [Opsipush 0xFFFF, Opixor]) "char" -> (exprConstants, exprOps ++ [Opsipush 0xFFFF, Opixor])
"boolean" -> (exprConstants, exprOps ++ [Opsipush 0x01, Opixor]) "boolean" -> (exprConstants, exprOps ++ [Opsipush 0x01, Opixor])
assembleExpression (TypedExpression _ (UnaryOperation Minus expr)) (constants, ops) = let assembleExpression (constants, ops) (TypedExpression _ (UnaryOperation Minus expr)) = let
(exprConstants, exprOps) = assembleExpression expr (constants, ops) (exprConstants, exprOps) = assembleExpression (constants, ops) expr
in in
(exprConstants, exprOps ++ [Opineg]) (exprConstants, exprOps ++ [Opineg])