From 613a280079ac38cf451bc507f7a875dfd8ee55a4 Mon Sep 17 00:00:00 2001 From: mrab Date: Thu, 13 Jun 2024 20:17:23 +0200 Subject: [PATCH] Method & constructor calls fully working --- src/ByteCode/ClassFile.hs | 3 ++ src/ByteCode/Generator.hs | 105 ++++++++++++++++++++++++++------------ src/Main.hs | 1 + 3 files changed, 77 insertions(+), 32 deletions(-) diff --git a/src/ByteCode/ClassFile.hs b/src/ByteCode/ClassFile.hs index 856781d..9bedee7 100644 --- a/src/ByteCode/ClassFile.hs +++ b/src/ByteCode/ClassFile.hs @@ -34,6 +34,7 @@ data Operation = Opiadd | Opixor | Opineg | Opdup + | Opnew Word16 | Opif_icmplt Word16 | Opif_icmple Word16 | Opif_icmpgt Word16 @@ -106,6 +107,7 @@ 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 @@ -161,6 +163,7 @@ instance Serializable Operation where 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 diff --git a/src/ByteCode/Generator.hs b/src/ByteCode/Generator.hs index 61d53d3..8b64383 100644 --- a/src/ByteCode/Generator.hs +++ b/src/ByteCode/Generator.hs @@ -29,6 +29,15 @@ methodDescriptor (MethodDeclaration returntype _ parameters _) = let ++ ")" ++ datatypeDescriptor returntype +methodDescriptorFromParamlist :: [Expression] -> String -> String +methodDescriptorFromParamlist parameters returntype = let + parameter_types = [datatype | TypedExpression datatype _ <- parameters] + in + "(" + ++ (concat (map datatypeDescriptor parameter_types)) + ++ ")" + ++ datatypeDescriptor returntype + memberInfoIsMethod :: [ConstantInfo] -> MemberInfo -> Bool memberInfoIsMethod constants info = elem '(' (memberInfoDescriptor constants info) @@ -40,6 +49,7 @@ datatypeDescriptor "char" = "C" datatypeDescriptor "boolean" = "B" datatypeDescriptor x = "L" ++ x ++ ";" + memberInfoDescriptor :: [ConstantInfo] -> MemberInfo -> String memberInfoDescriptor constants MemberInfo { memberAccessFlags = _, @@ -185,6 +195,20 @@ getFieldIndex constants (cname, fname, ftype) = case findMemberIndex constants ( 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 @@ -214,6 +238,18 @@ fieldBuilder (VariableDeclaration datatype name _) input = let fields = (fields input) ++ [field] } +-- 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)) methodBuilder :: ClassFileBuilder MethodDeclaration methodBuilder (MethodDeclaration returntype name parameters statement) input = let @@ -351,11 +387,6 @@ assembleExpression (constants, ops, lvars) (TypedExpression _ (UnaryOperation Mi in (exprConstants, exprOps ++ [Opineg], lvars) - ---assembleExpression (constants, ops, lvars) (TypedExpression dtype (FieldVariable name)) = --- assembleExpression (constants, ops, lvars) (TypedExpression dtype (BinaryOperation NameResolution ())) - - assembleExpression (constants, ops, lvars) (TypedExpression dtype (LocalVariable name)) | name == "this" = (constants, ops ++ [Opaload 0], lvars) | otherwise = let @@ -370,29 +401,36 @@ assembleExpression (constants, ops, lvars) (TypedExpression dtype (StatementExpr assembleExpression _ expr = error ("unimplemented: " ++ 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 -- TODO untested assembleStatementExpression :: Assembler StatementExpression assembleStatementExpression (constants, ops, lvars) - (TypedStatementExpression _ (Assignment (TypedExpression dtype (LocalVariable name)) expr)) = let - localIndex = findIndex ((==) 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 [Opistore (fromIntegral index)] else [Opastore (fromIntegral index)], lvars) - Nothing -> error ("No such local variable found in local variable pool: " ++ name) - -assembleStatementExpression - (constants, ops, lvars) - (TypedStatementExpression _ (Assignment (TypedExpression dtype (FieldVariable name)) expr)) = let - fieldIndex = findFieldIndex constants name - (constants_a, ops_a, _) = assembleExpression (constants, ops ++ [Opaload 0], lvars) expr - in case fieldIndex of - Just index -> (constants_a, ops_a ++ [Opputfield (fromIntegral index)], lvars) - Nothing -> error ("No such field variable found in constant pool: " ++ name) + (TypedStatementExpression _ (Assignment (TypedExpression dtype receiver) expr)) = let + target = resolveNameChain (TypedExpression dtype receiver) + in case target of + (TypedExpression dtype (LocalVariable name)) -> let + localIndex = findIndex ((==) 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 [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 @@ -485,16 +523,21 @@ assembleStatementExpression assembleStatementExpression (constants, ops, lvars) - (TypedStatementExpression _ (MethodCall receiver name params)) = let - (constants_r, ops_r, lvars_r) = assembleExpression (constants, ops, lvars) receiver + (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 - methodIndex = findMethodRefIndex constants name - in case methodIndex of - Just index -> (constants_p, ops_p ++ [Opinvokespecial (fromIntegral index)], lvars_p) - Nothing -> error("No such method found in constant pool: " ++ name) - - + (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, "", methodDescriptorFromParamlist params "void") + in + (constants_m, ops_p ++ [Opinvokespecial (fromIntegral methodIndex)], lvars_p) assembleStatement :: Assembler Statement @@ -549,8 +592,6 @@ assembleStatement (constants, ops, lvars) (TypedStatement _ (StatementExpression assembleStatement _ stmt = error ("Not yet implemented: " ++ show stmt) - - assembleMethod :: Assembler MethodDeclaration assembleMethod (constants, ops, lvars) (MethodDeclaration returntype name _ (TypedStatement _ (Block statements))) | name == "" = let diff --git a/src/Main.hs b/src/Main.hs index b009495..a6f8431 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -13,6 +13,7 @@ main = do let untypedAST = parse $ alexScanTokens file let typedAST = head (typeCheckCompilationUnit untypedAST) + --print typedAST let abstractClassFile = classBuilder typedAST emptyClassFile let assembledClassFile = pack (serialize abstractClassFile)