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
 

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
                                 }

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))
+            something_else -> error ("Expected UTF8Infos but got " ++ show something_else))
-                fieldsClassNameType    
+                fieldsClassNameType
     in
         fieldsResolved
 
@@ -223,7 +264,7 @@ injectDefaultConstructor pre
     | otherwise = pre ++ [MethodDeclaration "void" "<init>" [] (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" "<init>" params (TypedStatement "void" (Block statements)) -> MethodDeclaration "void" "<init>" params (TypedStatement "void" (Block (initializers ++ statements)))
                 otherwise -> method
-            ) pre
+            ) 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)