diff --git a/Test/JavaSources/Main.java b/Test/JavaSources/Main.java index ca1eb22..aa84965 100644 --- a/Test/JavaSources/Main.java +++ b/Test/JavaSources/Main.java @@ -1,7 +1,7 @@ // compile all test files using: // ls Test/JavaSources/*.java | grep -v ".*Main.java" | xargs -I {} cabal run compiler {} // compile (in project root) using: -// javac -g:none -sourcepath Test/JavaSources/ Test/JavaSources/Main.java +// javac -g:none -sourcepath Test/JavaSources/ Test/JavaSources/Main.java // afterwards, run using // java -ea -cp Test/JavaSources/ Main diff --git a/src/ByteCode/Builder.hs b/src/ByteCode/Builder.hs index 258592a..f7e9e00 100644 --- a/src/ByteCode/Builder.hs +++ b/src/ByteCode/Builder.hs @@ -50,14 +50,13 @@ methodBuilder (MethodDeclaration returntype name parameters statement) input = l memberDescriptorIndex = (fromIntegral (baseIndex + 3)), memberAttributes = [] } - in + 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 @@ -73,7 +72,7 @@ methodAssembler (MethodDeclaration returntype name parameters statement) input = assembledMethod = method { memberAttributes = [ CodeAttribute { - attributeMaxStack = 420, + attributeMaxStack = fromIntegral $ maxStackDepth constants bytecode, attributeMaxLocals = fromIntegral $ length aParamNames, attributeCode = bytecode } diff --git a/src/ByteCode/Util.hs b/src/ByteCode/Util.hs index 45e8816..4271e11 100644 --- a/src/ByteCode/Util.hs +++ b/src/ByteCode/Util.hs @@ -4,7 +4,7 @@ import Data.Int import Ast import ByteCode.ClassFile import Data.List -import Data.Maybe (mapMaybe) +import Data.Maybe (mapMaybe, isJust) import Data.Word (Word8, Word16, Word32) -- walks the name resolution chain. returns the innermost Just LocalVariable/FieldVariable or Nothing. @@ -12,13 +12,13 @@ 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)) +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)) +resolveNameChainOwner invalidExpression = error ("expected a NameResolution or Local/Field Variable but got: " ++ show (invalidExpression)) methodDescriptor :: MethodDeclaration -> String @@ -39,10 +39,39 @@ methodDescriptorFromParamlist parameters returntype = let ++ ")" ++ datatypeDescriptor returntype +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) ('B' : descriptor) = parseMethodType (params ++ ["B"], 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, B) 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" @@ -100,6 +129,18 @@ comparisonOperation CompareLessOrEqual branchLocation = Opif_icmple branchLoc 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) + findFieldIndex :: [ConstantInfo] -> String -> Maybe Int findFieldIndex constants name = let fieldRefNameInfos = [ @@ -143,10 +184,10 @@ findMethodIndex classFile name = let findClassIndex :: [ConstantInfo] -> String -> Maybe Int findClassIndex constants name = let - classNameIndices = [(index, constants!!(fromIntegral nameIndex - 1)) | (index, ClassInfo nameIndex) <- (zip[1..] constants)] + 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)) + something_else -> error ("Expected UTF8Info but got " ++ show something_else)) classNameIndices desiredClassIndex = find (\(index, className) -> className == name) classNames in case desiredClassIndex of @@ -162,7 +203,7 @@ getKnownMembers constants = let (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)) @@ -170,8 +211,8 @@ getKnownMembers constants = let 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 + something_else -> error ("Expected UTF8Infos but got " ++ show something_else)) + fieldsClassNameType in fieldsResolved @@ -223,7 +264,7 @@ injectDefaultConstructor pre | otherwise = pre ++ [MethodDeclaration "void" "" [] (TypedStatement "void" (Block []))] injectFieldInitializers :: String -> [VariableDeclaration] -> [MethodDeclaration] -> [MethodDeclaration] -injectFieldInitializers classname vars pre = let +injectFieldInitializers classname vars pre = let initializers = mapMaybe (\(variable) -> case variable of VariableDeclaration dtype name (Just initializer) -> Just ( TypedStatement dtype ( @@ -242,4 +283,55 @@ injectFieldInitializers classname vars pre = let map (\(method) -> case method of MethodDeclaration "void" "" params (TypedStatement "void" (Block statements)) -> MethodDeclaration "void" "" params (TypedStatement "void" (Block (initializers ++ statements))) otherwise -> method - ) pre \ No newline at end of file + ) 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)