src/ByteCode/Builder.hs

@@ -57,7 +57,6 @@ methodBuilder (MethodDeclaration returntype name parameters statement) input = l
         }
         
 
-
 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
@@ -170,7 +211,7 @@ 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
     in
         fieldsResolved
@@ -243,3 +284,54 @@ injectFieldInitializers classname vars pre = let
                 MethodDeclaration "void" "<init>" params (TypedStatement "void" (Block statements)) -> MethodDeclaration "void" "<init>" params (TypedStatement "void" (Block (initializers ++ statements)))
                 otherwise -> 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)