From 05cce6f0a2e886000341dca121736f29262c7087 Mon Sep 17 00:00:00 2001 From: Alexander Wood Date: Mon, 20 Nov 2023 15:33:43 +0000 Subject: [PATCH 01/23] save progress --- src/JVM/Data/Abstract/Instruction.hs | 11 +- src/JVM/Data/Analyse/Instruction.hs | 52 +++-- src/JVM/Data/Convert/Instruction.hs | 21 ++ src/JVM/Data/Raw/Instruction.hs | 8 +- test/Builder.hs | 320 ++++++++++++++++++--------- 5 files changed, 283 insertions(+), 129 deletions(-) diff --git a/src/JVM/Data/Abstract/Instruction.hs b/src/JVM/Data/Abstract/Instruction.hs index d6b5b05..dadc27b 100644 --- a/src/JVM/Data/Abstract/Instruction.hs +++ b/src/JVM/Data/Abstract/Instruction.hs @@ -11,8 +11,8 @@ import JVM.Data.Abstract.Builder.Label (Label) import JVM.Data.Abstract.ConstantPool import JVM.Data.Abstract.Descriptor import JVM.Data.Abstract.Type -import JVM.Data.Raw.Types import JVM.Data.Pretty +import JVM.Data.Raw.Types type Reference = Int @@ -33,6 +33,8 @@ data Instruction' label | InvokeInterface ClassInfoType Text MethodDescriptor | InvokeVirtual ClassInfoType Text MethodDescriptor | InvokeDynamic BootstrapMethod Text MethodDescriptor + | ILoad U1 + | IStore U1 | Label label | LDC LDCEntry | PutStatic ClassInfoType Text FieldType @@ -59,7 +61,9 @@ instance (Pretty label) => Pretty (Instruction' label) where pretty (InvokeInterface c n d) = "invokeinterface" <+> pretty c <> "." <> pretty n <> pretty d pretty (InvokeVirtual c n d) = "invokevirtual" <+> pretty c <> "." <> pretty n <> pretty d pretty (InvokeDynamic b n d) = "invokedynamic" <+> pretty b <> "." <> pretty n <> pretty d - pretty (Label l) = ":" <>pretty l + pretty (ILoad x) = "iload" <+> pretty x + pretty (IStore x) = "istore" <+> pretty x + pretty (Label l) = ":" <> pretty l pretty (LDC x) = "ldc" <+> pretty x pretty (PutStatic c n t) = "putstatic" <+> pretty c <> "." <> pretty n <+> pretty t pretty (GetField c n t) = "getfield" <+> pretty c <> "." <> pretty n <+> pretty t @@ -68,9 +72,6 @@ instance (Pretty label) => Pretty (Instruction' label) where pretty (CheckCast c) = "checkcast" <+> pretty c pretty Return = "return" - - - jumpTarget :: Instruction' label -> Maybe label jumpTarget (IfEq l) = Just l jumpTarget (IfNe l) = Just l diff --git a/src/JVM/Data/Analyse/Instruction.hs b/src/JVM/Data/Analyse/Instruction.hs index 0fd877c..12a4a7d 100644 --- a/src/JVM/Data/Analyse/Instruction.hs +++ b/src/JVM/Data/Analyse/Instruction.hs @@ -4,7 +4,7 @@ -- | Analyses lists of instructions, inserting StackMapTable attributes where needed & resolving labels. module JVM.Data.Analyse.Instruction (normaliseStackDiff, Apply (..), StackDiff (..), stackPush, stackPop, localsPop, stackPopAndPush, LocalsDiff (..), analyseStackChange, calculateStackMapFrames, analyseStackMapTable, insertStackMapTable, findJumps) where -import Control.Applicative (liftA2) +import Control.Applicative (Alternative ((<|>)), liftA2) import Data.List (foldl', genericLength) import Data.List.NonEmpty (NonEmpty (..)) import Data.List.NonEmpty qualified as NE @@ -14,10 +14,11 @@ import GHC.Stack (HasCallStack) import JVM.Data.Abstract.Builder.Code import JVM.Data.Abstract.Builder.Label import JVM.Data.Abstract.ClassFile.Method -import JVM.Data.Abstract.Descriptor (MethodDescriptor (..), methodParams, returnDescriptorType) +import JVM.Data.Abstract.Descriptor (MethodDescriptor (..), methodParam, methodParams, returnDescriptorType) import JVM.Data.Abstract.Instruction import JVM.Data.Abstract.Type (ClassInfoType (ArrayClassInfoType, ClassInfoType), FieldType (..), PrimitiveType (..), fieldTypeToClassInfoType) import JVM.Data.Pretty +import JVM.Data.Raw.Types -- | Details how the stack changes between two instructions data StackDiff @@ -146,26 +147,41 @@ instance Apply LocalsDiff Locals where apply (LocalsPop n) s = drop n s apply LocalsSame s = s -analyseStackChange :: HasCallStack => (Stack, Locals) -> MethodDescriptor -> Instruction -> Maybe (StackDiff, LocalsDiff) -analyseStackChange (_, locals) desc (ALoad idx) = do - let (!!?) :: [a] -> Int -> Maybe a +xstoreChange :: HasCallStack => (Stack, Locals) -> MethodDescriptor -> U1 -> Maybe FieldType -> Maybe (StackDiff, LocalsDiff) +xstoreChange ([], _) _ _ _ = error "xstoreChange: empty stack" +xstoreChange (stack, locals) desc idx expected = + pure + ( stackPop 1 + , if idx >= genericLength (methodParams desc) && (length locals - length (methodParams desc)) <= fromIntegral idx + then + let head' = head stack + in LocalsPush $ case expected of + Just x | x == head' -> [head'] + Just x -> error ("xstoreChange: expected " <> show x <> " but got " <> show head') + _ -> [head'] + else LocalsSame + ) + +xLoadChange :: HasCallStack => (Stack, Locals) -> MethodDescriptor -> U1 -> Maybe FieldType -> Maybe (StackDiff, LocalsDiff) +xLoadChange (_, locals) desc idx expected = do + let _ !!? n | n < 0 = Nothing [] !!? _ = Nothing (x : _) !!? 0 = Just x (_ : xs) !!? n = xs !!? (n - 1) - idx' <- locals !!? fromIntegral idx - pure (stackPush [idx'], LocalsSame) -analyseStackChange (stack : _, locals) desc (AStore idx) = - pure - ( stackPop 1 - , if idx >= genericLength (methodParams desc) && length locals <= fromIntegral idx - then LocalsPush [stack] - else LocalsSame - ) -analyseStackChange ([], _) _ (AStore x) = error ("AStore with empty stack: " <> show x) + idx' <- desc `methodParam` fromIntegral idx <|> locals !!? (fromIntegral idx - length (methodParams desc)) + case expected of + Just x | x /= idx' -> error ("xLoadChange: expected " <> show x <> " but got " <> show idx') + _ -> pure (stackPush [idx'], LocalsSame) + +analyseStackChange :: HasCallStack => (Stack, Locals) -> MethodDescriptor -> Instruction -> Maybe (StackDiff, LocalsDiff) +analyseStackChange sl desc (ALoad idx) = xLoadChange sl desc idx Nothing +analyseStackChange sl desc (AStore idx) = xstoreChange sl desc idx Nothing +analyseStackChange sl desc (ILoad idx) = xLoadChange sl desc idx (Just (PrimitiveFieldType Int)) +analyseStackChange sl desc (IStore idx) = xstoreChange sl desc idx (Just (PrimitiveFieldType Int)) analyseStackChange _ _ AReturn = pure (stackPop 1, LocalsSame) -analyseStackChange _ _ Return = pure (stackPop 1, LocalsSame) +analyseStackChange _ _ Return = pure (StackSame, LocalsSame) -- return void analyseStackChange _ _ (LDC x) = pure (StackPush [ldcEntryToFieldType x], LocalsSame) analyseStackChange _ _ AConstNull = pure (StackPush [ObjectFieldType "java/lang/Object"], LocalsSame) analyseStackChange _ _ (Goto _) = pure (StackSame, LocalsSame) @@ -189,7 +205,7 @@ analyseStackChange _ _ (Label _) = Nothing -- | Analyses a list of instructions, returning the stack and locals at each point. analyseStackMapTable :: HasCallStack => MethodDescriptor -> [Instruction] -> (Stack, Locals, [Maybe (StackDiff, LocalsDiff)]) -analyseStackMapTable desc = go ([], methodParams desc) +analyseStackMapTable desc = go ([], []) where go :: HasCallStack => (Stack, Locals) -> [Instruction] -> (Stack, Locals, [Maybe (StackDiff, LocalsDiff)]) go (x, l) [] = (x, l, []) @@ -239,7 +255,7 @@ calculateStackMapFrames desc code = ) _ -> (acc, stack', locals') ) - ([], [], methodParams desc) + ([], [], methodParams desc) jumpsAndLabels in (\(a, _, _) -> a) x diff --git a/src/JVM/Data/Convert/Instruction.hs b/src/JVM/Data/Convert/Instruction.hs index 70a49ae..b37e0ad 100644 --- a/src/JVM/Data/Convert/Instruction.hs +++ b/src/JVM/Data/Convert/Instruction.hs @@ -65,6 +65,16 @@ instructionSize (Abs.AStore 1) = 1 instructionSize (Abs.AStore 2) = 1 instructionSize (Abs.AStore 3) = 1 instructionSize (Abs.AStore _) = 2 +instructionSize (Abs.ILoad 0) = 1 +instructionSize (Abs.ILoad 1) = 1 +instructionSize (Abs.ILoad 2) = 1 +instructionSize (Abs.ILoad 3) = 1 +instructionSize (Abs.ILoad _) = 2 +instructionSize (Abs.IStore 0) = 1 +instructionSize (Abs.IStore 1) = 1 +instructionSize (Abs.IStore 2) = 1 +instructionSize (Abs.IStore 3) = 1 +instructionSize (Abs.IStore _) = 2 instructionSize Abs.AReturn = 1 instructionSize Abs.AConstNull = 1 instructionSize (Abs.IfEq _) = 3 @@ -176,6 +186,17 @@ convertInstruction (OffsetInstruction instOffset o) = Just <$> convertInstructio convertInstruction (Abs.AStore 2) = pure Raw.AStore2 convertInstruction (Abs.AStore 3) = pure Raw.AStore3 convertInstruction (Abs.AStore idx) = pure (Raw.AStore idx) + convertInstruction (Abs.ILoad 0) = pure Raw.ILoad0 + convertInstruction (Abs.ILoad 1) = pure Raw.ILoad1 + convertInstruction (Abs.ILoad 2) = pure Raw.ILoad2 + convertInstruction (Abs.ILoad 3) = pure Raw.ILoad3 + convertInstruction (Abs.ILoad idx) = pure (Raw.ILoad idx) + convertInstruction (Abs.IStore 0) = pure Raw.IStore0 + convertInstruction (Abs.IStore 1) = pure Raw.IStore1 + convertInstruction (Abs.IStore 2) = pure Raw.IStore2 + convertInstruction (Abs.IStore 3) = pure Raw.IStore3 + convertInstruction (Abs.IStore idx) = pure (Raw.IStore idx) + convertInstruction Abs.AConstNull = pure Raw.AConstNull convertInstruction (Abs.InvokeStatic c n m) = do idx <- findIndexOf (CPMethodRefEntry (MethodRef c n m)) diff --git a/src/JVM/Data/Raw/Instruction.hs b/src/JVM/Data/Raw/Instruction.hs index ecdafba..47acac0 100644 --- a/src/JVM/Data/Raw/Instruction.hs +++ b/src/JVM/Data/Raw/Instruction.hs @@ -133,7 +133,7 @@ data Instruction | IfNonNull Word16 | IfNull Word16 | IInc Word8 Word8 - | ILoad + | ILoad U1 | ILoad0 | ILoad1 | ILoad2 @@ -151,11 +151,11 @@ data Instruction | IReturn | IShl | IShr - | IStore | IStore0 | IStore1 | IStore2 | IStore3 + | IStore U1 | ISub | IUShr | IXor @@ -338,7 +338,7 @@ putInstruction = \case IfNonNull offset -> putWord8 MagicNumbers.instruction_ifNonNull *> putWord16be offset IfNull offset -> putWord8 MagicNumbers.instruction_ifNull *> putWord16be offset IInc index increment -> putWord8 MagicNumbers.instruction_iInc *> putWord8 index *> putWord8 increment - ILoad -> putWord8 MagicNumbers.instruction_iLoad + ILoad n -> putWord8 MagicNumbers.instruction_iLoad *> putWord8 n ILoad0 -> putWord8 MagicNumbers.instruction_iLoad0 ILoad1 -> putWord8 MagicNumbers.instruction_iLoad1 ILoad2 -> putWord8 MagicNumbers.instruction_iLoad2 @@ -356,7 +356,7 @@ putInstruction = \case IReturn -> putWord8 MagicNumbers.instruction_iReturn IShl -> putWord8 MagicNumbers.instruction_iShl IShr -> putWord8 MagicNumbers.instruction_iShr - IStore -> putWord8 MagicNumbers.instruction_iStore + IStore n -> putWord8 MagicNumbers.instruction_iStore *> putWord8 n IStore0 -> putWord8 MagicNumbers.instruction_iStore0 IStore1 -> putWord8 MagicNumbers.instruction_iStore1 IStore2 -> putWord8 MagicNumbers.instruction_iStore2 diff --git a/test/Builder.hs b/test/Builder.hs index faace63..691764f 100644 --- a/test/Builder.hs +++ b/test/Builder.hs @@ -45,8 +45,51 @@ spec = describe "test code building" $ do , Raw.IfEq 3 , Raw.Return ] - complex1 - complex2 + -- complex1 + simple1 + +-- complex2 + +simple1 :: Spec +simple1 = describe "Should handle another more simple example correctly" $ do + let ((label1, absInsts), attrs, code) = runCodeBuilder' $ do + label1 <- newLabel + let code = + [ ALoad 0 + , Goto label1 + , Label label1 + , AReturn + ] + + emit' code + pure (label1, code) + + it "Converts correctly" $ hedgehog $ do + (insts, _) <- runConv code + insts + === [ Raw.ALoad0 + , Raw.Goto 3 + , Raw.AReturn + ] + + it "Calculates the stack map frames correctly" $ hedgehog $ do + let desc = MethodDescriptor [(ObjectFieldType "java.lang.Integer")] (TypeReturn (ObjectFieldType "java.lang.Integer")) + (_, _, diffs) = analyseStackMapTable desc code + frames = calculateStackMapFrames desc code + + frames + === [ SameLocals1StackItemFrame IntegerVariableInfo label1 + ] + diffs + === [ Just (StackPush [ObjectFieldType "java.lang.Integer"], LocalsSame) + , Just (StackSame, LocalsSame) + , Nothing + , Just (StackPop 1, LocalsSame) + ] + + applyMany (fmap fst <$> diffs) [] === [] + applyMany (fmap snd <$> diffs) (methodParams desc) + === [(ObjectFieldType "java.lang.Integer")] complex1 :: Spec complex1 = describe "Should handle more complex labels correctly" $ do @@ -89,7 +132,7 @@ complex1 = describe "Should handle more complex labels correctly" $ do , ALoad 0 -- stack = [java.lang.Integer, java.lang.Integer, java.lang.Integer] , LDC (LDCInt 1) -- stack = [java.lang.Integer, java.lang.Integer, java.lang.Integer, 1] , InvokeStatic (ClassInfoType "java.lang.Integer") "valueOf" (MethodDescriptor [PrimitiveFieldType JVM.Int] (TypeReturn (ObjectFieldType "java.lang.Integer"))) -- stack = [java.lang.Integer, java.lang.Integer, java.lang.Integer, java.lang.Integer] - , InvokeStatic (ClassInfoType "Prelude") "minus" (MethodDescriptor [ObjectFieldType "java.lang.Integer", ObjectFieldType "java.lang.Integer"] (TypeReturn (ObjectFieldType "java.lang.Integer"))) -- stack = [java.lang.Integer, java.lang.Integer, java.lang.Integer] + , InvokeStatic (ClassInfoType "Prelude") "minus" (MethodDescriptor [ObjectFieldType "java.lang.Integer", ObjectFieldType "java.lang.Integer"] (TypeReturn (ObjectFieldType "java.lang.Integer"))) -- stack = [java.lang.Integer, java.lang.Integer, java.lang.Integer] , InvokeStatic (ClassInfoType "fact") "fact" (MethodDescriptor [ObjectFieldType "java.lang.Integer"] (TypeReturn (ObjectFieldType "java.lang.Integer"))) -- stack = [java.lang.Integer, java.lang.Integer] , InvokeStatic (ClassInfoType "Prelude") "times" (MethodDescriptor [ObjectFieldType "java.lang.Integer", ObjectFieldType "java.lang.Integer"] (TypeReturn (ObjectFieldType "java.lang.Integer"))) -- stack = [java.lang.Integer] , Label label2 -- stack = [java.lang.Integer] @@ -119,39 +162,43 @@ complex1 = describe "Should handle more complex labels correctly" $ do , Raw.AReturn -- #39 ] - it "Calculates the stack map frames correctly" $ do - hedgehog $ do - let desc = MethodDescriptor [ObjectFieldType "java.lang.Integer"] (TypeReturn (ObjectFieldType "java.lang.Integer")) - frames = calculateStackMapFrames desc code - - frames - === [ FullFrame [ObjectVariableInfo (ClassInfoType "java.lang.Integer")] [ObjectVariableInfo (ClassInfoType "java.lang.Integer")] label1 - , SameLocals1StackItemFrame (ObjectVariableInfo (ClassInfoType "java.lang.Integer")) label2 - ] - - it "Writes to a file without issue" $ hedgehog $ do - let (_, clazz) = - runClassBuilder "BuilderTest" java17 $ - addMethod $ - ClassFileMethod - [MPublic, MStatic] - "main" - (MethodDescriptor [ObjectFieldType "java.lang.String"] VoidReturn) - [ Code $ - CodeAttributeData - 5 - 2 - absInsts - [] - attrs - ] + it "Calculates the stack map frames correctly" $ hedgehog $ do + let desc = MethodDescriptor [ObjectFieldType "java.lang.Integer"] (TypeReturn (ObjectFieldType "java.lang.Integer")) + (_, _, diffs) = analyseStackMapTable desc code + frames = calculateStackMapFrames desc code - let classFile' = convert clazz + diffs + === ( Just + <$> [ (StackPush [ObjectFieldType "java.lang.Integer"], LocalsSame) -- stack = [java.lang.Integer] + , (StackPush [PrimitiveFieldType Int], LocalsSame) -- stack = [int, java.lang.Integer] + , (stackPopAndPush 1 [ObjectFieldType "java.lang.Integer"], LocalsSame) -- stack = [java.lang.Integer, java.lang.Integer] + , (stackPopAndPush 2 [ObjectFieldType "java.lang.Boolean"], LocalsSame) -- stack = [java.lang.Boolean] + , (stackPopAndPush 1 [PrimitiveFieldType Boolean], LocalsSame) -- stack = [boolean] + , (stackPop 1, LocalsSame) -- stack = [] + , (StackPush [PrimitiveFieldType Int], LocalsSame) -- stack = [int] + , (stackPopAndPush 1 [ObjectFieldType "java.lang.Integer"], LocalsSame) -- stack = [java.lang.Integer] + , (StackSame, LocalsSame) -- stack = [java.lang.Integer] + ] + ) + ++ [Nothing] -- stack = [java.lang.Integer] + ++ ( Just + <$> [ (StackPush [ObjectFieldType "java.lang.Integer"], LocalsSame) -- stack = [java.lang.Integer, java.lang.Integer] + , (StackPush [ObjectFieldType "java.lang.Integer"], LocalsSame) -- stack = [java.lang.Integer, java.lang.Integer, java.lang.Integer] + , (StackPush [PrimitiveFieldType Int], LocalsSame) -- stack = [java.lang.Integer, java.lang.Integer, java.lang.Integer, int] + , (stackPopAndPush 1 [ObjectFieldType "java.lang.Integer"], LocalsSame) -- stack = [java.lang.Integer, java.lang.Integer, java.lang.Integer, java.lang.Integer] + , (stackPopAndPush 2 [ObjectFieldType "java.lang.Integer"], LocalsSame) -- stack = [java.lang.Integer, java.lang.Integer, java.lang.Integer] + , (stackPopAndPush 1 [ObjectFieldType "java.lang.Integer"], LocalsSame) -- stack = [java.lang.Integer, java.lang.Integer] + , (stackPopAndPush 2 [ObjectFieldType "java.lang.Integer"], LocalsSame) -- stack = [java.lang.Integer] + ] + ) + ++ [ Nothing -- stack = [java.lang.Integer] + , Just (stackPop 1, LocalsSame) -- stack = [] + ] - classContents <- shouldBeRight classFile' - let bs = runPut (writeBinary classContents) - - liftIO $ BS.writeFile "BuilderTest.class" (BS.toStrict bs) + frames + === [ SameFrame label1 + , SameLocals1StackItemFrame (ObjectVariableInfo (ClassInfoType "java.lang.Integer")) label2 + ] complex2 :: Spec complex2 = describe "Should handle another complex example correctly" $ do @@ -235,78 +282,147 @@ complex2 = describe "Should handle another complex example correctly" $ do , Raw.AReturn -- #37 ] - it "Calculates the stack map frames correctly" $ do - hedgehog $ do - let desc = MethodDescriptor [ObjectFieldType "elara.EList", ObjectFieldType "elara.EList"] (TypeReturn (ObjectFieldType "elara.EList")) - (_, _, diffs) = analyseStackMapTable desc code - frames = calculateStackMapFrames desc code + it "Calculates the stack map frames correctly" $ hedgehog $ do + let desc = MethodDescriptor [ObjectFieldType "elara.EList", ObjectFieldType "elara.EList"] (TypeReturn (ObjectFieldType "elara.EList")) + (_, _, diffs) = analyseStackMapTable desc code + frames = calculateStackMapFrames desc code - let elist = ObjectVariableInfo (ClassInfoType "elara.EList") - frames - === [ FullFrame [elist] [elist, elist, elist, ObjectVariableInfo (ClassInfoType "java.lang.Object"), elist] label1 - , SameLocals1StackItemFrame elist label2 - ] - diffs - === ( Just - <$> [ (StackPush [ObjectFieldType "elara.EList"], LocalsSame) -- stack = [elara.EList] - , (StackSame, LocalsSame) -- stack = [elara.EList] - , (StackPush [ObjectFieldType "elara.EList"], LocalsSame) -- stack = [elara.EList, elara.EList] - , (stackPop 1, LocalsPush [ObjectFieldType "elara.EList"]) -- stack = [elara.EList] - , (stackPopAndPush 1 [PrimitiveFieldType Boolean], LocalsSame) -- stack = [Boolean] - , (stackPop 1, LocalsSame) -- stack = [] - , (StackPush [ObjectFieldType "elara.EList"], LocalsSame) -- stack = [elara.EList] - , (stackPopAndPush 1 [ObjectFieldType "java.lang.Object"], LocalsSame) -- stack = [java.lang.Object] - , (stackPop 1, LocalsPush [ObjectFieldType "java.lang.Object"]) -- stack = [] - , (StackPush [ObjectFieldType "elara.EList"], LocalsSame) -- stack = [elara.EList] - , (stackPopAndPush 1 [ObjectFieldType "elara.EList"], LocalsSame) -- stack = [elara.EList] - , (stackPop 1, LocalsPush [ObjectFieldType "elara.EList"]) -- stack = [] - , (StackPush [ObjectFieldType "java.lang.Object"], LocalsSame) -- stack = [java.lang.Object] - , (StackPush [ObjectFieldType "elara.EList"], LocalsSame) -- stack = [java.lang.Object, elara.EList] - , (StackPush [ObjectFieldType "elara.EList"], LocalsSame) -- stack = [java.lang.Object, elara.EList, elara.EList] - , (stackPopAndPush 2 [ObjectFieldType "elara.EList"], LocalsSame) -- stack = [java.lang.Object, elara.EList] - , (stackPopAndPush 2 [ObjectFieldType "elara.EList"], LocalsSame) -- stack = [elara.EList] - , (StackSame, LocalsSame) -- stack = [elara.EList] - ] - ) - ++ [ Nothing -- stack = [elara.EList] - , Just (StackPush [ObjectFieldType "elara.EList"], LocalsSame) -- stack = [elara.EList, elara.EList] - , Nothing -- stack = [elara.EList] - , Just (stackPop 1, LocalsSame) -- stack = [elara.EList] - ] + let elist = ObjectVariableInfo (ClassInfoType "elara.EList") + frames + === [ FullFrame [elist] [elist, elist, elist, ObjectVariableInfo (ClassInfoType "java.lang.Object"), elist] label1 + , SameLocals1StackItemFrame elist label2 + ] + diffs + === ( Just + <$> [ (StackPush [ObjectFieldType "elara.EList"], LocalsSame) -- stack = [elara.EList] + , (StackSame, LocalsSame) -- stack = [elara.EList] + , (StackPush [ObjectFieldType "elara.EList"], LocalsSame) -- stack = [elara.EList, elara.EList] + , (stackPop 1, LocalsPush [ObjectFieldType "elara.EList"]) -- stack = [elara.EList] + , (stackPopAndPush 1 [PrimitiveFieldType Boolean], LocalsSame) -- stack = [Boolean] + , (stackPop 1, LocalsSame) -- stack = [] + , (StackPush [ObjectFieldType "elara.EList"], LocalsSame) -- stack = [elara.EList] + , (stackPopAndPush 1 [ObjectFieldType "java.lang.Object"], LocalsSame) -- stack = [java.lang.Object] + , (stackPop 1, LocalsPush [ObjectFieldType "java.lang.Object"]) -- stack = [] + , (StackPush [ObjectFieldType "elara.EList"], LocalsSame) -- stack = [elara.EList] + , (stackPopAndPush 1 [ObjectFieldType "elara.EList"], LocalsSame) -- stack = [elara.EList] + , (stackPop 1, LocalsPush [ObjectFieldType "elara.EList"]) -- stack = [] + , (StackPush [ObjectFieldType "java.lang.Object"], LocalsSame) -- stack = [java.lang.Object] + , (StackPush [ObjectFieldType "elara.EList"], LocalsSame) -- stack = [java.lang.Object, elara.EList] + , (StackPush [ObjectFieldType "elara.EList"], LocalsSame) -- stack = [java.lang.Object, elara.EList, elara.EList] + , (stackPopAndPush 2 [ObjectFieldType "elara.EList"], LocalsSame) -- stack = [java.lang.Object, elara.EList] + , (stackPopAndPush 2 [ObjectFieldType "elara.EList"], LocalsSame) -- stack = [elara.EList] + , (StackSame, LocalsSame) -- stack = [elara.EList] + ] + ) + ++ [ Nothing -- stack = [elara.EList] + , Just (StackPush [ObjectFieldType "elara.EList"], LocalsSame) -- stack = [elara.EList, elara.EList] + , Nothing -- stack = [elara.EList] + , Just (stackPop 1, LocalsSame) -- stack = [elara.EList] + ] - applyMany (fmap fst <$> diffs) [] === [ObjectFieldType "elara.EList"] - applyMany (fmap snd <$> diffs) (methodParams desc) - === replicate 3 (ObjectFieldType "elara.EList") - ++ [ObjectFieldType "java.lang.Object"] - ++ [ObjectFieldType "elara.EList"] + applyMany (fmap fst <$> diffs) [] === [ObjectFieldType "elara.EList"] + applyMany (fmap snd <$> diffs) (methodParams desc) + === replicate 3 (ObjectFieldType "elara.EList") + ++ [ObjectFieldType "java.lang.Object"] + ++ [ObjectFieldType "elara.EList"] - let diffsUntilLabel1 = take 18 diffs - applyMany (fmap fst <$> diffsUntilLabel1) [] === [ObjectFieldType "elara.EList"] - applyMany (fmap snd <$> diffsUntilLabel1) (methodParams desc) - === replicate 3 (ObjectFieldType "elara.EList") - ++ [ObjectFieldType "java.lang.Object"] - ++ [ObjectFieldType "elara.EList"] + let diffsUntilLabel1 = take 18 diffs + applyMany (fmap fst <$> diffsUntilLabel1) [] === [ObjectFieldType "elara.EList"] + applyMany (fmap snd <$> diffsUntilLabel1) (methodParams desc) + === replicate 3 (ObjectFieldType "elara.EList") + ++ [ObjectFieldType "java.lang.Object"] + ++ [ObjectFieldType "elara.EList"] - it "Writes to a file without issue" $ hedgehog $ do - let (_, clazz) = - runClassBuilder "BuilderTest2" java17 $ - addMethod $ - ClassFileMethod - [MPublic, MStatic] - "main" - (MethodDescriptor [ObjectFieldType "java.lang.String"] VoidReturn) - [ Code $ - CodeAttributeData - 5 - 2 - absInsts - [] - attrs - ] +complex3 :: Spec +complex3 = describe "Should handle another more simple example correctly" $ do + {- + public static void main(java.lang.String[]); + 0: ldc #7 // int 400043 + 2: istore_1 + 3: iconst_1 + 4: istore_2 + 5: iconst_1 + 8: ifeq 22 + 11: sipush 4922 + 14: istore_3 + 15: getstatic #14 // Field java/lang/System.out:Ljava/io/PrintStream; + 18: iload_3 + 19: invokevirtual #20 // Method java/io/PrintStream.println:(I)V + 22: ldc #26 // int 40303 + 24: istore_3 + 25: return + -} + let ((label1, absInsts), attrs, code) = runCodeBuilder' $ do + label1 <- newLabel + let code = + [ LDC (LDCInt 400043) + , IStore 1 + , LDC (LDCInt 1) + , IStore 2 + , LDC (LDCInt 1) + , IfEq label1 + , LDC (LDCInt 4922) + , IStore 3 + , GetStatic (ClassInfoType "java.lang.System") "out" (ObjectFieldType "java.io.PrintStream") + , ILoad 3 + , InvokeVirtual (ClassInfoType "java.io.PrintStream") "println" (MethodDescriptor [PrimitiveFieldType JVM.Int] VoidReturn) + , Label label1 + , LDC (LDCInt 40303) + , IStore 3 + , Return + ] + + emit' code + pure (label1, code) + + it "Converts correctly" $ hedgehog $ do + (insts, _) <- runConv code + insts + === [ Raw.LDC 1 -- #0 + , Raw.IStore1 -- #2 + , Raw.LDC 2 -- #3 + , Raw.IStore2 -- #4 + , Raw.LDC 2 -- #5 + , Raw.IfEq 13 -- #8 + , Raw.LDC 3 -- #11 + , Raw.IStore3 -- #14 + , Raw.GetStatic 9 -- #15 + , Raw.ILoad3 -- #18 + , Raw.InvokeVirtual 15 -- #19 + , Raw.LDC 16 -- #22 + , Raw.IStore3 -- #24 + , Raw.Return -- #25 + ] - let classFile' = convert clazz + it "Calculates the stack map frames correctly" $ hedgehog $ do + let desc = MethodDescriptor [ArrayFieldType (ObjectFieldType "java.lang.String")] VoidReturn + (_, _, diffs) = analyseStackMapTable desc code + frames = calculateStackMapFrames desc code - classContents <- shouldBeRight classFile' - let bs = runPut (writeBinary classContents) + frames + === [ AppendFrame [IntegerVariableInfo, IntegerVariableInfo] label1 + ] + diffs + === ( Just + <$> [ (StackPush [PrimitiveFieldType Int], LocalsSame) -- ldc 1 -> stack = [int] locals = [java.lang.String[]] + , (StackPop 1, LocalsPush [PrimitiveFieldType Int]) -- istore1 -> stack = [] locals = [java.lang.String[], int] + , (StackPush [PrimitiveFieldType Int], LocalsSame) -- ldc 2 -> stack = [int] locals = [java.lang.String[], int] + , (StackPop 1, LocalsPush [PrimitiveFieldType Int]) -- istore2 -> stack = [] locals = [java.lang.String[], int, int] + , (StackPush [PrimitiveFieldType Int], LocalsSame) -- ldc 2 -> stack = [int] locals = [java.lang.String[], int, int] + , (StackPop 1, LocalsSame) -- ifeq 13 -> stack = [] locals = [java.lang.String[], int, int] + , (StackPush [PrimitiveFieldType Int], LocalsSame) -- ldc 3 -> stack = [int] locals = [java.lang.String[], int, int] + , (StackPop 1, LocalsPush [PrimitiveFieldType Int]) -- istore3 -> stack = [] locals = [java.lang.String[], int, int, int] + , (StackPush [ObjectFieldType "java.io.PrintStream"], LocalsSame) -- getstatic -> stack = [java.io.PrintStream] locals = [java.lang.String[], int, int, int] + , (StackPush [PrimitiveFieldType Int], LocalsSame) -- iload3 -> stack = [int, java.io.PrintStream] locals = [java.lang.String[], int, int, int] + , (StackPop 2, LocalsSame) -- invokevirtual -> stack = [] locals = [java.lang.String[], int, int, int] + ] + ) + ++ [ Nothing -- stack = [] locals = [java.lang.String[], int, int, int] + , Just (StackPush [PrimitiveFieldType Int], LocalsSame) -- ldc 16 -> stack = [int] locals = [java.lang.String[], int, int, int] + , Just (StackPop 1, LocalsSame) -- istore3 -> stack = [] locals = [java.lang.String[], int, int, int] + , Just (StackSame, LocalsSame) -- stack = [] locals = [java.lang.String[], int, int, int] + ] - liftIO $ BS.writeFile "BuilderTest2.class" (BS.toStrict bs) + applyMany (fmap fst <$> diffs) [] === [] + applyMany (fmap snd <$> diffs) (methodParams desc) + === [ArrayFieldType (ObjectFieldType "java.lang.String"), PrimitiveFieldType Int, PrimitiveFieldType Int, PrimitiveFieldType Int] From 07aeddbff94c0363c028cf42676f61634b92469f Mon Sep 17 00:00:00 2001 From: Alexander Wood Date: Sat, 2 Dec 2023 16:12:12 +0000 Subject: [PATCH 02/23] stuff --- README.MD | 5 +- h2jvm.cabal | 1 + src/Data/TypeMergingList.hs | 14 ++++ src/JVM/Data/Abstract/ClassFile/Method.hs | 7 +- src/JVM/Data/Analyse/StackMapTable/Mark.hs | 89 ++++++++++++++++++++++ 5 files changed, 111 insertions(+), 5 deletions(-) create mode 100644 src/JVM/Data/Analyse/StackMapTable/Mark.hs diff --git a/README.MD b/README.MD index ce3496a..fe79c25 100644 --- a/README.MD +++ b/README.MD @@ -5,7 +5,8 @@ It handles the messy details such as jump offsets, stack map frames, and more. H2JVM does its processing in a pipeline: 1. The user writes a class as a `JVM.Data.Abstract.ClassFile`, potentially using the `JVM.Data.Abstract.Builder` monads -2. This class is analysed using code in the `JVM.Data.Analyse` modules - adding stack map frames, calculating jump offsets, etc. +2. This class is analysed using code in the `JVM.Data.HLAnalyse` modules - calculating jump offsets, etc. This stage may also do some optimisations, such as removing dead code. 3. The class is converted to a low level format (`JVM.Data.Raw`) using the `JVM.Data.Convert` module -4. The low level format is converted to a `ByteString` using the `JVM.Data.Raw` modules, which can be written to a file. or used in a JVM. \ No newline at end of file +4. The low level class is analysed using code in the `JVM.Data.LLAnalyse` modules - adding stack map frames, calculating stack sizes, etc. +5. The low level format is converted to a `ByteString` using the `JVM.Data.Raw` modules, which can be written to a file. or used in a JVM. \ No newline at end of file diff --git a/h2jvm.cabal b/h2jvm.cabal index 08a01f5..825da68 100644 --- a/h2jvm.cabal +++ b/h2jvm.cabal @@ -118,6 +118,7 @@ library , bytestring , containers , lens >=5.0 + , generic-lens , mtl , prettyprinter , split diff --git a/src/Data/TypeMergingList.hs b/src/Data/TypeMergingList.hs index 43b2518..50df85b 100644 --- a/src/Data/TypeMergingList.hs +++ b/src/Data/TypeMergingList.hs @@ -1,4 +1,7 @@ + +{-# LANGUAGE DataKinds #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE AllowAmbiguousTypes #-} {- | A Snoc List type that merges elements of the same constructor using the Semigroup instance. For example, suppose we have some data type: @@ -16,9 +19,12 @@ Then we can do: -} module Data.TypeMergingList where +import Control.Lens ((^?)) import Data.Data import Data.List (foldl') +import GHC.Generics (Generic) import GHC.IsList qualified as L +import Data.Generics.Sum.Constructors newtype TypeMergingList a = TypeMergingList [a] deriving (Eq, Ord, Show) @@ -36,6 +42,14 @@ errorDifferentConstructors x y = error $ "Cannot merge values as they have diffe instance {-# OVERLAPPABLE #-} (Data a, Semigroup a) => DataMergeable a where merge = (<>) +getByCtor :: forall ctor s a. (Generic s, AsConstructor ctor s s a a) => TypeMergingList s -> Maybe a +getByCtor (TypeMergingList xs) = go xs + where + go [] = Nothing + go (x : xs') = case x ^? _Ctor @ctor of + Just a -> Just a + Nothing -> go xs' + snoc :: (DataMergeable a) => TypeMergingList a -> a -> TypeMergingList a snoc xs x = append xs (TypeMergingList [x]) diff --git a/src/JVM/Data/Abstract/ClassFile/Method.hs b/src/JVM/Data/Abstract/ClassFile/Method.hs index cdc8b7b..789331e 100644 --- a/src/JVM/Data/Abstract/ClassFile/Method.hs +++ b/src/JVM/Data/Abstract/ClassFile/Method.hs @@ -5,23 +5,24 @@ import JVM.Data.Abstract.ClassFile.AccessFlags (MethodAccessFlag) import JVM.Data.Abstract.Descriptor (MethodDescriptor) import Data.Data -import Data.TypeMergingList (DataMergeable (merge), errorDifferentConstructors) +import Data.TypeMergingList (DataMergeable (merge), errorDifferentConstructors, TypeMergingList) import JVM.Data.Abstract.Builder.Label import JVM.Data.Abstract.Instruction import JVM.Data.Abstract.Type (ClassInfoType) import JVM.Data.Raw.Types (U2, U1) +import GHC.Generics (Generic) data ClassFileMethod = ClassFileMethod { methodAccessFlags :: [MethodAccessFlag] , methodName :: Text , methodDescriptor :: MethodDescriptor - , methodAttributes :: [MethodAttribute] + , methodAttributes :: TypeMergingList MethodAttribute } deriving (Show) data MethodAttribute = Code !CodeAttributeData - deriving (Show) + deriving (Show, Generic) data CodeAttributeData = CodeAttributeData { maxStack :: U2 diff --git a/src/JVM/Data/Analyse/StackMapTable/Mark.hs b/src/JVM/Data/Analyse/StackMapTable/Mark.hs new file mode 100644 index 0000000..653bd46 --- /dev/null +++ b/src/JVM/Data/Analyse/StackMapTable/Mark.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE NoFieldSelectors #-} + +module JVM.Data.Analyse.StackMapTable.Mark where + +import Control.Applicative ((<|>)) +import Control.Monad.State +import Data.Generics.Sum +import Data.Map (Map) +import Data.Map qualified as Map +import Data.Maybe (fromJust, fromMaybe) +import Data.Traversable (for) +import Data.TypeMergingList qualified as TML +import JVM.Data.Abstract.Builder.Label +import JVM.Data.Abstract.ClassFile.Method (ClassFileMethod, CodeAttributeData (..), MethodAttribute (..), methodAttributes) +import JVM.Data.Abstract.Descriptor (MethodDescriptor) +import JVM.Data.Abstract.Instruction + +data Mark = Mark + { position :: Label + , block :: Maybe BasicBlock + , jump :: Maybe [Maybe BasicBlock] + , alwaysJump :: Bool -- true if an unconditional branch + , size :: Int -- 0 unless the mark indicates RETURN etc + } + +newMark :: Label -> Mark +newMark pos = Mark{position = pos, block = Nothing, jump = Nothing, alwaysJump = False, size = 0} + +instance Eq Mark where + a == b = a.position == b.position + +instance Ord Mark where + compare a b = compare (a.position) (b.position) + +data BasicBlock = BasicBlock + { position :: Label + , length :: Int + , incoming :: Int + , exit :: Maybe [BasicBlock] + , stop :: Bool + } + +makeBlocks :: ClassFileMethod -> Maybe [BasicBlock] +makeBlocks method = do + codeAttr <- TML.getByCtor @"Code" method.methodAttributes + + undefined + +makeMarks :: CodeAttributeData -> Map Label Mark +makeMarks data_ = flip execState mempty $ do + for data_.code $ \inst -> do + case inst of + Goto x -> do + to <- makeMark x + let jumps = replicate ((fromJust $ to.block).position) Nothing + jumps <- makeArray (to.block) + makeMarkFor jumps + +makeMark :: Label -> State (Map Label Mark) Mark +makeMark = makeMark0 True True + +makeMark0 :: Bool -> Bool -> Label -> State (Map Label Mark) Mark +makeMark0 isBlockBegin isTarget label = do + marks <- get + let inTable = fromMaybe (newMark label) (Map.lookup label marks) + modify $ Map.insert label inTable + if isBlockBegin + then do + let newBlock = fromMaybe (makeBlock label) inTable.block + let newBlock' = if isTarget then newBlock{incoming = newBlock.incoming + 1} else newBlock + let newMark = inTable{block = Just newBlock'} + modify $ Map.insert label newMark + pure newMark + else pure inTable + +makeBlock :: Label -> BasicBlock +makeBlock label = + BasicBlock + { position = label + , length = 0 + , incoming = 0 + , exit = Nothing + , stop = False + } \ No newline at end of file From 58c9e17b6ce52c5532004a7262d0cb7f8c67b1d0 Mon Sep 17 00:00:00 2001 From: Alexander Wood Date: Sat, 2 Dec 2023 16:18:23 +0000 Subject: [PATCH 03/23] make everything compile --- h2jvm.cabal | 3 +- src/Data/TypeMergingList.hs | 14 +- src/JVM/Data/Abstract/ConstantPool.hs | 4 +- src/JVM/Data/Abstract/Descriptor.hs | 2 +- src/JVM/Data/Analyse/Instruction.hs | 312 ---------------- src/JVM/Data/Analyse/StackMapTable/Mark.hs | 89 ----- src/JVM/Data/Convert/Instruction.hs | 1 - src/JVM/Data/Convert/Method.hs | 5 +- src/JVM/Data/Pretty.hs | 11 +- test/Analyse.hs | 69 +--- test/Builder.hs | 396 +-------------------- test/Main.hs | 2 +- 12 files changed, 27 insertions(+), 881 deletions(-) delete mode 100644 src/JVM/Data/Analyse/Instruction.hs delete mode 100644 src/JVM/Data/Analyse/StackMapTable/Mark.hs diff --git a/h2jvm.cabal b/h2jvm.cabal index 825da68..bdb1aa7 100644 --- a/h2jvm.cabal +++ b/h2jvm.cabal @@ -85,7 +85,6 @@ library JVM.Data.Abstract.Instruction JVM.Data.Abstract.Name JVM.Data.Abstract.Type - JVM.Data.Analyse.Instruction JVM.Data.Convert JVM.Data.Convert.AccessFlag JVM.Data.Convert.ConstantPool @@ -117,8 +116,8 @@ library , binary , bytestring , containers - , lens >=5.0 , generic-lens + , lens >=5.0 , mtl , prettyprinter , split diff --git a/src/Data/TypeMergingList.hs b/src/Data/TypeMergingList.hs index 50df85b..6b5b67a 100644 --- a/src/Data/TypeMergingList.hs +++ b/src/Data/TypeMergingList.hs @@ -1,7 +1,6 @@ - +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE AllowAmbiguousTypes #-} {- | A Snoc List type that merges elements of the same constructor using the Semigroup instance. For example, suppose we have some data type: @@ -21,10 +20,12 @@ module Data.TypeMergingList where import Control.Lens ((^?)) import Data.Data +import Data.Generics.Sum.Constructors import Data.List (foldl') import GHC.Generics (Generic) import GHC.IsList qualified as L -import Data.Generics.Sum.Constructors +import Data.Vector (Vector) +import Data.Vector qualified as V newtype TypeMergingList a = TypeMergingList [a] deriving (Eq, Ord, Show) @@ -69,6 +70,9 @@ fromList = foldl' snoc (TypeMergingList []) toList :: TypeMergingList a -> [a] toList (TypeMergingList xs) = reverse xs -- snoc list to cons list +toVector :: TypeMergingList a -> Vector a +toVector (TypeMergingList xs) = V.fromList (reverse xs) + instance (DataMergeable a) => Semigroup (TypeMergingList a) where (<>) = append @@ -79,3 +83,7 @@ instance (DataMergeable a) => L.IsList (TypeMergingList a) where type Item (TypeMergingList a) = a fromList = fromList toList = toList + + +instance Foldable TypeMergingList where + foldMap f (TypeMergingList xs) = foldMap f xs diff --git a/src/JVM/Data/Abstract/ConstantPool.hs b/src/JVM/Data/Abstract/ConstantPool.hs index ce96196..4f6b6f8 100644 --- a/src/JVM/Data/Abstract/ConstantPool.hs +++ b/src/JVM/Data/Abstract/ConstantPool.hs @@ -10,8 +10,8 @@ import Data.Text (Text) import JVM.Data.Abstract.Descriptor (MethodDescriptor) import Data.Data -import JVM.Data.Pretty import JVM.Data.Abstract.Type (ClassInfoType, FieldType) +import JVM.Data.Pretty {- | High-level, type-safe representation of a constant pool entry This tries to hide indexes as much as possible, instead just allowing the values to be provided directly. @@ -49,7 +49,6 @@ data FieldRef = FieldRef ClassInfoType Text FieldType instance Pretty FieldRef where pretty (FieldRef c n t) = pretty c <> "." <> pretty n <> ":" <> pretty t - data MethodRef = MethodRef ClassInfoType @@ -70,7 +69,6 @@ data BootstrapMethod instance Pretty BootstrapMethod where pretty (BootstrapMethod mh args) = pretty mh <+> hsep (map pretty args) - data BootstrapArgument = BMClassArg ClassInfoType | BMStringArg Text diff --git a/src/JVM/Data/Abstract/Descriptor.hs b/src/JVM/Data/Abstract/Descriptor.hs index d20e379..25f7579 100644 --- a/src/JVM/Data/Abstract/Descriptor.hs +++ b/src/JVM/Data/Abstract/Descriptor.hs @@ -32,4 +32,4 @@ instance Pretty ReturnDescriptor where returnDescriptorType :: ReturnDescriptor -> Maybe FieldType returnDescriptorType VoidReturn = Nothing -returnDescriptorType (TypeReturn t) = Just t \ No newline at end of file +returnDescriptorType (TypeReturn t) = Just t diff --git a/src/JVM/Data/Analyse/Instruction.hs b/src/JVM/Data/Analyse/Instruction.hs deleted file mode 100644 index 12a4a7d..0000000 --- a/src/JVM/Data/Analyse/Instruction.hs +++ /dev/null @@ -1,312 +0,0 @@ -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE OverloadedLists #-} - --- | Analyses lists of instructions, inserting StackMapTable attributes where needed & resolving labels. -module JVM.Data.Analyse.Instruction (normaliseStackDiff, Apply (..), StackDiff (..), stackPush, stackPop, localsPop, stackPopAndPush, LocalsDiff (..), analyseStackChange, calculateStackMapFrames, analyseStackMapTable, insertStackMapTable, findJumps) where - -import Control.Applicative (Alternative ((<|>)), liftA2) -import Data.List (foldl', genericLength) -import Data.List.NonEmpty (NonEmpty (..)) -import Data.List.NonEmpty qualified as NE -import Data.List.Split (splitWhen) -import Data.Maybe (isJust, mapMaybe, maybeToList) -import GHC.Stack (HasCallStack) -import JVM.Data.Abstract.Builder.Code -import JVM.Data.Abstract.Builder.Label -import JVM.Data.Abstract.ClassFile.Method -import JVM.Data.Abstract.Descriptor (MethodDescriptor (..), methodParam, methodParams, returnDescriptorType) -import JVM.Data.Abstract.Instruction -import JVM.Data.Abstract.Type (ClassInfoType (ArrayClassInfoType, ClassInfoType), FieldType (..), PrimitiveType (..), fieldTypeToClassInfoType) -import JVM.Data.Pretty -import JVM.Data.Raw.Types - --- | Details how the stack changes between two instructions -data StackDiff - = -- | Pushes the given types onto the stack - StackPush (NonEmpty FieldType) - | -- | Pops the given number of types from the stack - StackPop Int - | -- | Pops the given number of types from the stack, then pushes the given types. - -- This has some specific (and somewhat weird) semantics that means it must prevent "optimisation". - -- For example, suppose we wrote @StackPopAndPush 1 [someFieldType]@. You might think this could be optimised to @StackSame@, but no! - -- The popping refers to the *previous* (imaginary) stack, not the current one. So if the previous stack was @[someOtherFieldType]@, it should become @[someFieldType]@. Optimising to @StackSame@ would mean it remains @[someOtherFieldType]@. - StackPopAndPush Int (NonEmpty FieldType) - | -- | The stack is unchanged - StackSame - deriving (Show, Eq, Ord) - -instance Pretty StackDiff where - pretty StackSame = "same" - pretty (StackPush ts) = "push " <> pretty ts - pretty (StackPopAndPush n ts) = "pop " <> pretty n <> " then push " <> pretty ts - pretty (StackPop n) = "pop " <> pretty n - -stackPop :: HasCallStack => Int -> StackDiff -stackPop n | n < 0 = error "stackPop: negative" -stackPop 0 = StackSame -stackPop n = StackPop n - -stackPush :: [FieldType] -> StackDiff -stackPush [] = StackSame -stackPush ts = StackPush (NE.fromList ts) - -stackPopAndPush :: HasCallStack => Int -> [FieldType] -> StackDiff -stackPopAndPush n _ | n < 0 = error "stackPopAndPush: negative" -stackPopAndPush 0 ts = stackPush ts -stackPopAndPush n [] = stackPop n -stackPopAndPush n ts = - -- We don't perform any optimisations here, see the docs for StackPopAndPush constructor - StackPopAndPush n (NE.fromList ts) - --- | "Normalises" a stack diff. All this really does is turns 'StackPopAndPush' into 'StackPop' and 'StackPush' where possible, undoing the special semantics of 'StackPopAndPush'. -normaliseStackDiff :: StackDiff -> StackDiff -normaliseStackDiff (StackPopAndPush n ts) = case n `compare` length ts of - LT -> stackPush (NE.drop n ts) - EQ -> StackSame - GT -> stackPop (n - length ts) -normaliseStackDiff x = x - -instance Semigroup StackDiff where - StackSame <> x = x - x <> StackSame = x - StackPush ts <> StackPush ts' = StackPush (ts <> ts') - StackPop n <> StackPop n' = stackPop (n + n') - -- \^^ trivial cases - StackPush ts <> StackPop n = case n `compare` length ts of - LT -> stackPush (NE.drop n ts) - EQ -> StackSame - GT -> stackPop (n - length ts) - StackPop n <> StackPush ts = case n `compare` length ts of - LT -> stackPush (NE.drop n ts) - EQ -> StackSame - GT -> stackPop (n - length ts) - StackPop n <> StackPopAndPush n' ts = stackPopAndPush (n + n') (NE.toList ts) - StackPopAndPush n ts <> StackPop n' = (stackPop n <> StackPush ts) <> stackPop n' - StackPopAndPush n ts <> StackPopAndPush n' ts' = stackPop n <> StackPush ts <> StackPopAndPush n' ts' - StackPush ts <> StackPopAndPush n ts' = (stackPush (NE.toList ts) <> stackPop n) <> StackPush ts' - StackPopAndPush n ts <> StackPush ts' = (stackPop n <> StackPush ts) <> StackPush ts' - -instance Monoid StackDiff where - mempty = StackSame - -type Stack = [FieldType] - --- | Details how the local variables change between two instructions -data LocalsDiff - = -- | Pushes the given types onto the locals - LocalsPush (NonEmpty FieldType) - | -- | Pops the given number of types from the locals - LocalsPop Int - | LocalsSame - deriving (Show, Eq, Ord) - -instance Pretty LocalsDiff where - pretty LocalsSame = "same" - pretty (LocalsPush ts) = "push " <> pretty ts - pretty (LocalsPop n) = "pop " <> pretty n - -localsPop :: Int -> LocalsDiff -localsPop 0 = LocalsSame -localsPop n | n < 0 = error "localsPop: negative" -localsPop n = LocalsPop n - -instance Semigroup LocalsDiff where - LocalsSame <> x = x - x <> LocalsSame = x - LocalsPush ts <> LocalsPush ts' = LocalsPush (ts <> ts') - LocalsPop n <> LocalsPop n' = localsPop (n + n') - LocalsPush ts <> LocalsPop n = maybe LocalsSame LocalsPush (NE.nonEmpty $ NE.drop n ts) - LocalsPop n <> LocalsPush ts = maybe LocalsSame LocalsPush (NE.nonEmpty $ NE.drop n ts) - -instance Monoid LocalsDiff where - mempty = LocalsSame - -type Locals = [FieldType] - -class Apply diff a | diff -> a where - apply :: diff -> a -> a - applyMany :: [diff] -> a -> a - applyMany diffs x = foldl' (flip apply) x diffs - -instance Apply (Maybe StackDiff) Stack where - apply (Just diff) = apply diff - apply Nothing = id - -instance Apply (Maybe LocalsDiff) Locals where - apply (Just diff) = apply diff - apply Nothing = id - -instance Apply StackDiff Stack where - apply (StackPush ts) s = NE.toList ts ++ s - apply (StackPop n) s = drop n s - apply StackSame s = s - apply (StackPopAndPush n ts) s = applyMany [stackPop n, StackPush ts] s - -instance Apply LocalsDiff Locals where - apply (LocalsPush ts) s = s ++ NE.toList ts - apply (LocalsPop n) s = drop n s - apply LocalsSame s = s - -xstoreChange :: HasCallStack => (Stack, Locals) -> MethodDescriptor -> U1 -> Maybe FieldType -> Maybe (StackDiff, LocalsDiff) -xstoreChange ([], _) _ _ _ = error "xstoreChange: empty stack" -xstoreChange (stack, locals) desc idx expected = - pure - ( stackPop 1 - , if idx >= genericLength (methodParams desc) && (length locals - length (methodParams desc)) <= fromIntegral idx - then - let head' = head stack - in LocalsPush $ case expected of - Just x | x == head' -> [head'] - Just x -> error ("xstoreChange: expected " <> show x <> " but got " <> show head') - _ -> [head'] - else LocalsSame - ) - -xLoadChange :: HasCallStack => (Stack, Locals) -> MethodDescriptor -> U1 -> Maybe FieldType -> Maybe (StackDiff, LocalsDiff) -xLoadChange (_, locals) desc idx expected = do - let - _ !!? n | n < 0 = Nothing - [] !!? _ = Nothing - (x : _) !!? 0 = Just x - (_ : xs) !!? n = xs !!? (n - 1) - - idx' <- desc `methodParam` fromIntegral idx <|> locals !!? (fromIntegral idx - length (methodParams desc)) - case expected of - Just x | x /= idx' -> error ("xLoadChange: expected " <> show x <> " but got " <> show idx') - _ -> pure (stackPush [idx'], LocalsSame) - -analyseStackChange :: HasCallStack => (Stack, Locals) -> MethodDescriptor -> Instruction -> Maybe (StackDiff, LocalsDiff) -analyseStackChange sl desc (ALoad idx) = xLoadChange sl desc idx Nothing -analyseStackChange sl desc (AStore idx) = xstoreChange sl desc idx Nothing -analyseStackChange sl desc (ILoad idx) = xLoadChange sl desc idx (Just (PrimitiveFieldType Int)) -analyseStackChange sl desc (IStore idx) = xstoreChange sl desc idx (Just (PrimitiveFieldType Int)) -analyseStackChange _ _ AReturn = pure (stackPop 1, LocalsSame) -analyseStackChange _ _ Return = pure (StackSame, LocalsSame) -- return void -analyseStackChange _ _ (LDC x) = pure (StackPush [ldcEntryToFieldType x], LocalsSame) -analyseStackChange _ _ AConstNull = pure (StackPush [ObjectFieldType "java/lang/Object"], LocalsSame) -analyseStackChange _ _ (Goto _) = pure (StackSame, LocalsSame) -analyseStackChange (stack : _, _) _ Dup = pure (StackPush [stack], LocalsSame) -analyseStackChange ([], _) _ Dup = error "Dup with empty stack" -analyseStackChange _ _ (IfEq _) = pure (StackPop 1, LocalsSame) -analyseStackChange _ _ (IfNe _) = pure (StackPop 1, LocalsSame) -analyseStackChange _ _ (IfLt _) = pure (StackPop 1, LocalsSame) -analyseStackChange _ _ (IfGe _) = pure (StackPop 1, LocalsSame) -analyseStackChange _ _ (IfGt _) = pure (StackPop 1, LocalsSame) -analyseStackChange _ _ (IfLe _) = pure (StackPop 1, LocalsSame) -analyseStackChange _ _ (InvokeStatic _ _ (MethodDescriptor args ret)) = pure (stackPopAndPush (length args) (maybeToList $ returnDescriptorType ret), LocalsSame) -analyseStackChange _ _ (InvokeVirtual _ _ (MethodDescriptor args ret)) = pure (stackPopAndPush (length args + 1) (maybeToList $ returnDescriptorType ret), LocalsSame) -analyseStackChange _ _ (InvokeDynamic _ _ (MethodDescriptor args ret)) = pure (stackPopAndPush (length args - 1) (maybeToList $ returnDescriptorType ret), LocalsSame) -analyseStackChange _ _ (InvokeInterface _ _ (MethodDescriptor args ret)) = pure (stackPopAndPush (length args - 1) (maybeToList $ returnDescriptorType ret), LocalsSame) -analyseStackChange _ _ (PutStatic{}) = pure (StackPop 1, LocalsSame) -analyseStackChange _ _ f@(GetField _ _ ft) = pure (stackPopAndPush 1 [ft], LocalsSame) -analyseStackChange _ _ (GetStatic _ _ ft) = pure (StackPush [ft], LocalsSame) -analyseStackChange _ _ (CheckCast _) = pure (StackSame, LocalsSame) -analyseStackChange _ _ (Label _) = Nothing - --- | Analyses a list of instructions, returning the stack and locals at each point. -analyseStackMapTable :: HasCallStack => MethodDescriptor -> [Instruction] -> (Stack, Locals, [Maybe (StackDiff, LocalsDiff)]) -analyseStackMapTable desc = go ([], []) - where - go :: HasCallStack => (Stack, Locals) -> [Instruction] -> (Stack, Locals, [Maybe (StackDiff, LocalsDiff)]) - go (x, l) [] = (x, l, []) - go (stack, locals) (i : is) = - case analyseStackChange (stack, locals) desc i of - Nothing -> let (s, l, xs) = go (stack, locals) is in (s, l, Nothing : xs) - Just (stackDiff, localsDiff) -> - let (s, l, diffs) = go (apply stackDiff stack, apply localsDiff locals) is - in (s, l, Just (stackDiff, localsDiff) : diffs) - --- | Inserts a StackMapTable entry into the CodeBuilder -insertStackMapTable :: Monad m => MethodDescriptor -> CodeBuilderT m () -insertStackMapTable desc = do - -- The process here is fairly simple: - -- 1. Analyse the instructions, getting the stack and locals diffs at each point - -- 2. Find all the instructions in which a jump occurs - -- 3. Find the diffs between each jump source and jump target - -- 4. Insert a StackMapTable entry for each jump source, with the diffs from the jump source to the jump target - code <- getCode - mapM_ appendStackMapFrame (calculateStackMapFrames desc code) - -calculateStackMapFrames :: MethodDescriptor -> [Instruction] -> [StackMapFrame] -calculateStackMapFrames desc code = - let - (_, _, frameDiffs) = analyseStackMapTable desc code - - isLabel (Label x) = Just x - isLabel _ = Nothing - - labels = mapMaybe isLabel code - jumps = fmap mconcat (fmap snd <$> splitWhen (isJust . isLabel . fst) (zip code frameDiffs)) - - -- jumps = [[ALoad 1], []] - jumpsAndLabels = zip (Nothing : (Just <$> reverse labels)) jumps - x = - foldl' - ( flip $ \(label, res) (acc, stack, locals) -> - let - stack' = apply (fmap fst res) stack - locals' = apply (fmap snd res) locals - in - case liftA2 (,) label res of - Just (label', res') -> - ( calculateStackMapFrame (stack', locals') label' res' : acc - , stack' - , locals' - ) - _ -> (acc, stack', locals') - ) - ([], [], methodParams desc) - jumpsAndLabels - in - (\(a, _, _) -> a) x - --- calculateFrame :: MethodDescriptor -> (StackDiff, LocalsDiff) -> [Instruction] -> [(Label, StackDiff, LocalsDiff)] --- calculateFrame desc prev code = go prev code [] --- where --- go :: (StackDiff, LocalsDiff) -> [Instruction] -> [Instruction] -> [(Label, StackDiff, LocalsDiff)] --- go _ [] _ = [] -- if we run out of instructions before seeing another label, there's no need for a frame --- go prev ((Label label) : xs) acc = do --- let (newStack, newLocals, diffs) = analyseStackMapTable desc acc --- newDiffs@(newDiffs1, newDiffs2) = (prev <> mconcat diffs) --- in (label, newDiffs1, newDiffs2) : go newDiffs xs [] --- go prev (x : xs) acc = go prev xs (acc ++ [x]) - -calculateStackMapFrame :: (Stack, Locals) -> Label -> (StackDiff, LocalsDiff) -> StackMapFrame -calculateStackMapFrame _ target (StackSame, LocalsSame) = SameFrame target -calculateStackMapFrame _ target (StackSame, LocalsPush xs) = AppendFrame (NE.toList $ fieldTypeToVerificationType <$> xs) target -calculateStackMapFrame _ target (StackSame, LocalsPop n) = ChopFrame (fromIntegral n) target -calculateStackMapFrame _ target (StackPush xs, LocalsSame) = SameLocals1StackItemFrame (fieldTypeToVerificationType (NE.last xs)) target -calculateStackMapFrame _ target (StackPush xs, LocalsPush ys) = FullFrame (NE.toList $ fieldTypeToVerificationType <$> xs) (NE.toList $ fieldTypeToVerificationType <$> ys) target -calculateStackMapFrame (stack, locals) target _ = FullFrame (fieldTypeToVerificationType <$> stack) (fieldTypeToVerificationType <$> locals) target - -fieldTypeToVerificationType :: FieldType -> VerificationTypeInfo -fieldTypeToVerificationType (ObjectFieldType x) = ObjectVariableInfo (ClassInfoType x) -fieldTypeToVerificationType (ArrayFieldType x) = ObjectVariableInfo (ArrayClassInfoType (fieldTypeToClassInfoType x)) -fieldTypeToVerificationType (PrimitiveFieldType Byte) = IntegerVariableInfo -fieldTypeToVerificationType (PrimitiveFieldType Char) = IntegerVariableInfo -fieldTypeToVerificationType (PrimitiveFieldType Double) = DoubleVariableInfo -fieldTypeToVerificationType (PrimitiveFieldType Float) = FloatVariableInfo -fieldTypeToVerificationType (PrimitiveFieldType Int) = IntegerVariableInfo -fieldTypeToVerificationType (PrimitiveFieldType Long) = LongVariableInfo -fieldTypeToVerificationType (PrimitiveFieldType Short) = IntegerVariableInfo -fieldTypeToVerificationType (PrimitiveFieldType Boolean) = IntegerVariableInfo - -{- | Finds the difference between the stack and locals at the given jump source and jump target. -@findJumpDiff desc code (jumpSourceIdx, label)@ takes all the instructions between @jumpSourceIdx@ and @label@ in @code@ -and analyses their stack & locals changes, returning the stack and locals at @jumpSourceIdx@ and the diffs between @jumpSourceIdx@ and @label@. --} - --- findJumpDiff :: MethodDescriptor -> [Instruction] -> (Integer, Label) -> (Stack, Locals, (StackDiff, LocalsDiff)) --- findJumpDiff desc code (jump, label) = --- let slice = takeWhile (/= Label label) (drop (fromIntegral jump) code) --- (stack, locals, diffs) = analyseStackMapTable desc slice --- in (stack, locals, mconcat diffs) - -{- | Finds all the instructions in which a jump occurs and the instruction to which it jumps. -For example, given input @[.., IfEq l, .., Label l, x, ..]@ this will return @[(n, l)]@ where @n@ is the index of the @IfEq l@ instruction. --} -findJumps :: [Instruction] -> [(Integer, Label)] -findJumps xs = mapMaybe f (zip xs [0 ..]) - where - f :: (Instruction, Integer) -> Maybe (Integer, Label) - f (inst, i) = (i,) <$> jumpTarget inst diff --git a/src/JVM/Data/Analyse/StackMapTable/Mark.hs b/src/JVM/Data/Analyse/StackMapTable/Mark.hs deleted file mode 100644 index 653bd46..0000000 --- a/src/JVM/Data/Analyse/StackMapTable/Mark.hs +++ /dev/null @@ -1,89 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE NoFieldSelectors #-} - -module JVM.Data.Analyse.StackMapTable.Mark where - -import Control.Applicative ((<|>)) -import Control.Monad.State -import Data.Generics.Sum -import Data.Map (Map) -import Data.Map qualified as Map -import Data.Maybe (fromJust, fromMaybe) -import Data.Traversable (for) -import Data.TypeMergingList qualified as TML -import JVM.Data.Abstract.Builder.Label -import JVM.Data.Abstract.ClassFile.Method (ClassFileMethod, CodeAttributeData (..), MethodAttribute (..), methodAttributes) -import JVM.Data.Abstract.Descriptor (MethodDescriptor) -import JVM.Data.Abstract.Instruction - -data Mark = Mark - { position :: Label - , block :: Maybe BasicBlock - , jump :: Maybe [Maybe BasicBlock] - , alwaysJump :: Bool -- true if an unconditional branch - , size :: Int -- 0 unless the mark indicates RETURN etc - } - -newMark :: Label -> Mark -newMark pos = Mark{position = pos, block = Nothing, jump = Nothing, alwaysJump = False, size = 0} - -instance Eq Mark where - a == b = a.position == b.position - -instance Ord Mark where - compare a b = compare (a.position) (b.position) - -data BasicBlock = BasicBlock - { position :: Label - , length :: Int - , incoming :: Int - , exit :: Maybe [BasicBlock] - , stop :: Bool - } - -makeBlocks :: ClassFileMethod -> Maybe [BasicBlock] -makeBlocks method = do - codeAttr <- TML.getByCtor @"Code" method.methodAttributes - - undefined - -makeMarks :: CodeAttributeData -> Map Label Mark -makeMarks data_ = flip execState mempty $ do - for data_.code $ \inst -> do - case inst of - Goto x -> do - to <- makeMark x - let jumps = replicate ((fromJust $ to.block).position) Nothing - jumps <- makeArray (to.block) - makeMarkFor jumps - -makeMark :: Label -> State (Map Label Mark) Mark -makeMark = makeMark0 True True - -makeMark0 :: Bool -> Bool -> Label -> State (Map Label Mark) Mark -makeMark0 isBlockBegin isTarget label = do - marks <- get - let inTable = fromMaybe (newMark label) (Map.lookup label marks) - modify $ Map.insert label inTable - if isBlockBegin - then do - let newBlock = fromMaybe (makeBlock label) inTable.block - let newBlock' = if isTarget then newBlock{incoming = newBlock.incoming + 1} else newBlock - let newMark = inTable{block = Just newBlock'} - modify $ Map.insert label newMark - pure newMark - else pure inTable - -makeBlock :: Label -> BasicBlock -makeBlock label = - BasicBlock - { position = label - , length = 0 - , incoming = 0 - , exit = Nothing - , stop = False - } \ No newline at end of file diff --git a/src/JVM/Data/Convert/Instruction.hs b/src/JVM/Data/Convert/Instruction.hs index b37e0ad..68d69fe 100644 --- a/src/JVM/Data/Convert/Instruction.hs +++ b/src/JVM/Data/Convert/Instruction.hs @@ -196,7 +196,6 @@ convertInstruction (OffsetInstruction instOffset o) = Just <$> convertInstructio convertInstruction (Abs.IStore 2) = pure Raw.IStore2 convertInstruction (Abs.IStore 3) = pure Raw.IStore3 convertInstruction (Abs.IStore idx) = pure (Raw.IStore idx) - convertInstruction Abs.AConstNull = pure Raw.AConstNull convertInstruction (Abs.InvokeStatic c n m) = do idx <- findIndexOf (CPMethodRefEntry (MethodRef c n m)) diff --git a/src/JVM/Data/Convert/Method.hs b/src/JVM/Data/Convert/Method.hs index de5de20..bbb3fdd 100644 --- a/src/JVM/Data/Convert/Method.hs +++ b/src/JVM/Data/Convert/Method.hs @@ -16,6 +16,7 @@ import JVM.Data.Convert.Instruction (CodeConverter, convertInstructions, fullyRe import JVM.Data.Convert.Monad (ConvertM) import JVM.Data.Raw.ClassFile qualified as Raw import JVM.Data.Raw.Types +import Data.TypeMergingList qualified as TML -- >>> foldMWith (\a b -> pure (a + b, a + b)) 0 [1, 2, 3] -- (6,[1,3,6]) @@ -134,5 +135,5 @@ convertMethod Abs.ClassFileMethod{..} = do let flags = accessFlagsToWord16 methodAccessFlags nameIndex <- findIndexOf (CPUTF8Entry methodName) descriptorIndex <- findIndexOf (CPUTF8Entry (convertMethodDescriptor methodDescriptor)) - attributes <- traverse convertMethodAttribute methodAttributes - pure $ Raw.MethodInfo flags (fromIntegral nameIndex) (fromIntegral descriptorIndex) (V.fromList attributes) + attributes <- traverse convertMethodAttribute (TML.toVector methodAttributes) + pure $ Raw.MethodInfo flags (fromIntegral nameIndex) (fromIntegral descriptorIndex) attributes diff --git a/src/JVM/Data/Pretty.hs b/src/JVM/Data/Pretty.hs index 1e4e6aa..9277475 100644 --- a/src/JVM/Data/Pretty.hs +++ b/src/JVM/Data/Pretty.hs @@ -1,19 +1,18 @@ - {-# LANGUAGE DerivingVia #-} {-# LANGUAGE UndecidableInstances #-} -module JVM.Data.Pretty (showPretty, tracePrettyId, Pretty(..), (<+>), hsep) where +module JVM.Data.Pretty (showPretty, tracePrettyId, Pretty (..), (<+>), hsep) where import Data.String -import Prettyprinter -import Prettyprinter.Render.Text (renderStrict) import Data.Text (unpack) import Debug.Trace (trace) +import Prettyprinter +import Prettyprinter.Render.Text (renderStrict) showPretty :: IsString s => Pretty a => a -> s showPretty = fromString . unpack . renderStrict . layoutPretty defaultLayoutOptions . pretty instance Pretty (Doc a) where - pretty = unAnnotate + pretty = unAnnotate tracePrettyId :: (Pretty a) => a -> a -tracePrettyId a = trace (showPretty a) a \ No newline at end of file +tracePrettyId a = trace (showPretty a) a diff --git a/test/Analyse.hs b/test/Analyse.hs index b9cc999..ab4c54a 100644 --- a/test/Analyse.hs +++ b/test/Analyse.hs @@ -8,7 +8,7 @@ import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range import JVM.Data.Abstract.Name import JVM.Data.Abstract.Type -import JVM.Data.Analyse.Instruction + import Test.Hspec import Test.Hspec.Hedgehog @@ -41,72 +41,9 @@ genFieldType = [ Gen.subterm genFieldType ArrayFieldType ] -genStackDiff :: Gen StackDiff -genStackDiff = - Gen.choice - [ stackPush <$> Gen.list (Range.linear 0 100) genFieldType - , stackPop <$> Gen.integral (Range.linear 0 100) - , stackPopAndPush <$> Gen.integral (Range.linear 0 100) <*> Gen.list (Range.linear 0 100) genFieldType - , pure StackSame - ] + spec :: Spec spec = describe "Analysis checks" $ do describe "Does StackDiff concatenation correctly" $ do - it "Is StackSame identity" $ hedgehog $ do - a <- forAll genStackDiff - a <> StackSame === a - StackSame <> a === a - - it "is stackPopAndPush valid when normalised" $ hedgehog $ do - n <- forAll $ Gen.integral (Range.linear 1 100) - ts <- forAll $ Gen.list (Range.linear 1 100) genFieldType - - normaliseStackDiff (stackPopAndPush n ts) - === if n <= length ts - then stackPush (drop n ts) - else stackPop (n - length ts) - - normaliseStackDiff (stackPopAndPush n ts) === stackPop n <> stackPush ts - stackPop n <> stackPush ts === normaliseStackDiff (stackPopAndPush n ts) - - it "is StackPush + StackPop valid" $ hedgehog $ do - n <- forAll $ Gen.integral (Range.linear 1 100) - ts <- forAll $ Gen.nonEmpty (Range.linear 1 100) genFieldType - - StackPop n <> StackPush ts === case n `compare` length ts of - LT -> stackPush (NE.drop n ts) - EQ -> StackSame - GT -> stackPop (n - length ts) - StackPush ts - <> StackPop n - === if n <= length ts - then stackPush (NE.drop n ts) - else stackPop (n - length ts) - - it "Is StackPop + StackPopAndPush valid" $ hedgehog $ do - n <- forAll $ Gen.integral (Range.linear 1 100) - n2 <- forAll $ Gen.integral (Range.linear 1 100) - ts <- forAll $ Gen.list (Range.linear 1 100) genFieldType - - stackPop n <> stackPopAndPush n2 ts === stackPopAndPush (n2 + n) ts - stackPopAndPush n2 ts - <> stackPop n - === if (n + n2) <= length ts - then stackPush (drop (n + n2) ts) - else stackPop (n + n2 - length ts) - - it "Is StackPush + StackPopAndPush valid" $ hedgehog $ do - n <- forAll $ Gen.integral (Range.linear 1 100) - ts1 <- forAll $ Gen.list (Range.linear 1 100) genFieldType - ts2 <- forAll $ Gen.list (Range.linear 1 100) genFieldType - - stackPopAndPush n ts1 - <> stackPush ts2 - === if n >= length ts1 - then stackPop (n - length ts1) <> stackPush (ts2) - else normaliseStackDiff $ stackPopAndPush n (ts1 <> ts2) - (stackPush ts1 <> stackPopAndPush n ts2) - === if n <= length ts1 - then stackPush (drop n ts1) <> stackPush ts2 - else stackPop (n - length ts1) <> stackPush ts2 + pure () \ No newline at end of file diff --git a/test/Builder.hs b/test/Builder.hs index 691764f..e851e95 100644 --- a/test/Builder.hs +++ b/test/Builder.hs @@ -2,26 +2,13 @@ module Builder where -import Control.Monad.IO.Class -import Data.Binary.Put -import Data.Binary.Write -import Data.ByteString qualified as BS -import Data.List (scanl') import Hedgehog -import JVM.Data.Abstract.Builder (addMethod, runClassBuilder) import JVM.Data.Abstract.Builder.Code -import JVM.Data.Abstract.ClassFile.AccessFlags -import JVM.Data.Abstract.ClassFile.Method -import JVM.Data.Abstract.Descriptor import JVM.Data.Abstract.Instruction -import JVM.Data.Abstract.Type as JVM -import JVM.Data.Analyse.Instruction -import JVM.Data.Convert -import JVM.Data.JVMVersion (java17) import JVM.Data.Raw.Instruction qualified as Raw import Test.Hspec import Test.Hspec.Hedgehog -import Util (runConv, shouldBeRight) +import Util (runConv) spec :: Spec spec = describe "test code building" $ do @@ -45,384 +32,3 @@ spec = describe "test code building" $ do , Raw.IfEq 3 , Raw.Return ] - -- complex1 - simple1 - --- complex2 - -simple1 :: Spec -simple1 = describe "Should handle another more simple example correctly" $ do - let ((label1, absInsts), attrs, code) = runCodeBuilder' $ do - label1 <- newLabel - let code = - [ ALoad 0 - , Goto label1 - , Label label1 - , AReturn - ] - - emit' code - pure (label1, code) - - it "Converts correctly" $ hedgehog $ do - (insts, _) <- runConv code - insts - === [ Raw.ALoad0 - , Raw.Goto 3 - , Raw.AReturn - ] - - it "Calculates the stack map frames correctly" $ hedgehog $ do - let desc = MethodDescriptor [(ObjectFieldType "java.lang.Integer")] (TypeReturn (ObjectFieldType "java.lang.Integer")) - (_, _, diffs) = analyseStackMapTable desc code - frames = calculateStackMapFrames desc code - - frames - === [ SameLocals1StackItemFrame IntegerVariableInfo label1 - ] - diffs - === [ Just (StackPush [ObjectFieldType "java.lang.Integer"], LocalsSame) - , Just (StackSame, LocalsSame) - , Nothing - , Just (StackPop 1, LocalsSame) - ] - - applyMany (fmap fst <$> diffs) [] === [] - applyMany (fmap snd <$> diffs) (methodParams desc) - === [(ObjectFieldType "java.lang.Integer")] - -complex1 :: Spec -complex1 = describe "Should handle more complex labels correctly" $ do - {- - 0: aload_0 - 1: ldc #39 // int 0 - 3: invokestatic #15 // Method java/lang/Integer.valueOf:(I)Ljava/lang/Integer; - 6: invokestatic #43 // Method Prelude.eq:(Ljava/lang/Object;Ljava/lang/Object;)Ljava/lang/Boolean; - 9: invokevirtual #49 // Method java/lang/Boolean.booleanValue:()Z - 12: ifeq 23 - 15: ldc #50 // int 1 - 17: invokestatic #15 // Method java/lang/Integer.valueOf:(I)Ljava/lang/Integer; - 20: goto 39 - Label #1 - 23: aload_0 - 24: aload_0 - 25: ldc #50 // int 1 - 27: invokestatic #15 // Method java/lang/Integer.valueOf:(I)Ljava/lang/Integer; - 30: invokestatic #54 // Method Prelude.minus:(Ljava/lang/Integer;Ljava/lang/Integer;)Ljava/lang/Integer; - 33: invokestatic #19 // Method fact:(Ljava/lang/Integer;)Ljava/lang/Integer; - 36: invokestatic #57 // Method Prelude.times:(Ljava/lang/Integer;Ljava/lang/Integer;)Ljava/lang/Integer; - Label #2 - 39: areturn - -} - let (((label1, label2), absInsts), attrs, code) = runCodeBuilder' $ do - label1 <- newLabel - label2 <- newLabel - let code = - [ ALoad 0 -- stack = [java.lang.Integer] - , LDC (LDCInt 1) -- stack = [java.lang.Integer, 1] - , InvokeStatic (ClassInfoType "java.lang.Integer") "valueOf" (MethodDescriptor [PrimitiveFieldType JVM.Int] (TypeReturn (ObjectFieldType "java.lang.Integer"))) -- stack = [java.lang.Integer, java.lang.Integer] - , InvokeStatic (ClassInfoType "Prelude") "eq" (MethodDescriptor [ObjectFieldType "java.lang.Object", ObjectFieldType "java.lang.Object"] (TypeReturn (ObjectFieldType "java.lang.Boolean"))) -- stack = [java.lang.Boolean] - , InvokeVirtual (ClassInfoType "java.lang.Boolean") "booleanValue" (MethodDescriptor [] (TypeReturn (PrimitiveFieldType JVM.Boolean))) -- stack = [java.lang.Boolean] - , IfEq label1 -- stack = [] - , LDC (LDCInt 1) -- stack = [1] - , InvokeStatic (ClassInfoType "java.lang.Integer") "valueOf" (MethodDescriptor [PrimitiveFieldType JVM.Int] (TypeReturn (ObjectFieldType "java.lang.Integer"))) -- stack = [java.lang.Integer] - , Goto label2 -- stack = [java.lang.Integer] - , Label label1 -- stack = [java.lang.Integer] - , ALoad 0 -- stack = [java.lang.Integer, java.lang.Integer] - , ALoad 0 -- stack = [java.lang.Integer, java.lang.Integer, java.lang.Integer] - , LDC (LDCInt 1) -- stack = [java.lang.Integer, java.lang.Integer, java.lang.Integer, 1] - , InvokeStatic (ClassInfoType "java.lang.Integer") "valueOf" (MethodDescriptor [PrimitiveFieldType JVM.Int] (TypeReturn (ObjectFieldType "java.lang.Integer"))) -- stack = [java.lang.Integer, java.lang.Integer, java.lang.Integer, java.lang.Integer] - , InvokeStatic (ClassInfoType "Prelude") "minus" (MethodDescriptor [ObjectFieldType "java.lang.Integer", ObjectFieldType "java.lang.Integer"] (TypeReturn (ObjectFieldType "java.lang.Integer"))) -- stack = [java.lang.Integer, java.lang.Integer, java.lang.Integer] - , InvokeStatic (ClassInfoType "fact") "fact" (MethodDescriptor [ObjectFieldType "java.lang.Integer"] (TypeReturn (ObjectFieldType "java.lang.Integer"))) -- stack = [java.lang.Integer, java.lang.Integer] - , InvokeStatic (ClassInfoType "Prelude") "times" (MethodDescriptor [ObjectFieldType "java.lang.Integer", ObjectFieldType "java.lang.Integer"] (TypeReturn (ObjectFieldType "java.lang.Integer"))) -- stack = [java.lang.Integer] - , Label label2 -- stack = [java.lang.Integer] - , AReturn -- stack = [] - ] - emit' code - pure ((label1, label2), code) - it "Converts correctly" $ hedgehog $ do - (insts, _) <- runConv code - insts - === [ Raw.ALoad0 -- #0 - , Raw.LDC 1 -- #1 - , Raw.InvokeStatic 7 -- #3 - , Raw.InvokeStatic 13 -- #6 - , Raw.InvokeVirtual 19 -- #9 - , Raw.IfEq 11 -- #12 - , Raw.LDC 1 -- #15 - , Raw.InvokeStatic 7 -- #17 - , Raw.Goto 19 -- #20 - , Raw.ALoad0 -- #23 - , Raw.ALoad0 -- #24 - , Raw.LDC 1 -- #25 - , Raw.InvokeStatic 7 -- #27 - , Raw.InvokeStatic 23 -- #30 - , Raw.InvokeStatic 28 -- #33 - , Raw.InvokeStatic 31 -- #36 - , Raw.AReturn -- #39 - ] - - it "Calculates the stack map frames correctly" $ hedgehog $ do - let desc = MethodDescriptor [ObjectFieldType "java.lang.Integer"] (TypeReturn (ObjectFieldType "java.lang.Integer")) - (_, _, diffs) = analyseStackMapTable desc code - frames = calculateStackMapFrames desc code - - diffs - === ( Just - <$> [ (StackPush [ObjectFieldType "java.lang.Integer"], LocalsSame) -- stack = [java.lang.Integer] - , (StackPush [PrimitiveFieldType Int], LocalsSame) -- stack = [int, java.lang.Integer] - , (stackPopAndPush 1 [ObjectFieldType "java.lang.Integer"], LocalsSame) -- stack = [java.lang.Integer, java.lang.Integer] - , (stackPopAndPush 2 [ObjectFieldType "java.lang.Boolean"], LocalsSame) -- stack = [java.lang.Boolean] - , (stackPopAndPush 1 [PrimitiveFieldType Boolean], LocalsSame) -- stack = [boolean] - , (stackPop 1, LocalsSame) -- stack = [] - , (StackPush [PrimitiveFieldType Int], LocalsSame) -- stack = [int] - , (stackPopAndPush 1 [ObjectFieldType "java.lang.Integer"], LocalsSame) -- stack = [java.lang.Integer] - , (StackSame, LocalsSame) -- stack = [java.lang.Integer] - ] - ) - ++ [Nothing] -- stack = [java.lang.Integer] - ++ ( Just - <$> [ (StackPush [ObjectFieldType "java.lang.Integer"], LocalsSame) -- stack = [java.lang.Integer, java.lang.Integer] - , (StackPush [ObjectFieldType "java.lang.Integer"], LocalsSame) -- stack = [java.lang.Integer, java.lang.Integer, java.lang.Integer] - , (StackPush [PrimitiveFieldType Int], LocalsSame) -- stack = [java.lang.Integer, java.lang.Integer, java.lang.Integer, int] - , (stackPopAndPush 1 [ObjectFieldType "java.lang.Integer"], LocalsSame) -- stack = [java.lang.Integer, java.lang.Integer, java.lang.Integer, java.lang.Integer] - , (stackPopAndPush 2 [ObjectFieldType "java.lang.Integer"], LocalsSame) -- stack = [java.lang.Integer, java.lang.Integer, java.lang.Integer] - , (stackPopAndPush 1 [ObjectFieldType "java.lang.Integer"], LocalsSame) -- stack = [java.lang.Integer, java.lang.Integer] - , (stackPopAndPush 2 [ObjectFieldType "java.lang.Integer"], LocalsSame) -- stack = [java.lang.Integer] - ] - ) - ++ [ Nothing -- stack = [java.lang.Integer] - , Just (stackPop 1, LocalsSame) -- stack = [] - ] - - frames - === [ SameFrame label1 - , SameLocals1StackItemFrame (ObjectVariableInfo (ClassInfoType "java.lang.Integer")) label2 - ] - -complex2 :: Spec -complex2 = describe "Should handle another complex example correctly" $ do - {- - public static elara.EList plusplus(elara.EList, elara.EList); - Code: - 0: aload_0 - 1: checkcast #12 // class elara/EList - 4: dup - 5: astore_2 - 6: invokevirtual #16 // Method elara/EList.isEmpty:()Z - 9: ifne 36 - 12: aload_2 - 13: getfield #20 // Field elara/EList.head:Ljava/lang/Object; - 16: astore_3 - 17: aload_2 - 18: getfield #24 // Field elara/EList.tail:Lelara/EList; - 21: astore 4 - 23: aload_3 - 24: aload 4 - 26: aload_1 - 27: invokestatic #26 // Method plusplus:(Lelara/EList;Lelara/EList;)Lelara/EList; - 30: invokestatic #32 // Method Elara/Prim.cons:(Ljava/lang/Object;Lelara/EList;)Lelara/EList; - 33: goto 37 - 36: aload_1 - 37: areturn - -} - let (((label1, label2), absInsts), attrs, code) = runCodeBuilder' $ do - label1 <- newLabel - label2 <- newLabel - let code = - [ ALoad 0 - , CheckCast (ClassInfoType "elara.EList") - , Dup - , AStore 2 - , InvokeVirtual (ClassInfoType "elara.EList") "isEmpty" (MethodDescriptor [] (TypeReturn (PrimitiveFieldType JVM.Boolean))) - , IfNe label1 - , ALoad 2 - , GetField (ClassInfoType "elara.EList") "head" (ObjectFieldType "java.lang.Object") - , AStore 3 - , ALoad 2 - , GetField (ClassInfoType "elara.EList") "tail" (ObjectFieldType "elara.EList") - , AStore 4 - , ALoad 3 - , ALoad 4 - , ALoad 1 - , InvokeStatic (ClassInfoType "BuilderTest2") "plusplus" (MethodDescriptor [ObjectFieldType "elara.EList", ObjectFieldType "elara.EList"] (TypeReturn (ObjectFieldType "elara.EList"))) - , InvokeStatic (ClassInfoType "Elara.Prim") "cons" (MethodDescriptor [ObjectFieldType "java.lang.Object", ObjectFieldType "elara.EList"] (TypeReturn (ObjectFieldType "elara.EList"))) - , Goto label2 - , Label label1 - , ALoad 1 - , Label label2 - , AReturn - ] - - emit' code - pure ((label1, label2), code) - - it "Converts correctly" $ hedgehog $ do - (insts, _) <- runConv code - insts - === [ Raw.ALoad0 -- #0 - , Raw.CheckCast 2 -- #1 - , Raw.Dup -- #4 - , Raw.AStore2 -- #5 - , Raw.InvokeVirtual 6 -- #6 - , Raw.IfNe 27 -- #9 - , Raw.ALoad2 -- #12 - , Raw.GetField 10 -- #13 - , Raw.AStore3 -- #16 - , Raw.ALoad2 -- #17 - , Raw.GetField 14 -- #18 - , Raw.AStore 4 -- #21 - , Raw.ALoad3 -- #23 - , Raw.ALoad 4 -- #24 - , Raw.ALoad1 -- #25 - , Raw.InvokeStatic 20 -- #27 - , Raw.InvokeStatic 26 -- #30 - , Raw.Goto 4 -- #33 - , Raw.ALoad1 -- #36 - , Raw.AReturn -- #37 - ] - - it "Calculates the stack map frames correctly" $ hedgehog $ do - let desc = MethodDescriptor [ObjectFieldType "elara.EList", ObjectFieldType "elara.EList"] (TypeReturn (ObjectFieldType "elara.EList")) - (_, _, diffs) = analyseStackMapTable desc code - frames = calculateStackMapFrames desc code - - let elist = ObjectVariableInfo (ClassInfoType "elara.EList") - frames - === [ FullFrame [elist] [elist, elist, elist, ObjectVariableInfo (ClassInfoType "java.lang.Object"), elist] label1 - , SameLocals1StackItemFrame elist label2 - ] - diffs - === ( Just - <$> [ (StackPush [ObjectFieldType "elara.EList"], LocalsSame) -- stack = [elara.EList] - , (StackSame, LocalsSame) -- stack = [elara.EList] - , (StackPush [ObjectFieldType "elara.EList"], LocalsSame) -- stack = [elara.EList, elara.EList] - , (stackPop 1, LocalsPush [ObjectFieldType "elara.EList"]) -- stack = [elara.EList] - , (stackPopAndPush 1 [PrimitiveFieldType Boolean], LocalsSame) -- stack = [Boolean] - , (stackPop 1, LocalsSame) -- stack = [] - , (StackPush [ObjectFieldType "elara.EList"], LocalsSame) -- stack = [elara.EList] - , (stackPopAndPush 1 [ObjectFieldType "java.lang.Object"], LocalsSame) -- stack = [java.lang.Object] - , (stackPop 1, LocalsPush [ObjectFieldType "java.lang.Object"]) -- stack = [] - , (StackPush [ObjectFieldType "elara.EList"], LocalsSame) -- stack = [elara.EList] - , (stackPopAndPush 1 [ObjectFieldType "elara.EList"], LocalsSame) -- stack = [elara.EList] - , (stackPop 1, LocalsPush [ObjectFieldType "elara.EList"]) -- stack = [] - , (StackPush [ObjectFieldType "java.lang.Object"], LocalsSame) -- stack = [java.lang.Object] - , (StackPush [ObjectFieldType "elara.EList"], LocalsSame) -- stack = [java.lang.Object, elara.EList] - , (StackPush [ObjectFieldType "elara.EList"], LocalsSame) -- stack = [java.lang.Object, elara.EList, elara.EList] - , (stackPopAndPush 2 [ObjectFieldType "elara.EList"], LocalsSame) -- stack = [java.lang.Object, elara.EList] - , (stackPopAndPush 2 [ObjectFieldType "elara.EList"], LocalsSame) -- stack = [elara.EList] - , (StackSame, LocalsSame) -- stack = [elara.EList] - ] - ) - ++ [ Nothing -- stack = [elara.EList] - , Just (StackPush [ObjectFieldType "elara.EList"], LocalsSame) -- stack = [elara.EList, elara.EList] - , Nothing -- stack = [elara.EList] - , Just (stackPop 1, LocalsSame) -- stack = [elara.EList] - ] - - applyMany (fmap fst <$> diffs) [] === [ObjectFieldType "elara.EList"] - applyMany (fmap snd <$> diffs) (methodParams desc) - === replicate 3 (ObjectFieldType "elara.EList") - ++ [ObjectFieldType "java.lang.Object"] - ++ [ObjectFieldType "elara.EList"] - - let diffsUntilLabel1 = take 18 diffs - applyMany (fmap fst <$> diffsUntilLabel1) [] === [ObjectFieldType "elara.EList"] - applyMany (fmap snd <$> diffsUntilLabel1) (methodParams desc) - === replicate 3 (ObjectFieldType "elara.EList") - ++ [ObjectFieldType "java.lang.Object"] - ++ [ObjectFieldType "elara.EList"] - -complex3 :: Spec -complex3 = describe "Should handle another more simple example correctly" $ do - {- - public static void main(java.lang.String[]); - 0: ldc #7 // int 400043 - 2: istore_1 - 3: iconst_1 - 4: istore_2 - 5: iconst_1 - 8: ifeq 22 - 11: sipush 4922 - 14: istore_3 - 15: getstatic #14 // Field java/lang/System.out:Ljava/io/PrintStream; - 18: iload_3 - 19: invokevirtual #20 // Method java/io/PrintStream.println:(I)V - 22: ldc #26 // int 40303 - 24: istore_3 - 25: return - -} - let ((label1, absInsts), attrs, code) = runCodeBuilder' $ do - label1 <- newLabel - let code = - [ LDC (LDCInt 400043) - , IStore 1 - , LDC (LDCInt 1) - , IStore 2 - , LDC (LDCInt 1) - , IfEq label1 - , LDC (LDCInt 4922) - , IStore 3 - , GetStatic (ClassInfoType "java.lang.System") "out" (ObjectFieldType "java.io.PrintStream") - , ILoad 3 - , InvokeVirtual (ClassInfoType "java.io.PrintStream") "println" (MethodDescriptor [PrimitiveFieldType JVM.Int] VoidReturn) - , Label label1 - , LDC (LDCInt 40303) - , IStore 3 - , Return - ] - - emit' code - pure (label1, code) - - it "Converts correctly" $ hedgehog $ do - (insts, _) <- runConv code - insts - === [ Raw.LDC 1 -- #0 - , Raw.IStore1 -- #2 - , Raw.LDC 2 -- #3 - , Raw.IStore2 -- #4 - , Raw.LDC 2 -- #5 - , Raw.IfEq 13 -- #8 - , Raw.LDC 3 -- #11 - , Raw.IStore3 -- #14 - , Raw.GetStatic 9 -- #15 - , Raw.ILoad3 -- #18 - , Raw.InvokeVirtual 15 -- #19 - , Raw.LDC 16 -- #22 - , Raw.IStore3 -- #24 - , Raw.Return -- #25 - ] - - it "Calculates the stack map frames correctly" $ hedgehog $ do - let desc = MethodDescriptor [ArrayFieldType (ObjectFieldType "java.lang.String")] VoidReturn - (_, _, diffs) = analyseStackMapTable desc code - frames = calculateStackMapFrames desc code - - frames - === [ AppendFrame [IntegerVariableInfo, IntegerVariableInfo] label1 - ] - diffs - === ( Just - <$> [ (StackPush [PrimitiveFieldType Int], LocalsSame) -- ldc 1 -> stack = [int] locals = [java.lang.String[]] - , (StackPop 1, LocalsPush [PrimitiveFieldType Int]) -- istore1 -> stack = [] locals = [java.lang.String[], int] - , (StackPush [PrimitiveFieldType Int], LocalsSame) -- ldc 2 -> stack = [int] locals = [java.lang.String[], int] - , (StackPop 1, LocalsPush [PrimitiveFieldType Int]) -- istore2 -> stack = [] locals = [java.lang.String[], int, int] - , (StackPush [PrimitiveFieldType Int], LocalsSame) -- ldc 2 -> stack = [int] locals = [java.lang.String[], int, int] - , (StackPop 1, LocalsSame) -- ifeq 13 -> stack = [] locals = [java.lang.String[], int, int] - , (StackPush [PrimitiveFieldType Int], LocalsSame) -- ldc 3 -> stack = [int] locals = [java.lang.String[], int, int] - , (StackPop 1, LocalsPush [PrimitiveFieldType Int]) -- istore3 -> stack = [] locals = [java.lang.String[], int, int, int] - , (StackPush [ObjectFieldType "java.io.PrintStream"], LocalsSame) -- getstatic -> stack = [java.io.PrintStream] locals = [java.lang.String[], int, int, int] - , (StackPush [PrimitiveFieldType Int], LocalsSame) -- iload3 -> stack = [int, java.io.PrintStream] locals = [java.lang.String[], int, int, int] - , (StackPop 2, LocalsSame) -- invokevirtual -> stack = [] locals = [java.lang.String[], int, int, int] - ] - ) - ++ [ Nothing -- stack = [] locals = [java.lang.String[], int, int, int] - , Just (StackPush [PrimitiveFieldType Int], LocalsSame) -- ldc 16 -> stack = [int] locals = [java.lang.String[], int, int, int] - , Just (StackPop 1, LocalsSame) -- istore3 -> stack = [] locals = [java.lang.String[], int, int, int] - , Just (StackSame, LocalsSame) -- stack = [] locals = [java.lang.String[], int, int, int] - ] - - applyMany (fmap fst <$> diffs) [] === [] - applyMany (fmap snd <$> diffs) (methodParams desc) - === [ArrayFieldType (ObjectFieldType "java.lang.String"), PrimitiveFieldType Int, PrimitiveFieldType Int, PrimitiveFieldType Int] diff --git a/test/Main.hs b/test/Main.hs index 16890ca..a605c33 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -2,8 +2,8 @@ module Main where -import Builder qualified (spec) import Analyse qualified (spec) +import Builder qualified (spec) import Convert qualified (spec) import Test.Hspec (Spec, hspec) From 51e61621fbcc0d59a368fc1699443673c47deff5 Mon Sep 17 00:00:00 2001 From: Alexander Wood Date: Sat, 2 Dec 2023 16:42:06 +0000 Subject: [PATCH 04/23] basic blocks --- README.MD | 3 +-- h2jvm.cabal | 1 + src/Data/TypeMergingList.hs | 5 ++--- src/JVM/Data/Abstract/Instruction.hs | 3 ++- src/JVM/Data/Analyse/StackMap.hs | 24 +++++++++++++++++++++++ src/JVM/Data/Convert/Method.hs | 2 +- test/Analyse.hs | 29 +++++++++++++++++++++++++--- 7 files changed, 57 insertions(+), 10 deletions(-) create mode 100644 src/JVM/Data/Analyse/StackMap.hs diff --git a/README.MD b/README.MD index fe79c25..e4eaa66 100644 --- a/README.MD +++ b/README.MD @@ -8,5 +8,4 @@ H2JVM does its processing in a pipeline: 2. This class is analysed using code in the `JVM.Data.HLAnalyse` modules - calculating jump offsets, etc. This stage may also do some optimisations, such as removing dead code. 3. The class is converted to a low level format (`JVM.Data.Raw`) using the `JVM.Data.Convert` module -4. The low level class is analysed using code in the `JVM.Data.LLAnalyse` modules - adding stack map frames, calculating stack sizes, etc. -5. The low level format is converted to a `ByteString` using the `JVM.Data.Raw` modules, which can be written to a file. or used in a JVM. \ No newline at end of file +4. The low level format is converted to a `ByteString` using the `JVM.Data.Raw` modules, which can be written to a file. or used in a JVM. \ No newline at end of file diff --git a/h2jvm.cabal b/h2jvm.cabal index bdb1aa7..400bee4 100644 --- a/h2jvm.cabal +++ b/h2jvm.cabal @@ -85,6 +85,7 @@ library JVM.Data.Abstract.Instruction JVM.Data.Abstract.Name JVM.Data.Abstract.Type + JVM.Data.Analyse.StackMap JVM.Data.Convert JVM.Data.Convert.AccessFlag JVM.Data.Convert.ConstantPool diff --git a/src/Data/TypeMergingList.hs b/src/Data/TypeMergingList.hs index 6b5b67a..ef97348 100644 --- a/src/Data/TypeMergingList.hs +++ b/src/Data/TypeMergingList.hs @@ -22,10 +22,10 @@ import Control.Lens ((^?)) import Data.Data import Data.Generics.Sum.Constructors import Data.List (foldl') -import GHC.Generics (Generic) -import GHC.IsList qualified as L import Data.Vector (Vector) import Data.Vector qualified as V +import GHC.Generics (Generic) +import GHC.IsList qualified as L newtype TypeMergingList a = TypeMergingList [a] deriving (Eq, Ord, Show) @@ -84,6 +84,5 @@ instance (DataMergeable a) => L.IsList (TypeMergingList a) where fromList = fromList toList = toList - instance Foldable TypeMergingList where foldMap f (TypeMergingList xs) = foldMap f xs diff --git a/src/JVM/Data/Abstract/Instruction.hs b/src/JVM/Data/Abstract/Instruction.hs index dadc27b..bc0521c 100644 --- a/src/JVM/Data/Abstract/Instruction.hs +++ b/src/JVM/Data/Abstract/Instruction.hs @@ -7,6 +7,7 @@ module JVM.Data.Abstract.Instruction where import Data.Text (Text) +import GHC.Generics (Generic) import JVM.Data.Abstract.Builder.Label (Label) import JVM.Data.Abstract.ConstantPool import JVM.Data.Abstract.Descriptor @@ -43,7 +44,7 @@ data Instruction' label | Goto label | CheckCast ClassInfoType | Return - deriving (Show, Eq, Ord, Functor) + deriving (Show, Eq, Ord, Functor, Generic) instance (Pretty label) => Pretty (Instruction' label) where pretty (ALoad x) = "aload" <+> pretty x diff --git a/src/JVM/Data/Analyse/StackMap.hs b/src/JVM/Data/Analyse/StackMap.hs new file mode 100644 index 0000000..e2d8c1b --- /dev/null +++ b/src/JVM/Data/Analyse/StackMap.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE DataKinds #-} + +{- | Generate a stack map table for a method. +This process MUST run last in the high level stage - +modifications to the code after this point will invalidate the stack map table and cause invalid class files to be generated. +-} +module JVM.Data.Analyse.StackMap where + +import Control.Lens.Extras (is) +import Data.Generics.Sum (AsAny (_As)) +import Data.List.Split (split, splitOn, splitWhen) +import JVM.Data.Abstract.Instruction + +data BasicBlock = BasicBlock + { index :: Int + , instructions :: [Instruction] + } + deriving (Show, Eq) + +splitIntoBasicBlocks :: [Instruction] -> [BasicBlock] +splitIntoBasicBlocks [] = [] +splitIntoBasicBlocks l = + let blocks = splitWhen (is (_As @"Label")) l + in zipWith BasicBlock [0 ..] blocks diff --git a/src/JVM/Data/Convert/Method.hs b/src/JVM/Data/Convert/Method.hs index bbb3fdd..81ece5c 100644 --- a/src/JVM/Data/Convert/Method.hs +++ b/src/JVM/Data/Convert/Method.hs @@ -4,6 +4,7 @@ module JVM.Data.Convert.Method where import Control.Applicative (liftA2) +import Data.TypeMergingList qualified as TML import Data.Vector qualified as V import GHC.Stack (HasCallStack) import JVM.Data.Abstract.ClassFile.Method @@ -16,7 +17,6 @@ import JVM.Data.Convert.Instruction (CodeConverter, convertInstructions, fullyRe import JVM.Data.Convert.Monad (ConvertM) import JVM.Data.Raw.ClassFile qualified as Raw import JVM.Data.Raw.Types -import Data.TypeMergingList qualified as TML -- >>> foldMWith (\a b -> pure (a + b, a + b)) 0 [1, 2, 3] -- (6,[1,3,6]) diff --git a/test/Analyse.hs b/test/Analyse.hs index ab4c54a..26ab455 100644 --- a/test/Analyse.hs +++ b/test/Analyse.hs @@ -9,6 +9,9 @@ import Hedgehog.Range qualified as Range import JVM.Data.Abstract.Name import JVM.Data.Abstract.Type +import JVM.Data.Abstract.Builder.Code +import JVM.Data.Abstract.Instruction +import JVM.Data.Analyse.StackMap (BasicBlock (BasicBlock), splitIntoBasicBlocks) import Test.Hspec import Test.Hspec.Hedgehog @@ -41,9 +44,29 @@ genFieldType = [ Gen.subterm genFieldType ArrayFieldType ] - - spec :: Spec spec = describe "Analysis checks" $ do describe "Does StackDiff concatenation correctly" $ do - pure () \ No newline at end of file + it "Can identify basic blocks properly" $ do + let (l, _, code) = runCodeBuilder' $ do + label <- newLabel + emit $ LDC (LDCInt 0) + emit $ IStore 1 + emit $ LDC (LDCInt 0) + emit $ IStore 2 + emit $ ILoad 1 + emit $ IfLe label + emit $ LDC (LDCInt 0) + emit $ IStore 3 + emit $ Label label + emit $ LDC (LDCInt 0) + emit $ IStore 3 + emit Return + pure label + hedgehog $ do + let x = splitIntoBasicBlocks code + + x + === [ BasicBlock 0 [LDC (LDCInt 0), IStore 1, LDC (LDCInt 0), IStore 2, ILoad 1, IfLe l, LDC (LDCInt 0), IStore 3] + , BasicBlock 1 [LDC (LDCInt 0), IStore 3, Return] + ] From 58c14eb3e28d324f5ed9c0ffe2ad6d624cd40715 Mon Sep 17 00:00:00 2001 From: Alexander Wood Date: Tue, 5 Dec 2023 20:03:20 +0000 Subject: [PATCH 05/23] partial rewrite of SMT algorithm, definitely doesnt work well --- src/JVM/Data/Analyse/StackMap.hs | 111 ++++++++++++++++++++++++++++++- test/Analyse.hs | 94 +++++++++++++++++++++----- test/Builder.hs | 2 + 3 files changed, 188 insertions(+), 19 deletions(-) diff --git a/src/JVM/Data/Analyse/StackMap.hs b/src/JVM/Data/Analyse/StackMap.hs index e2d8c1b..56d8e0b 100644 --- a/src/JVM/Data/Analyse/StackMap.hs +++ b/src/JVM/Data/Analyse/StackMap.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiWayIf #-} {- | Generate a stack map table for a method. This process MUST run last in the high level stage - @@ -6,19 +7,123 @@ modifications to the code after this point will invalidate the stack map table a -} module JVM.Data.Analyse.StackMap where +import Control.Lens ((^.), (^?), _Just) import Control.Lens.Extras (is) +import Control.Lens.Fold import Data.Generics.Sum (AsAny (_As)) -import Data.List.Split (split, splitOn, splitWhen) +import Data.List +import Data.Maybe (fromJust) +import JVM.Data.Abstract.Builder.Label +import JVM.Data.Abstract.ClassFile.Method +import JVM.Data.Abstract.Descriptor (MethodDescriptor (MethodDescriptor)) import JVM.Data.Abstract.Instruction +import JVM.Data.Abstract.Type (ClassInfoType (..), FieldType (..), PrimitiveType (..), fieldTypeToClassInfoType) data BasicBlock = BasicBlock { index :: Int , instructions :: [Instruction] + , end :: Maybe Label } deriving (Show, Eq) +data Frame = Frame + { locals :: [LocalVariable] + , stack :: [StackEntry] + } + deriving (Show, Eq) + +data LocalVariable = Uninitialised | LocalVariable FieldType + deriving (Show, Eq) + +data StackEntry = StackEntry FieldType | StackEntryTop | StackEntryNull + deriving (Show, Eq) + +lvToStackEntry :: LocalVariable -> StackEntry +lvToStackEntry Uninitialised = StackEntryTop +lvToStackEntry (LocalVariable ft) = StackEntry ft + +stackEntryToLV :: StackEntry -> LocalVariable +stackEntryToLV StackEntryTop = Uninitialised +stackEntryToLV StackEntryNull = Uninitialised +stackEntryToLV (StackEntry ft) = LocalVariable ft + splitIntoBasicBlocks :: [Instruction] -> [BasicBlock] splitIntoBasicBlocks [] = [] splitIntoBasicBlocks l = - let blocks = splitWhen (is (_As @"Label")) l - in zipWith BasicBlock [0 ..] blocks + let blockToInstAndLabel = splitOnLabels l + in zipWith (\i (l, b) -> BasicBlock i b l) [0 ..] blockToInstAndLabel + +splitOnLabels :: [Instruction] -> [(Maybe Label, [Instruction])] +splitOnLabels xs = go xs [] + where + go :: [Instruction] -> ([Instruction]) -> [(Maybe Label, [Instruction])] + go [] acc = [(Nothing, acc)] + go (x : xs) acc = case x ^? _As @"Label" of + Just l' -> (Just l', acc) : go xs [] + Nothing -> go xs (acc <> [x]) + +topFrame :: MethodDescriptor -> Frame +topFrame (MethodDescriptor args _) = Frame (map LocalVariable args) [] + +analyseBlockDiff :: Frame -> BasicBlock -> Frame +analyseBlockDiff current block = do + foldl (flip analyseInstruction) current (takeWhileInclusive (not . isConditionalJump) block.instructions) + where + isConditionalJump :: Instruction -> Bool + isConditionalJump (IfEq _) = True + isConditionalJump (IfNe _) = True + isConditionalJump (IfLt _) = True + isConditionalJump (IfGe _) = True + isConditionalJump (IfGt _) = True + isConditionalJump (IfLe _) = True + isConditionalJump _ = False + + analyseInstruction :: Instruction -> Frame -> Frame + analyseInstruction (Label _) ba = error "Label should not be encountered in analyseInstruction" + analyseInstruction (ALoad i) ba = ba{stack = lvToStackEntry (ba.locals !! fromIntegral (i - 1)) : ba.stack} + analyseInstruction (ILoad i) ba = ba{stack = lvToStackEntry (ba.locals !! fromIntegral (i - 1)) : ba.stack} + analyseInstruction (AStore i) ba = ba{locals = replaceAtOrGrow (fromIntegral (i - 1)) (stackEntryToLV $ head ba.stack) ba.locals, stack = tail ba.stack} + analyseInstruction (IStore i) ba = ba{locals = replaceAtOrGrow (fromIntegral (i - 1)) (stackEntryToLV $ head ba.stack) ba.locals, stack = tail ba.stack} + analyseInstruction AReturn ba = ba{stack = tail ba.stack} + analyseInstruction Return ba = ba + analyseInstruction (LDC (LDCInt _)) ba = ba{stack = StackEntry (PrimitiveFieldType Int) : ba.stack} + analyseInstruction AConstNull ba = ba{stack = StackEntryNull : ba.stack} + analyseInstruction Dup ba = ba{stack = head ba.stack : ba.stack} + analyseInstruction (IfEq _) ba = ba{stack = tail ba.stack} + analyseInstruction (IfNe _) ba = ba{stack = tail ba.stack} + analyseInstruction (IfLt _) ba = ba{stack = tail ba.stack} + analyseInstruction (IfGe _) ba = ba{stack = tail ba.stack} + analyseInstruction (IfGt _) ba = ba{stack = tail ba.stack} + analyseInstruction (IfLe _) ba = ba{stack = tail ba.stack} + analyseInstruction other ba = error $ "Instruction not supported: " <> show other + +frameDiffToSMF :: Frame -> BasicBlock -> StackMapFrame +frameDiffToSMF f1@(Frame locals1 stack1) bb = do + let f2@(Frame locals2 stack2) = analyseBlockDiff f1 bb + if + | locals1 == locals2 && stack1 == stack2 -> SameFrame (fromJust bb.end) + | stack1 == stack2 && locals1 `isPrefixOf` locals2 -> AppendFrame (map lvToVerificationTypeInfo (drop (length locals1) locals2)) (fromJust bb.end) + | otherwise -> error (show f1 <> show f2) + +lvToVerificationTypeInfo :: LocalVariable -> VerificationTypeInfo +lvToVerificationTypeInfo Uninitialised = TopVariableInfo +lvToVerificationTypeInfo (LocalVariable ft) = case ft of + PrimitiveFieldType Int -> IntegerVariableInfo + PrimitiveFieldType Float -> FloatVariableInfo + PrimitiveFieldType Long -> LongVariableInfo + PrimitiveFieldType Double -> DoubleVariableInfo + _ -> ObjectVariableInfo (fieldTypeToClassInfoType ft) + +replaceAtOrGrow :: Int -> LocalVariable -> [LocalVariable] -> [LocalVariable] +replaceAtOrGrow i x xs + | i < length xs = replaceAt i x xs + | otherwise = xs <> replicate (i - length xs) Uninitialised <> [x] + +replaceAt :: Int -> a -> [a] -> [a] +replaceAt i x xs = take i xs <> [x] <> drop (i + 1) xs + +takeWhileInclusive :: (a -> Bool) -> [a] -> [a] +takeWhileInclusive _ [] = [] +takeWhileInclusive p (x : xs) + | p x = x : takeWhileInclusive p xs + | otherwise = [x] \ No newline at end of file diff --git a/test/Analyse.hs b/test/Analyse.hs index 26ab455..c74163c 100644 --- a/test/Analyse.hs +++ b/test/Analyse.hs @@ -10,8 +10,10 @@ import JVM.Data.Abstract.Name import JVM.Data.Abstract.Type import JVM.Data.Abstract.Builder.Code +import JVM.Data.Abstract.ClassFile.Method ( StackMapFrame (..), VerificationTypeInfo (..)) +import JVM.Data.Abstract.Descriptor import JVM.Data.Abstract.Instruction -import JVM.Data.Analyse.StackMap (BasicBlock (BasicBlock), splitIntoBasicBlocks) +import JVM.Data.Analyse.StackMap (BasicBlock (BasicBlock), Frame (..), LocalVariable (..), analyseBlockDiff, frameDiffToSMF, splitIntoBasicBlocks, topFrame) import Test.Hspec import Test.Hspec.Hedgehog @@ -47,26 +49,86 @@ genFieldType = spec :: Spec spec = describe "Analysis checks" $ do describe "Does StackDiff concatenation correctly" $ do - it "Can identify basic blocks properly" $ do + it "Can identify sameframe blocks properly" $ do let (l, _, code) = runCodeBuilder' $ do label <- newLabel + emit $ LDC (LDCInt 0) -- [0] + emit $ IfEq label emit $ LDC (LDCInt 0) - emit $ IStore 1 - emit $ LDC (LDCInt 0) - emit $ IStore 2 - emit $ ILoad 1 - emit $ IfLe label - emit $ LDC (LDCInt 0) - emit $ IStore 3 + emit AReturn emit $ Label label - emit $ LDC (LDCInt 0) - emit $ IStore 3 - emit Return + emit $ LDC (LDCInt 1) + emit AReturn + pure label hedgehog $ do - let x = splitIntoBasicBlocks code + let blocks = splitIntoBasicBlocks code - x - === [ BasicBlock 0 [LDC (LDCInt 0), IStore 1, LDC (LDCInt 0), IStore 2, ILoad 1, IfLe l, LDC (LDCInt 0), IStore 3] - , BasicBlock 1 [LDC (LDCInt 0), IStore 3, Return] + blocks + === [ BasicBlock 0 [LDC (LDCInt 0), IfEq l, LDC (LDCInt 0), AReturn] (Just l) + , BasicBlock 1 [LDC (LDCInt 1), AReturn] Nothing ] + + let top = topFrame (MethodDescriptor [] (TypeReturn (PrimitiveFieldType Int))) + let nextFrame = analyseBlockDiff top (head blocks) + + nextFrame + === Frame + { locals = [] + , stack = [] + } + + let nextFrame' = analyseBlockDiff nextFrame (blocks !! 1) + + nextFrame' + === Frame + { locals = [] + , stack = [] + } + + frameDiffToSMF top (head blocks) + === SameFrame l + + it "Can identify append frame blocks properly" $ do + let (l, _, code) = runCodeBuilder' $ do + label <- newLabel + emit $ LDC (LDCInt 0) -- [0] + emit $ IStore 1 -- [] + emit $ LDC (LDCInt 0) -- [0] + emit $ IStore 2 -- [] + emit $ ILoad 1 -- [0] + emit $ IfLe label -- [] + emit $ LDC (LDCInt 0) -- [0] + emit $ IStore 3 -- [] + emit $ Label label -- [] + emit $ LDC (LDCInt 0) -- [0] + emit $ IStore 3 -- [] + emit Return -- [] + pure label + hedgehog $ do + let blocks = splitIntoBasicBlocks code + + blocks + === [ BasicBlock 0 [LDC (LDCInt 0), IStore 1, LDC (LDCInt 0), IStore 2, ILoad 1, IfLe l, LDC (LDCInt 0), IStore 3] (Just l) + , BasicBlock 1 [LDC (LDCInt 0), IStore 3, Return] Nothing + ] + + let top = topFrame (MethodDescriptor [] VoidReturn) + let nextFrame = analyseBlockDiff top (head blocks) + + nextFrame + === Frame + { locals = [LocalVariable (PrimitiveFieldType Int), LocalVariable (PrimitiveFieldType Int)] + , stack = [] + } + + let nextFrame' = analyseBlockDiff nextFrame (blocks !! 1) + + nextFrame' + === Frame + { locals = [LocalVariable (PrimitiveFieldType Int), LocalVariable (PrimitiveFieldType Int), LocalVariable (PrimitiveFieldType Int)] + , stack = [] + } + + frameDiffToSMF top (head blocks) + === AppendFrame [IntegerVariableInfo, IntegerVariableInfo] l \ No newline at end of file diff --git a/test/Builder.hs b/test/Builder.hs index e851e95..bc55a56 100644 --- a/test/Builder.hs +++ b/test/Builder.hs @@ -32,3 +32,5 @@ spec = describe "test code building" $ do , Raw.IfEq 3 , Raw.Return ] + + From 7190889924a690df010768c6cdaa7710ee36949e Mon Sep 17 00:00:00 2001 From: Alexander Wood Date: Tue, 5 Dec 2023 20:17:07 +0000 Subject: [PATCH 06/23] re-add API --- src/JVM/Data/Analyse/StackMap.hs | 15 +++++++++++---- test/Analyse.hs | 3 ++- 2 files changed, 13 insertions(+), 5 deletions(-) diff --git a/src/JVM/Data/Analyse/StackMap.hs b/src/JVM/Data/Analyse/StackMap.hs index 56d8e0b..1589910 100644 --- a/src/JVM/Data/Analyse/StackMap.hs +++ b/src/JVM/Data/Analyse/StackMap.hs @@ -7,17 +7,16 @@ modifications to the code after this point will invalidate the stack map table a -} module JVM.Data.Analyse.StackMap where -import Control.Lens ((^.), (^?), _Just) -import Control.Lens.Extras (is) import Control.Lens.Fold import Data.Generics.Sum (AsAny (_As)) import Data.List import Data.Maybe (fromJust) +import GHC.Stack (HasCallStack) import JVM.Data.Abstract.Builder.Label import JVM.Data.Abstract.ClassFile.Method import JVM.Data.Abstract.Descriptor (MethodDescriptor (MethodDescriptor)) import JVM.Data.Abstract.Instruction -import JVM.Data.Abstract.Type (ClassInfoType (..), FieldType (..), PrimitiveType (..), fieldTypeToClassInfoType) +import JVM.Data.Abstract.Type (FieldType (..), PrimitiveType (..), fieldTypeToClassInfoType) data BasicBlock = BasicBlock { index :: Int @@ -97,7 +96,7 @@ analyseBlockDiff current block = do analyseInstruction (IfLe _) ba = ba{stack = tail ba.stack} analyseInstruction other ba = error $ "Instruction not supported: " <> show other -frameDiffToSMF :: Frame -> BasicBlock -> StackMapFrame +frameDiffToSMF :: HasCallStack => Frame -> BasicBlock -> StackMapFrame frameDiffToSMF f1@(Frame locals1 stack1) bb = do let f2@(Frame locals2 stack2) = analyseBlockDiff f1 bb if @@ -114,6 +113,14 @@ lvToVerificationTypeInfo (LocalVariable ft) = case ft of PrimitiveFieldType Double -> DoubleVariableInfo _ -> ObjectVariableInfo (fieldTypeToClassInfoType ft) +calculateStackMapFrames :: MethodDescriptor -> [Instruction] -> [StackMapFrame] +calculateStackMapFrames md code = do + let blocks = splitIntoBasicBlocks code + let top = topFrame md + let frames = scanl analyseBlockDiff top blocks + + zipWith frameDiffToSMF frames (init blocks) + replaceAtOrGrow :: Int -> LocalVariable -> [LocalVariable] -> [LocalVariable] replaceAtOrGrow i x xs | i < length xs = replaceAt i x xs diff --git a/test/Analyse.hs b/test/Analyse.hs index c74163c..f148e9f 100644 --- a/test/Analyse.hs +++ b/test/Analyse.hs @@ -13,7 +13,7 @@ import JVM.Data.Abstract.Builder.Code import JVM.Data.Abstract.ClassFile.Method ( StackMapFrame (..), VerificationTypeInfo (..)) import JVM.Data.Abstract.Descriptor import JVM.Data.Abstract.Instruction -import JVM.Data.Analyse.StackMap (BasicBlock (BasicBlock), Frame (..), LocalVariable (..), analyseBlockDiff, frameDiffToSMF, splitIntoBasicBlocks, topFrame) +import JVM.Data.Analyse.StackMap (BasicBlock (BasicBlock), Frame (..), LocalVariable (..), analyseBlockDiff, frameDiffToSMF, splitIntoBasicBlocks, topFrame, calculateStackMapFrames) import Test.Hspec import Test.Hspec.Hedgehog @@ -62,6 +62,7 @@ spec = describe "Analysis checks" $ do pure label hedgehog $ do + let blocks = splitIntoBasicBlocks code blocks From e560a8aad60af9e532180c3d4a731429bc236e14 Mon Sep 17 00:00:00 2001 From: Alexander Wood Date: Tue, 5 Dec 2023 20:51:07 +0000 Subject: [PATCH 07/23] format & update fourmolu --- flake.nix | 7 ++++++- src/JVM/Data/Analyse/StackMap.hs | 2 +- test/Analyse.hs | 7 +++---- test/Builder.hs | 2 -- 4 files changed, 10 insertions(+), 8 deletions(-) diff --git a/flake.nix b/flake.nix index 959e4df..0c3bbfc 100644 --- a/flake.nix +++ b/flake.nix @@ -38,12 +38,17 @@ hlsCheck.enable = false; }; + packages = { + fourmolu.source = "0.11.0.0"; + + }; + settings = { ghcid = { separateBinOutput = false; check = false; }; - + fourmolu.check = false; }; }; diff --git a/src/JVM/Data/Analyse/StackMap.hs b/src/JVM/Data/Analyse/StackMap.hs index 1589910..ca55c73 100644 --- a/src/JVM/Data/Analyse/StackMap.hs +++ b/src/JVM/Data/Analyse/StackMap.hs @@ -133,4 +133,4 @@ takeWhileInclusive :: (a -> Bool) -> [a] -> [a] takeWhileInclusive _ [] = [] takeWhileInclusive p (x : xs) | p x = x : takeWhileInclusive p xs - | otherwise = [x] \ No newline at end of file + | otherwise = [x] diff --git a/test/Analyse.hs b/test/Analyse.hs index f148e9f..69e6fa9 100644 --- a/test/Analyse.hs +++ b/test/Analyse.hs @@ -10,10 +10,10 @@ import JVM.Data.Abstract.Name import JVM.Data.Abstract.Type import JVM.Data.Abstract.Builder.Code -import JVM.Data.Abstract.ClassFile.Method ( StackMapFrame (..), VerificationTypeInfo (..)) +import JVM.Data.Abstract.ClassFile.Method (StackMapFrame (..), VerificationTypeInfo (..)) import JVM.Data.Abstract.Descriptor import JVM.Data.Abstract.Instruction -import JVM.Data.Analyse.StackMap (BasicBlock (BasicBlock), Frame (..), LocalVariable (..), analyseBlockDiff, frameDiffToSMF, splitIntoBasicBlocks, topFrame, calculateStackMapFrames) +import JVM.Data.Analyse.StackMap (BasicBlock (BasicBlock), Frame (..), LocalVariable (..), analyseBlockDiff, calculateStackMapFrames, frameDiffToSMF, splitIntoBasicBlocks, topFrame) import Test.Hspec import Test.Hspec.Hedgehog @@ -62,7 +62,6 @@ spec = describe "Analysis checks" $ do pure label hedgehog $ do - let blocks = splitIntoBasicBlocks code blocks @@ -132,4 +131,4 @@ spec = describe "Analysis checks" $ do } frameDiffToSMF top (head blocks) - === AppendFrame [IntegerVariableInfo, IntegerVariableInfo] l \ No newline at end of file + === AppendFrame [IntegerVariableInfo, IntegerVariableInfo] l diff --git a/test/Builder.hs b/test/Builder.hs index bc55a56..e851e95 100644 --- a/test/Builder.hs +++ b/test/Builder.hs @@ -32,5 +32,3 @@ spec = describe "test code building" $ do , Raw.IfEq 3 , Raw.Return ] - - From b26122624fec43cbd25a8c894cb30690e5ecd456 Mon Sep 17 00:00:00 2001 From: Alexander Wood Date: Tue, 5 Dec 2023 20:53:07 +0000 Subject: [PATCH 08/23] we are so back --- src/JVM/Data/Abstract/ClassFile/Method.hs | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/src/JVM/Data/Abstract/ClassFile/Method.hs b/src/JVM/Data/Abstract/ClassFile/Method.hs index 789331e..54b4b22 100644 --- a/src/JVM/Data/Abstract/ClassFile/Method.hs +++ b/src/JVM/Data/Abstract/ClassFile/Method.hs @@ -5,12 +5,12 @@ import JVM.Data.Abstract.ClassFile.AccessFlags (MethodAccessFlag) import JVM.Data.Abstract.Descriptor (MethodDescriptor) import Data.Data -import Data.TypeMergingList (DataMergeable (merge), errorDifferentConstructors, TypeMergingList) +import Data.TypeMergingList (DataMergeable (merge), TypeMergingList, errorDifferentConstructors) +import GHC.Generics (Generic) import JVM.Data.Abstract.Builder.Label import JVM.Data.Abstract.Instruction import JVM.Data.Abstract.Type (ClassInfoType) -import JVM.Data.Raw.Types (U2, U1) -import GHC.Generics (Generic) +import JVM.Data.Raw.Types (U1, U2) data ClassFileMethod = ClassFileMethod { methodAccessFlags :: [MethodAccessFlag] @@ -54,14 +54,17 @@ instance DataMergeable CodeAttribute where data StackMapFrame = SameFrame Label | ChopFrame - !U1 -- | How many locals to chop - !Label -- | The label of the next instruction + !U1 + -- ^ How many locals to chop + !Label + -- ^ The label of the next instruction | SameLocals1StackItemFrame !VerificationTypeInfo Label | AppendFrame ![VerificationTypeInfo] !Label | FullFrame ![VerificationTypeInfo] ![VerificationTypeInfo] !Label deriving (Show, Data, Eq) -data VerificationTypeInfo = TopVariableInfo +data VerificationTypeInfo + = TopVariableInfo | IntegerVariableInfo | FloatVariableInfo | LongVariableInfo From 05294ea043265fc9a4db0b289781b99bd66c38b5 Mon Sep 17 00:00:00 2001 From: Alexander Wood Date: Tue, 5 Dec 2023 21:01:03 +0000 Subject: [PATCH 09/23] derive a bunch of stuff --- flake.lock | 42 +++++++++++------------ flake.nix | 3 +- src/Data/IndexedMap.hs | 2 +- src/Data/TypeMergingList.hs | 6 ++-- src/JVM/Data/Abstract/Builder.hs | 24 ++++++------- src/JVM/Data/Abstract/Builder/Code.hs | 14 ++++---- src/JVM/Data/Abstract/ClassFile/Method.hs | 12 +++---- src/JVM/Data/Abstract/ConstantPool.hs | 17 ++++----- src/JVM/Data/Abstract/Instruction.hs | 5 +-- src/JVM/Data/Analyse/StackMap.hs | 8 ++--- src/JVM/Data/Convert/AccessFlag.hs | 2 +- src/JVM/Data/Convert/ConstantPool.hs | 20 +++++------ src/JVM/Data/Convert/Method.hs | 6 ++-- src/JVM/Data/Pretty.hs | 2 +- test/Convert.hs | 2 +- test/Util.hs | 4 +-- 16 files changed, 85 insertions(+), 84 deletions(-) diff --git a/flake.lock b/flake.lock index 17286c0..515a8f9 100644 --- a/flake.lock +++ b/flake.lock @@ -5,11 +5,11 @@ "nixpkgs-lib": "nixpkgs-lib" }, "locked": { - "lastModified": 1685662779, - "narHash": "sha256-cKDDciXGpMEjP1n6HlzKinN0H+oLmNpgeCTzYnsA2po=", + "lastModified": 1701473968, + "narHash": "sha256-YcVE5emp1qQ8ieHUnxt1wCZCC3ZfAS+SRRWZ2TMda7E=", "owner": "hercules-ci", "repo": "flake-parts", - "rev": "71fb97f0d875fd4de4994dfb849f2c75e17eb6c3", + "rev": "34fed993f1674c8d06d58b37ce1e0fe5eebcb9f5", "type": "github" }, "original": { @@ -20,11 +20,11 @@ }, "flake-root": { "locked": { - "lastModified": 1680964220, - "narHash": "sha256-dIdTYcf+KW9a4pKHsEbddvLVSfR1yiAJynzg2x0nfWg=", + "lastModified": 1692742795, + "narHash": "sha256-f+Y0YhVCIJ06LemO+3Xx00lIcqQxSKJHXT/yk1RTKxw=", "owner": "srid", "repo": "flake-root", - "rev": "f1c0b93d05bdbea6c011136ba1a135c80c5b326c", + "rev": "d9a70d9c7a5fd7f3258ccf48da9335e9b47c3937", "type": "github" }, "original": { @@ -35,11 +35,11 @@ }, "haskell-flake": { "locked": { - "lastModified": 1685727978, - "narHash": "sha256-kSDetNgDoaIFO11vAyJXaO9Eh3iGhpZbve6AKib7ctw=", + "lastModified": 1701214938, + "narHash": "sha256-25PiqJK6iSX0CPZghcUCGCEvU9uMSNbCJ772NComipY=", "owner": "srid", "repo": "haskell-flake", - "rev": "1f0a5ee4f69b0740ad6eb93cd0b4fb4265f7f6b6", + "rev": "abea026d35df050c27163f5193f96ef3a8b4ea6a", "type": "github" }, "original": { @@ -50,11 +50,11 @@ }, "mission-control": { "locked": { - "lastModified": 1683658484, - "narHash": "sha256-JkGnWyYZxOnyOhztrxLSqaod6+O/3rRypq0dAqA/zn0=", + "lastModified": 1701205489, + "narHash": "sha256-xqggNXBHyYHx6miXw7Aefre6MNCwzuDg2Mz0BOY1D9o=", "owner": "Platonic-Systems", "repo": "mission-control", - "rev": "a0c93bd764a3c25e6999397e9f5f119c1b124e38", + "rev": "f9582470f8e9b97a665cde84d42d6c4c0fbef03a", "type": "github" }, "original": { @@ -65,11 +65,11 @@ }, "nixpkgs": { "locked": { - "lastModified": 1685677062, - "narHash": "sha256-zoHF7+HNwNwne2XEomphbdc4Y8tdWT16EUxUTXpOKpQ=", + "lastModified": 1701626906, + "narHash": "sha256-ugr1QyzzwNk505ICE4VMQzonHQ9QS5W33xF2FXzFQ00=", "owner": "nixos", "repo": "nixpkgs", - "rev": "95be94370d09f97f6af6a1df1eb9649b5260724e", + "rev": "0c6d8c783336a59f4c59d4a6daed6ab269c4b361", "type": "github" }, "original": { @@ -82,11 +82,11 @@ "nixpkgs-lib": { "locked": { "dir": "lib", - "lastModified": 1685564631, - "narHash": "sha256-8ywr3AkblY4++3lIVxmrWZFzac7+f32ZEhH/A8pNscI=", + "lastModified": 1701253981, + "narHash": "sha256-ztaDIyZ7HrTAfEEUt9AtTDNoCYxUdSd6NrRHaYOIxtk=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "4f53efe34b3a8877ac923b9350c874e3dcd5dc0a", + "rev": "e92039b55bcd58469325ded85d4f58dd5a4eaf58", "type": "github" }, "original": { @@ -130,11 +130,11 @@ ] }, "locked": { - "lastModified": 1685519364, - "narHash": "sha256-rE9c9jWDSc5Nj0OjNzBENaJ6j4YBphcqSPia2IwCMLA=", + "lastModified": 1701682826, + "narHash": "sha256-2lxeTUGs8Jzz/wjLgWYmZoXn60BYNRMzwHFtxNFUDLU=", "owner": "numtide", "repo": "treefmt-nix", - "rev": "6521a278bcba66b440554cc1350403594367b4ac", + "rev": "affe7fc3f5790e1d0b5ba51bcff0f7ebe465e92d", "type": "github" }, "original": { diff --git a/flake.nix b/flake.nix index 0c3bbfc..3dee028 100644 --- a/flake.nix +++ b/flake.nix @@ -39,8 +39,7 @@ }; packages = { - fourmolu.source = "0.11.0.0"; - + # fourmolu.source = "0.11.0.0"; }; settings = { diff --git a/src/Data/IndexedMap.hs b/src/Data/IndexedMap.hs index 5e89be8..d30e4c8 100644 --- a/src/Data/IndexedMap.hs +++ b/src/Data/IndexedMap.hs @@ -117,7 +117,7 @@ instance (Ord a) => Ord (IndexedMap a) where instance Foldable IndexedMap where foldMap f (IndexedMap im _) = foldMap f im -instance Ord a => IsList (IndexedMap a) where +instance (Ord a) => IsList (IndexedMap a) where type Item (IndexedMap a) = a fromList = foldr (\a b -> snd $ insert a b) empty toList = toList . toVector diff --git a/src/Data/TypeMergingList.hs b/src/Data/TypeMergingList.hs index ef97348..1dc0f96 100644 --- a/src/Data/TypeMergingList.hs +++ b/src/Data/TypeMergingList.hs @@ -34,10 +34,10 @@ newtype TypeMergingList a = TypeMergingList [a] Instances of this class may assume that the constructors of the two arguments are the same (i.e. @toConstr x == toConstr y@), and are permitted to be partial if this is not the case. -} -class Data a => DataMergeable a where +class (Data a) => DataMergeable a where merge :: a -> a -> a -errorDifferentConstructors :: Data a => a -> a -> b +errorDifferentConstructors :: (Data a) => a -> a -> b errorDifferentConstructors x y = error $ "Cannot merge values as they have different data constructors: " <> showConstr (toConstr x) <> " and " <> showConstr (toConstr y) instance {-# OVERLAPPABLE #-} (Data a, Semigroup a) => DataMergeable a where @@ -64,7 +64,7 @@ append (TypeMergingList xs) (TypeMergingList ys) = TypeMergingList (go xs ys) | toConstr x == toConstr y = (x `merge` y) : go xs' ys' | otherwise = y : go (x : xs') ys' -fromList :: DataMergeable a => Data a => [a] -> TypeMergingList a +fromList :: (DataMergeable a) => (Data a) => [a] -> TypeMergingList a fromList = foldl' snoc (TypeMergingList []) toList :: TypeMergingList a -> [a] diff --git a/src/JVM/Data/Abstract/Builder.hs b/src/JVM/Data/Abstract/Builder.hs index 46095a0..41b7d0b 100644 --- a/src/JVM/Data/Abstract/Builder.hs +++ b/src/JVM/Data/Abstract/Builder.hs @@ -23,37 +23,37 @@ unClassBuilderT (ClassBuilderT m) = m type ClassBuilder = ClassBuilderT Identity -addAccessFlag :: Monad m => ClassAccessFlag -> ClassBuilderT m () +addAccessFlag :: (Monad m) => ClassAccessFlag -> ClassBuilderT m () addAccessFlag flag = modify (\c -> c{accessFlags = flag : c.accessFlags}) -setName :: Monad m => QualifiedClassName -> ClassBuilderT m () +setName :: (Monad m) => QualifiedClassName -> ClassBuilderT m () setName n = modify (\c -> c{name = n}) -setVersion :: Monad m => JVMVersion -> ClassBuilderT m () +setVersion :: (Monad m) => JVMVersion -> ClassBuilderT m () setVersion v = modify (\c -> c{version = v}) -setSuperClass :: Monad m => QualifiedClassName -> ClassBuilderT m () +setSuperClass :: (Monad m) => QualifiedClassName -> ClassBuilderT m () setSuperClass s = modify (\c -> c{superClass = Just s}) -addInterface :: Monad m => QualifiedClassName -> ClassBuilderT m () +addInterface :: (Monad m) => QualifiedClassName -> ClassBuilderT m () addInterface i = modify (\c -> c{interfaces = i : c.interfaces}) -addField :: Monad m => ClassFileField -> ClassBuilderT m () +addField :: (Monad m) => ClassFileField -> ClassBuilderT m () addField f = modify (\c -> c{fields = f : c.fields}) -buildAndAddField :: Monad m => ClassBuilderT m ClassFileField -> ClassBuilderT m () +buildAndAddField :: (Monad m) => ClassBuilderT m ClassFileField -> ClassBuilderT m () buildAndAddField f = f >>= addField -addMethod :: Monad m => ClassFileMethod -> ClassBuilderT m () +addMethod :: (Monad m) => ClassFileMethod -> ClassBuilderT m () addMethod m = modify (\c -> c{methods = m : c.methods}) -buildAndAddMethod :: Monad m => ClassBuilderT m ClassFileMethod -> ClassBuilderT m () +buildAndAddMethod :: (Monad m) => ClassBuilderT m ClassFileMethod -> ClassBuilderT m () buildAndAddMethod m = m >>= addMethod -addAttribute :: Monad m => ClassFileAttribute -> ClassBuilderT m () +addAttribute :: (Monad m) => ClassFileAttribute -> ClassBuilderT m () addAttribute a = modify (\c -> c{attributes = c.attributes `TML.snoc` a}) -addBootstrapMethod :: Monad m => BootstrapMethod -> ClassBuilderT m () +addBootstrapMethod :: (Monad m) => BootstrapMethod -> ClassBuilderT m () addBootstrapMethod b = addAttribute (BootstrapMethods [b]) dummyClass :: QualifiedClassName -> JVMVersion -> ClassFile @@ -69,7 +69,7 @@ dummyClass name version = , attributes = mempty } -runClassBuilderT :: Monad m => QualifiedClassName -> JVMVersion -> ClassBuilderT m a -> m (a, ClassFile) +runClassBuilderT :: (Monad m) => QualifiedClassName -> JVMVersion -> ClassBuilderT m a -> m (a, ClassFile) runClassBuilderT n v m = runStateT (unClassBuilderT m) (dummyClass n v) diff --git a/src/JVM/Data/Abstract/Builder/Code.hs b/src/JVM/Data/Abstract/Builder/Code.hs index 696d993..869021d 100644 --- a/src/JVM/Data/Abstract/Builder/Code.hs +++ b/src/JVM/Data/Abstract/Builder/Code.hs @@ -37,23 +37,23 @@ newLabel = do put (s{labelSource = ls'}) pure l -emit :: Monad m => Instruction -> CodeBuilderT m () +emit :: (Monad m) => Instruction -> CodeBuilderT m () emit i = emit' [i] -emit' :: Monad m => [Instruction] -> CodeBuilderT m () +emit' :: (Monad m) => [Instruction] -> CodeBuilderT m () emit' is = do modify (\s -> s{code = reverse is <> s.code}) -addCodeAttribute :: Monad m => CodeAttribute -> CodeBuilderT m () +addCodeAttribute :: (Monad m) => CodeAttribute -> CodeBuilderT m () addCodeAttribute ca = do s@CodeState{attributes = attrs} <- get put (s{attributes = attrs `TML.snoc` ca}) pure () -appendStackMapFrame :: Monad m => StackMapFrame -> CodeBuilderT m () +appendStackMapFrame :: (Monad m) => StackMapFrame -> CodeBuilderT m () appendStackMapFrame f = addCodeAttribute (StackMapTable [f]) -getCode :: Monad m => CodeBuilderT m [Instruction] +getCode :: (Monad m) => CodeBuilderT m [Instruction] getCode = gets (.code) rr :: (a, CodeState) -> (a, [CodeAttribute], [Instruction]) @@ -68,11 +68,11 @@ rr (a, s) = runCodeBuilder :: CodeBuilder a -> ([CodeAttribute], [Instruction]) runCodeBuilder = (\(_, b, c) -> (b, c)) . runCodeBuilder' -runCodeBuilderT :: Monad m => CodeBuilderT m a -> m (a, [CodeAttribute], [Instruction]) +runCodeBuilderT :: (Monad m) => CodeBuilderT m a -> m (a, [CodeAttribute], [Instruction]) runCodeBuilderT = fmap rr . flip runStateT initialCodeState . unCodeBuilderT runCodeBuilder' :: CodeBuilder a -> (a, [CodeAttribute], [Instruction]) runCodeBuilder' = rr . runIdentity . flip runStateT initialCodeState . unCodeBuilderT -runCodeBuilderT' :: Monad m => CodeBuilderT m a -> m (a, [CodeAttribute], [Instruction]) +runCodeBuilderT' :: (Monad m) => CodeBuilderT m a -> m (a, [CodeAttribute], [Instruction]) runCodeBuilderT' = fmap rr . flip runStateT initialCodeState . unCodeBuilderT diff --git a/src/JVM/Data/Abstract/ClassFile/Method.hs b/src/JVM/Data/Abstract/ClassFile/Method.hs index 54b4b22..81535f0 100644 --- a/src/JVM/Data/Abstract/ClassFile/Method.hs +++ b/src/JVM/Data/Abstract/ClassFile/Method.hs @@ -22,7 +22,7 @@ data ClassFileMethod = ClassFileMethod data MethodAttribute = Code !CodeAttributeData - deriving (Show, Generic) + deriving (Show, Generic, Data) data CodeAttributeData = CodeAttributeData { maxStack :: U2 @@ -31,7 +31,7 @@ data CodeAttributeData = CodeAttributeData , exceptionTable :: [ExceptionTableEntry] , codeAttributes :: [CodeAttribute] } - deriving (Show) + deriving (Show, Data, Generic) data ExceptionTableEntry = ExceptionTableEntry { startPc :: Int @@ -39,12 +39,12 @@ data ExceptionTableEntry = ExceptionTableEntry , handlerPc :: Int , catchType :: Maybe ClassInfoType } - deriving (Show) + deriving (Show, Data, Generic) data CodeAttribute = LineNumberTable [LineNumberTableEntry] | StackMapTable [StackMapFrame] - deriving (Show, Eq, Data) + deriving (Show, Eq, Data, Generic) instance DataMergeable CodeAttribute where merge (LineNumberTable a) (LineNumberTable b) = LineNumberTable (a <> b) @@ -54,10 +54,10 @@ instance DataMergeable CodeAttribute where data StackMapFrame = SameFrame Label | ChopFrame + -- | How many locals to chop !U1 - -- ^ How many locals to chop + -- | The label of the next instruction !Label - -- ^ The label of the next instruction | SameLocals1StackItemFrame !VerificationTypeInfo Label | AppendFrame ![VerificationTypeInfo] !Label | FullFrame ![VerificationTypeInfo] ![VerificationTypeInfo] !Label diff --git a/src/JVM/Data/Abstract/ConstantPool.hs b/src/JVM/Data/Abstract/ConstantPool.hs index 4f6b6f8..ac121f6 100644 --- a/src/JVM/Data/Abstract/ConstantPool.hs +++ b/src/JVM/Data/Abstract/ConstantPool.hs @@ -19,8 +19,9 @@ import JVM.Data.Pretty -} data ConstantPoolEntry = -- | A class reference - CPClassEntry ClassInfoType - -- ^ The class being referenced + CPClassEntry + -- | The class being referenced + ClassInfoType | CPFieldRefEntry FieldRef | CPMethodRefEntry MethodRef | CPInterfaceMethodRefEntry MethodRef @@ -35,12 +36,12 @@ data ConstantPoolEntry | CPMethodTypeEntry MethodDescriptor | -- | CONSTANT_InvokeDynamic_info CPInvokeDynamicEntry + -- | bootstrap_method_attr(_index) BootstrapMethod - -- ^ bootstrap_method_attr(_index) + -- | name(_and_type_index) Text - -- ^ name(_and_type_index) + -- | (name_and_)type(_index) MethodDescriptor - -- ^ (name_and_)type(_index) deriving (Show, Eq, Ord) data FieldRef = FieldRef ClassInfoType Text FieldType @@ -51,12 +52,12 @@ instance Pretty FieldRef where data MethodRef = MethodRef + -- | The class containing the method ClassInfoType - -- ^ The class containing the method + -- | The name of the method Text - -- ^ The name of the method + -- | The descriptor of the method MethodDescriptor - -- ^ The descriptor of the method deriving (Show, Eq, Ord, Data) instance Pretty MethodRef where diff --git a/src/JVM/Data/Abstract/Instruction.hs b/src/JVM/Data/Abstract/Instruction.hs index bc0521c..0cc412b 100644 --- a/src/JVM/Data/Abstract/Instruction.hs +++ b/src/JVM/Data/Abstract/Instruction.hs @@ -14,6 +14,7 @@ import JVM.Data.Abstract.Descriptor import JVM.Data.Abstract.Type import JVM.Data.Pretty import JVM.Data.Raw.Types +import Data.Data (Data) type Reference = Int @@ -44,7 +45,7 @@ data Instruction' label | Goto label | CheckCast ClassInfoType | Return - deriving (Show, Eq, Ord, Functor, Generic) + deriving (Show, Eq, Ord, Functor, Generic, Data) instance (Pretty label) => Pretty (Instruction' label) where pretty (ALoad x) = "aload" <+> pretty x @@ -88,7 +89,7 @@ data LDCEntry | LDCFloat Float | LDCString Text | LDCClass ClassInfoType - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, Data, Generic) instance Pretty LDCEntry where pretty (LDCInt x) = pretty x diff --git a/src/JVM/Data/Analyse/StackMap.hs b/src/JVM/Data/Analyse/StackMap.hs index ca55c73..ecf2b46 100644 --- a/src/JVM/Data/Analyse/StackMap.hs +++ b/src/JVM/Data/Analyse/StackMap.hs @@ -96,13 +96,13 @@ analyseBlockDiff current block = do analyseInstruction (IfLe _) ba = ba{stack = tail ba.stack} analyseInstruction other ba = error $ "Instruction not supported: " <> show other -frameDiffToSMF :: HasCallStack => Frame -> BasicBlock -> StackMapFrame +frameDiffToSMF :: (HasCallStack) => Frame -> BasicBlock -> StackMapFrame frameDiffToSMF f1@(Frame locals1 stack1) bb = do let f2@(Frame locals2 stack2) = analyseBlockDiff f1 bb if - | locals1 == locals2 && stack1 == stack2 -> SameFrame (fromJust bb.end) - | stack1 == stack2 && locals1 `isPrefixOf` locals2 -> AppendFrame (map lvToVerificationTypeInfo (drop (length locals1) locals2)) (fromJust bb.end) - | otherwise -> error (show f1 <> show f2) + | locals1 == locals2 && stack1 == stack2 -> SameFrame (fromJust bb.end) + | stack1 == stack2 && locals1 `isPrefixOf` locals2 -> AppendFrame (map lvToVerificationTypeInfo (drop (length locals1) locals2)) (fromJust bb.end) + | otherwise -> error (show f1 <> show f2) lvToVerificationTypeInfo :: LocalVariable -> VerificationTypeInfo lvToVerificationTypeInfo Uninitialised = TopVariableInfo diff --git a/src/JVM/Data/Convert/AccessFlag.hs b/src/JVM/Data/Convert/AccessFlag.hs index ab7ebd9..454d631 100644 --- a/src/JVM/Data/Convert/AccessFlag.hs +++ b/src/JVM/Data/Convert/AccessFlag.hs @@ -11,7 +11,7 @@ import JVM.Data.Raw.AccessFlags qualified as Raw class ConvertAccessFlag a where convertAccessFlag :: a -> Raw.AccessFlag -accessFlagsToWord16 :: ConvertAccessFlag a => [a] -> Word16 +accessFlagsToWord16 :: (ConvertAccessFlag a) => [a] -> Word16 accessFlagsToWord16 = foldr (\flag acc -> acc .|. accessFlagValue (convertAccessFlag flag)) 0 instance ConvertAccessFlag ClassAccessFlag where diff --git a/src/JVM/Data/Convert/ConstantPool.hs b/src/JVM/Data/Convert/ConstantPool.hs index 8704a92..a85c708 100644 --- a/src/JVM/Data/Convert/ConstantPool.hs +++ b/src/JVM/Data/Convert/ConstantPool.hs @@ -20,13 +20,13 @@ import JVM.Data.Raw.ConstantPool import JVM.Data.Raw.MagicNumbers import JVM.Data.Raw.Types -lookupOrInsertM :: Monad m => ConstantPoolInfo -> ConstantPoolT m Int +lookupOrInsertM :: (Monad m) => ConstantPoolInfo -> ConstantPoolT m Int lookupOrInsertM = IM.lookupOrInsertMOver _constantPool _constantPool :: Lens' ConstantPoolState (IndexedMap ConstantPoolInfo) _constantPool = lens (.constantPool) (\s x -> s{constantPool = x}) -transformEntry :: Monad m => ConstantPoolEntry -> ConstantPoolT m Int +transformEntry :: (Monad m) => ConstantPoolEntry -> ConstantPoolT m Int transformEntry (CPUTF8Entry text) = lookupOrInsertM (UTF8Info $ encodeUtf8 text) transformEntry (CPIntegerEntry i) = lookupOrInsertM (IntegerInfo $ fromIntegral i) transformEntry (CPFloatEntry f) = lookupOrInsertM (FloatInfo (toJVMFloat f)) @@ -100,7 +100,7 @@ transformEntry (CPMethodTypeEntry methodDescriptor) = do descriptorIndex <- transformEntry (CPUTF8Entry (convertMethodDescriptor methodDescriptor)) lookupOrInsertM (MethodTypeInfo (fromIntegral descriptorIndex)) -convertBootstrapMethod :: Monad m => BootstrapMethod -> ConstantPoolT m Int +convertBootstrapMethod :: (Monad m) => BootstrapMethod -> ConstantPoolT m Int convertBootstrapMethod (BootstrapMethod mhEntry args) = do mhIndex <- findIndexOf (CPMethodHandleEntry mhEntry) bsArgs <- traverse (findIndexOf . bmArgToCPEntry) args @@ -126,10 +126,10 @@ newtype ConstantPoolT m a = ConstantPoolT (StateT ConstantPoolState m a) type ConstantPoolM = ConstantPoolT Identity -class Monad m => MonadConstantPool m where +class (Monad m) => MonadConstantPool m where findIndexOf :: ConstantPoolEntry -> m U2 -instance Monad m => MonadConstantPool (ConstantPoolT m) where +instance (Monad m) => MonadConstantPool (ConstantPoolT m) where findIndexOf = fmap toU2OrError . transformEntry where toU2OrError :: Int -> U2 @@ -138,21 +138,21 @@ instance Monad m => MonadConstantPool (ConstantPoolT m) where then error "Constant pool index out of bounds, too many entries?" else fromIntegral i -instance MonadConstantPool m => MonadConstantPool (StateT s m) where +instance (MonadConstantPool m) => MonadConstantPool (StateT s m) where findIndexOf = lift . findIndexOf -instance MonadConstantPool m => MonadConstantPool (ExceptT e m) where +instance (MonadConstantPool m) => MonadConstantPool (ExceptT e m) where findIndexOf = lift . findIndexOf -deriving instance MonadError e m => MonadError e (ConstantPoolT m) +deriving instance (MonadError e m) => MonadError e (ConstantPoolT m) runConstantPoolM :: ConstantPoolM a -> (a, ConstantPoolState) runConstantPoolM = runConstantPoolMWith mempty -runConstantPoolT :: Monad m => ConstantPoolT m a -> m (a, ConstantPoolState) +runConstantPoolT :: (Monad m) => ConstantPoolT m a -> m (a, ConstantPoolState) runConstantPoolT = runConstantPoolTWith mempty -runConstantPoolTWith :: Monad m => ConstantPoolState -> ConstantPoolT m a -> m (a, ConstantPoolState) +runConstantPoolTWith :: (Monad m) => ConstantPoolState -> ConstantPoolT m a -> m (a, ConstantPoolState) runConstantPoolTWith s (ConstantPoolT t) = runStateT t s runConstantPoolMWith :: ConstantPoolState -> ConstantPoolM a -> (a, ConstantPoolState) diff --git a/src/JVM/Data/Convert/Method.hs b/src/JVM/Data/Convert/Method.hs index 81ece5c..73cac44 100644 --- a/src/JVM/Data/Convert/Method.hs +++ b/src/JVM/Data/Convert/Method.hs @@ -20,14 +20,14 @@ import JVM.Data.Raw.Types -- >>> foldMWith (\a b -> pure (a + b, a + b)) 0 [1, 2, 3] -- (6,[1,3,6]) -foldMWith :: Monad m => (a -> b -> m (a, c)) -> a -> [b] -> m (a, [c]) +foldMWith :: (Monad m) => (a -> b -> m (a, c)) -> a -> [b] -> m (a, [c]) foldMWith _ a [] = pure (a, []) foldMWith f a (x : xs) = do (a', x') <- f a x (a'', xs') <- foldMWith f a' xs pure (a'', x' : xs') -convertMethodAttribute :: HasCallStack => Abs.MethodAttribute -> ConvertM Raw.AttributeInfo +convertMethodAttribute :: (HasCallStack) => Abs.MethodAttribute -> ConvertM Raw.AttributeInfo convertMethodAttribute (Abs.Code (Abs.CodeAttributeData{..})) = do (code', attributes') <- fullyRunCodeConverter $ do liftA2 (,) (convertInstructions code) (convertCodeAttributes codeAttributes) @@ -130,7 +130,7 @@ convertVerificationTypeInfo (Abs.UninitializedVariableInfo x) = do label <- fullyResolveAbs x pure $ Raw.UninitializedVariableInfo (fromIntegral label) -convertMethod :: HasCallStack => Abs.ClassFileMethod -> ConvertM Raw.MethodInfo +convertMethod :: (HasCallStack) => Abs.ClassFileMethod -> ConvertM Raw.MethodInfo convertMethod Abs.ClassFileMethod{..} = do let flags = accessFlagsToWord16 methodAccessFlags nameIndex <- findIndexOf (CPUTF8Entry methodName) diff --git a/src/JVM/Data/Pretty.hs b/src/JVM/Data/Pretty.hs index 9277475..86f0ec3 100644 --- a/src/JVM/Data/Pretty.hs +++ b/src/JVM/Data/Pretty.hs @@ -9,7 +9,7 @@ import Debug.Trace (trace) import Prettyprinter import Prettyprinter.Render.Text (renderStrict) -showPretty :: IsString s => Pretty a => a -> s +showPretty :: (IsString s) => (Pretty a) => a -> s showPretty = fromString . unpack . renderStrict . layoutPretty defaultLayoutOptions . pretty instance Pretty (Doc a) where diff --git a/test/Convert.hs b/test/Convert.hs index e8c7dd5..fc1216c 100644 --- a/test/Convert.hs +++ b/test/Convert.hs @@ -70,5 +70,5 @@ spec = describe "test conversions" $ do bms === IM.singleton (Raw.BootstrapMethod (fromIntegral indexOfMethodHandle) [fromIntegral strArgIndex]) inst === Raw.InvokeDynamic (fromIntegral indexOfIndy) -findCPIndex :: MonadTest m => (a -> Bool) -> IM.IndexedMap a -> m Int +findCPIndex :: (MonadTest m) => (a -> Bool) -> IM.IndexedMap a -> m Int findCPIndex pred cp = shouldBeJust $ IM.lookupIndexWhere pred cp diff --git a/test/Util.hs b/test/Util.hs index 7b683d5..eb2476c 100644 --- a/test/Util.hs +++ b/test/Util.hs @@ -10,7 +10,7 @@ import JVM.Data.Convert.Monad (runConvertM) import JVM.Data.Raw.Instruction qualified as Raw import Test.Hspec (HasCallStack) -runConv :: MonadTest m => [Abs.Instruction] -> m ([Raw.Instruction], ConstantPoolState) +runConv :: (MonadTest m) => [Abs.Instruction] -> m ([Raw.Instruction], ConstantPoolState) runConv = withFrozenCallStack $ shouldBeRight @@ -18,7 +18,7 @@ runConv = . fullyRunCodeConverter . convertInstructions -shouldBeJust :: MonadTest m => HasCallStack => Maybe a -> m a +shouldBeJust :: (MonadTest m) => (HasCallStack) => Maybe a -> m a shouldBeJust (Just a) = pure a shouldBeJust Nothing = withFrozenCallStack $ failWith Nothing "Expected Just, got Nothing" -- This is safe because we know that the expectationFailure function will never return From 3ea902b1010929f5afb505f16839905efcfc1301 Mon Sep 17 00:00:00 2001 From: Alexander Wood Date: Tue, 5 Dec 2023 21:05:39 +0000 Subject: [PATCH 10/23] More DataMergeable implementations --- flake.nix | 1 + src/JVM/Data/Abstract/ClassFile/Method.hs | 9 +++++++++ src/JVM/Data/Abstract/Instruction.hs | 2 +- 3 files changed, 11 insertions(+), 1 deletion(-) diff --git a/flake.nix b/flake.nix index 3dee028..addbc90 100644 --- a/flake.nix +++ b/flake.nix @@ -40,6 +40,7 @@ packages = { # fourmolu.source = "0.11.0.0"; + hedgehog.source = "1.4"; }; settings = { diff --git a/src/JVM/Data/Abstract/ClassFile/Method.hs b/src/JVM/Data/Abstract/ClassFile/Method.hs index 81535f0..1591a4f 100644 --- a/src/JVM/Data/Abstract/ClassFile/Method.hs +++ b/src/JVM/Data/Abstract/ClassFile/Method.hs @@ -51,6 +51,15 @@ instance DataMergeable CodeAttribute where merge (StackMapTable a) (StackMapTable b) = StackMapTable (a <> b) merge x y = errorDifferentConstructors x y +instance DataMergeable MethodAttribute where + merge (Code a) (Code b) = Code (merge a b) + merge x y = errorDifferentConstructors x y + +instance DataMergeable CodeAttributeData where + merge (CodeAttributeData a b c d e) (CodeAttributeData a' b' c' d' e') = + CodeAttributeData (max a a') (max b b') (c <> c') (d <> d') (e <> e') + + data StackMapFrame = SameFrame Label | ChopFrame diff --git a/src/JVM/Data/Abstract/Instruction.hs b/src/JVM/Data/Abstract/Instruction.hs index 0cc412b..6fd929a 100644 --- a/src/JVM/Data/Abstract/Instruction.hs +++ b/src/JVM/Data/Abstract/Instruction.hs @@ -6,6 +6,7 @@ -} module JVM.Data.Abstract.Instruction where +import Data.Data (Data) import Data.Text (Text) import GHC.Generics (Generic) import JVM.Data.Abstract.Builder.Label (Label) @@ -14,7 +15,6 @@ import JVM.Data.Abstract.Descriptor import JVM.Data.Abstract.Type import JVM.Data.Pretty import JVM.Data.Raw.Types -import Data.Data (Data) type Reference = Int From 89361c5000f240b398d05152aa2082b6491e8594 Mon Sep 17 00:00:00 2001 From: Alexander Wood Date: Tue, 5 Dec 2023 21:46:05 +0000 Subject: [PATCH 11/23] invokeX support --- flake.nix | 3 +++ h2jvm.cabal | 1 + result | 1 + src/JVM/Data/Abstract/ClassFile/Method.hs | 1 - src/JVM/Data/Analyse/StackMap.hs | 6 +++++- 5 files changed, 10 insertions(+), 2 deletions(-) create mode 120000 result diff --git a/flake.nix b/flake.nix index addbc90..23c77fd 100644 --- a/flake.nix +++ b/flake.nix @@ -41,6 +41,8 @@ packages = { # fourmolu.source = "0.11.0.0"; hedgehog.source = "1.4"; + tasty-hedgehog.source = "1.4.0.2"; + }; settings = { @@ -49,6 +51,7 @@ check = false; }; fourmolu.check = false; + hw-fingertree.check = false; }; }; diff --git a/h2jvm.cabal b/h2jvm.cabal index 400bee4..ff78517 100644 --- a/h2jvm.cabal +++ b/h2jvm.cabal @@ -153,6 +153,7 @@ test-suite h2jvm-test -- The entrypoint to the test suite. main-is: Main.hs other-modules: + Analyse Builder Convert Util diff --git a/result b/result new file mode 120000 index 0000000..19962e4 --- /dev/null +++ b/result @@ -0,0 +1 @@ +/nix/store/fsy9gx6qp90ra0034p4ikyc0254jnp26-h2jvm-0.4.4.2 \ No newline at end of file diff --git a/src/JVM/Data/Abstract/ClassFile/Method.hs b/src/JVM/Data/Abstract/ClassFile/Method.hs index 1591a4f..f97bf68 100644 --- a/src/JVM/Data/Abstract/ClassFile/Method.hs +++ b/src/JVM/Data/Abstract/ClassFile/Method.hs @@ -59,7 +59,6 @@ instance DataMergeable CodeAttributeData where merge (CodeAttributeData a b c d e) (CodeAttributeData a' b' c' d' e') = CodeAttributeData (max a a') (max b b') (c <> c') (d <> d') (e <> e') - data StackMapFrame = SameFrame Label | ChopFrame diff --git a/src/JVM/Data/Analyse/StackMap.hs b/src/JVM/Data/Analyse/StackMap.hs index ecf2b46..afb2a6a 100644 --- a/src/JVM/Data/Analyse/StackMap.hs +++ b/src/JVM/Data/Analyse/StackMap.hs @@ -14,7 +14,7 @@ import Data.Maybe (fromJust) import GHC.Stack (HasCallStack) import JVM.Data.Abstract.Builder.Label import JVM.Data.Abstract.ClassFile.Method -import JVM.Data.Abstract.Descriptor (MethodDescriptor (MethodDescriptor)) +import JVM.Data.Abstract.Descriptor (MethodDescriptor (MethodDescriptor), methodParams) import JVM.Data.Abstract.Instruction import JVM.Data.Abstract.Type (FieldType (..), PrimitiveType (..), fieldTypeToClassInfoType) @@ -94,6 +94,10 @@ analyseBlockDiff current block = do analyseInstruction (IfGe _) ba = ba{stack = tail ba.stack} analyseInstruction (IfGt _) ba = ba{stack = tail ba.stack} analyseInstruction (IfLe _) ba = ba{stack = tail ba.stack} + analyseInstruction (InvokeStatic _ _ md) ba = ba{stack = drop (length (methodParams md)) ba.stack} + analyseInstruction (InvokeVirtual _ _ md) ba = ba{stack = drop (1 + length (methodParams md)) ba.stack} + analyseInstruction (InvokeInterface _ _ md) ba = ba{stack = drop (1 + length (methodParams md)) ba.stack} + analyseInstruction (InvokeDynamic _ _ md) ba = ba{stack = drop (1 + length (methodParams md)) ba.stack} analyseInstruction other ba = error $ "Instruction not supported: " <> show other frameDiffToSMF :: (HasCallStack) => Frame -> BasicBlock -> StackMapFrame From a64f6a12d3b07e7ea63627769f0bbce74acfc4eb Mon Sep 17 00:00:00 2001 From: Alexander Wood Date: Tue, 5 Dec 2023 21:48:53 +0000 Subject: [PATCH 12/23] no more nix result --- .gitignore | 3 ++- result | 1 - 2 files changed, 2 insertions(+), 2 deletions(-) delete mode 120000 result diff --git a/.gitignore b/.gitignore index 29b9738..bb415e3 100644 --- a/.gitignore +++ b/.gitignore @@ -21,6 +21,7 @@ cabal.project.local cabal.project.local~ .HTF/ .ghc.environment.* +result .vscode/ @@ -29,4 +30,4 @@ cabal.project.local~ .direnv/ -.DS_Store \ No newline at end of file +.DS_Store diff --git a/result b/result deleted file mode 120000 index 19962e4..0000000 --- a/result +++ /dev/null @@ -1 +0,0 @@ -/nix/store/fsy9gx6qp90ra0034p4ikyc0254jnp26-h2jvm-0.4.4.2 \ No newline at end of file From f74885eb98abf374bb8bcf7e898b82bbfa48e7e3 Mon Sep 17 00:00:00 2001 From: Alexander Wood Date: Tue, 5 Dec 2023 21:56:01 +0000 Subject: [PATCH 13/23] fix incorrect stack changes for InvokeX --- src/JVM/Data/Abstract/Descriptor.hs | 9 ++++----- src/JVM/Data/Analyse/StackMap.hs | 17 ++++++++--------- 2 files changed, 12 insertions(+), 14 deletions(-) diff --git a/src/JVM/Data/Abstract/Descriptor.hs b/src/JVM/Data/Abstract/Descriptor.hs index 25f7579..7f4f157 100644 --- a/src/JVM/Data/Abstract/Descriptor.hs +++ b/src/JVM/Data/Abstract/Descriptor.hs @@ -4,16 +4,15 @@ import Data.Data import JVM.Data.Abstract.Type (FieldType) import JVM.Data.Pretty -data MethodDescriptor - = MethodDescriptor [FieldType] ReturnDescriptor +data MethodDescriptor = MethodDescriptor + { params :: [FieldType] + , return :: ReturnDescriptor + } deriving (Show, Eq, Ord, Data) instance Pretty MethodDescriptor where pretty (MethodDescriptor params ret) = "(" <> hsep (pretty <$> params) <> ")" <> pretty ret -methodParams :: MethodDescriptor -> [FieldType] -methodParams (MethodDescriptor params _) = params - methodParam :: MethodDescriptor -> Int -> Maybe FieldType methodParam (MethodDescriptor params _) i = params !!? i where diff --git a/src/JVM/Data/Analyse/StackMap.hs b/src/JVM/Data/Analyse/StackMap.hs index afb2a6a..1cf71a0 100644 --- a/src/JVM/Data/Analyse/StackMap.hs +++ b/src/JVM/Data/Analyse/StackMap.hs @@ -10,11 +10,11 @@ module JVM.Data.Analyse.StackMap where import Control.Lens.Fold import Data.Generics.Sum (AsAny (_As)) import Data.List -import Data.Maybe (fromJust) +import Data.Maybe (fromJust, maybeToList) import GHC.Stack (HasCallStack) import JVM.Data.Abstract.Builder.Label import JVM.Data.Abstract.ClassFile.Method -import JVM.Data.Abstract.Descriptor (MethodDescriptor (MethodDescriptor), methodParams) +import JVM.Data.Abstract.Descriptor (MethodDescriptor (..), returnDescriptorType) import JVM.Data.Abstract.Instruction import JVM.Data.Abstract.Type (FieldType (..), PrimitiveType (..), fieldTypeToClassInfoType) @@ -55,7 +55,7 @@ splitIntoBasicBlocks l = splitOnLabels :: [Instruction] -> [(Maybe Label, [Instruction])] splitOnLabels xs = go xs [] where - go :: [Instruction] -> ([Instruction]) -> [(Maybe Label, [Instruction])] + go :: [Instruction] -> [Instruction] -> [(Maybe Label, [Instruction])] go [] acc = [(Nothing, acc)] go (x : xs) acc = case x ^? _As @"Label" of Just l' -> (Just l', acc) : go xs [] @@ -65,8 +65,7 @@ topFrame :: MethodDescriptor -> Frame topFrame (MethodDescriptor args _) = Frame (map LocalVariable args) [] analyseBlockDiff :: Frame -> BasicBlock -> Frame -analyseBlockDiff current block = do - foldl (flip analyseInstruction) current (takeWhileInclusive (not . isConditionalJump) block.instructions) +analyseBlockDiff current block = foldl (flip analyseInstruction) current (takeWhileInclusive (not . isConditionalJump) block.instructions) where isConditionalJump :: Instruction -> Bool isConditionalJump (IfEq _) = True @@ -94,10 +93,10 @@ analyseBlockDiff current block = do analyseInstruction (IfGe _) ba = ba{stack = tail ba.stack} analyseInstruction (IfGt _) ba = ba{stack = tail ba.stack} analyseInstruction (IfLe _) ba = ba{stack = tail ba.stack} - analyseInstruction (InvokeStatic _ _ md) ba = ba{stack = drop (length (methodParams md)) ba.stack} - analyseInstruction (InvokeVirtual _ _ md) ba = ba{stack = drop (1 + length (methodParams md)) ba.stack} - analyseInstruction (InvokeInterface _ _ md) ba = ba{stack = drop (1 + length (methodParams md)) ba.stack} - analyseInstruction (InvokeDynamic _ _ md) ba = ba{stack = drop (1 + length (methodParams md)) ba.stack} + analyseInstruction (InvokeStatic _ _ md) ba = ba{stack = (StackEntry <$> maybeToList (returnDescriptorType md.return)) <> drop (length md.params) ba.stack} + analyseInstruction (InvokeVirtual _ _ md) ba = ba{stack = (StackEntry <$> maybeToList (returnDescriptorType md.return)) <> drop (1 + length md.params) ba.stack} + analyseInstruction (InvokeInterface _ _ md) ba = ba{stack = (StackEntry <$> maybeToList (returnDescriptorType md.return)) <> drop (length md.params) ba.stack} + analyseInstruction (InvokeDynamic _ _ md) ba = ba{stack = (StackEntry <$> maybeToList (returnDescriptorType md.return)) <> drop (1 + length md.params) ba.stack} analyseInstruction other ba = error $ "Instruction not supported: " <> show other frameDiffToSMF :: (HasCallStack) => Frame -> BasicBlock -> StackMapFrame From 80a332fe6ad4b00ba5b90aa769c42265f9a05ed1 Mon Sep 17 00:00:00 2001 From: Alexander Wood Date: Tue, 5 Dec 2023 22:02:11 +0000 Subject: [PATCH 14/23] now all the different stackmap combos work :) --- src/JVM/Data/Analyse/StackMap.hs | 16 ++++++++++++++-- 1 file changed, 14 insertions(+), 2 deletions(-) diff --git a/src/JVM/Data/Analyse/StackMap.hs b/src/JVM/Data/Analyse/StackMap.hs index 1cf71a0..90f43d5 100644 --- a/src/JVM/Data/Analyse/StackMap.hs +++ b/src/JVM/Data/Analyse/StackMap.hs @@ -101,11 +101,13 @@ analyseBlockDiff current block = foldl (flip analyseInstruction) current (takeWh frameDiffToSMF :: (HasCallStack) => Frame -> BasicBlock -> StackMapFrame frameDiffToSMF f1@(Frame locals1 stack1) bb = do - let f2@(Frame locals2 stack2) = analyseBlockDiff f1 bb + let (Frame locals2 stack2) = analyseBlockDiff f1 bb if | locals1 == locals2 && stack1 == stack2 -> SameFrame (fromJust bb.end) | stack1 == stack2 && locals1 `isPrefixOf` locals2 -> AppendFrame (map lvToVerificationTypeInfo (drop (length locals1) locals2)) (fromJust bb.end) - | otherwise -> error (show f1 <> show f2) + | [x] <- stack2, locals1 == locals2 -> SameLocals1StackItemFrame (seToVerificationTypeInfo x) (fromJust bb.end) + | locals1 == locals2 && locals1 `isSuffixOf` locals2 -> ChopFrame (fromIntegral $ length locals1 - length locals2) (fromJust bb.end) + | otherwise -> FullFrame (map lvToVerificationTypeInfo locals2) (map seToVerificationTypeInfo stack2) (fromJust bb.end) lvToVerificationTypeInfo :: LocalVariable -> VerificationTypeInfo lvToVerificationTypeInfo Uninitialised = TopVariableInfo @@ -116,6 +118,16 @@ lvToVerificationTypeInfo (LocalVariable ft) = case ft of PrimitiveFieldType Double -> DoubleVariableInfo _ -> ObjectVariableInfo (fieldTypeToClassInfoType ft) +seToVerificationTypeInfo :: StackEntry -> VerificationTypeInfo +seToVerificationTypeInfo StackEntryTop = TopVariableInfo +seToVerificationTypeInfo StackEntryNull = NullVariableInfo +seToVerificationTypeInfo (StackEntry ft) = case ft of + PrimitiveFieldType Int -> IntegerVariableInfo + PrimitiveFieldType Float -> FloatVariableInfo + PrimitiveFieldType Long -> LongVariableInfo + PrimitiveFieldType Double -> DoubleVariableInfo + _ -> ObjectVariableInfo (fieldTypeToClassInfoType ft) + calculateStackMapFrames :: MethodDescriptor -> [Instruction] -> [StackMapFrame] calculateStackMapFrames md code = do let blocks = splitIntoBasicBlocks code From ff0a2342c03b65ba27a1d0b261db6bfadf265417 Mon Sep 17 00:00:00 2001 From: Alexander Wood Date: Tue, 5 Dec 2023 22:06:54 +0000 Subject: [PATCH 15/23] impl stackmap changes for all instructions --- src/JVM/Data/Abstract/Type.hs | 5 +++++ src/JVM/Data/Analyse/StackMap.hs | 9 +++++++-- 2 files changed, 12 insertions(+), 2 deletions(-) diff --git a/src/JVM/Data/Abstract/Type.hs b/src/JVM/Data/Abstract/Type.hs index 5dab450..6a41874 100644 --- a/src/JVM/Data/Abstract/Type.hs +++ b/src/JVM/Data/Abstract/Type.hs @@ -47,6 +47,11 @@ data ClassInfoType | ArrayClassInfoType ClassInfoType deriving (Show, Eq, Ord, Data) +classInfoTypeToFieldType :: ClassInfoType -> FieldType +classInfoTypeToFieldType (ClassInfoType c) = ObjectFieldType c +classInfoTypeToFieldType (PrimitiveClassInfoType p) = PrimitiveFieldType p +classInfoTypeToFieldType (ArrayClassInfoType c) = ArrayFieldType (classInfoTypeToFieldType c) + instance Pretty ClassInfoType where pretty (ClassInfoType c) = pretty c pretty (PrimitiveClassInfoType p) = pretty p diff --git a/src/JVM/Data/Analyse/StackMap.hs b/src/JVM/Data/Analyse/StackMap.hs index 90f43d5..53b9f2d 100644 --- a/src/JVM/Data/Analyse/StackMap.hs +++ b/src/JVM/Data/Analyse/StackMap.hs @@ -16,7 +16,7 @@ import JVM.Data.Abstract.Builder.Label import JVM.Data.Abstract.ClassFile.Method import JVM.Data.Abstract.Descriptor (MethodDescriptor (..), returnDescriptorType) import JVM.Data.Abstract.Instruction -import JVM.Data.Abstract.Type (FieldType (..), PrimitiveType (..), fieldTypeToClassInfoType) +import JVM.Data.Abstract.Type (FieldType (..), PrimitiveType (..), classInfoTypeToFieldType, fieldTypeToClassInfoType) data BasicBlock = BasicBlock { index :: Int @@ -93,11 +93,16 @@ analyseBlockDiff current block = foldl (flip analyseInstruction) current (takeWh analyseInstruction (IfGe _) ba = ba{stack = tail ba.stack} analyseInstruction (IfGt _) ba = ba{stack = tail ba.stack} analyseInstruction (IfLe _) ba = ba{stack = tail ba.stack} + analyseInstruction (CheckCast _) ba = ba analyseInstruction (InvokeStatic _ _ md) ba = ba{stack = (StackEntry <$> maybeToList (returnDescriptorType md.return)) <> drop (length md.params) ba.stack} analyseInstruction (InvokeVirtual _ _ md) ba = ba{stack = (StackEntry <$> maybeToList (returnDescriptorType md.return)) <> drop (1 + length md.params) ba.stack} analyseInstruction (InvokeInterface _ _ md) ba = ba{stack = (StackEntry <$> maybeToList (returnDescriptorType md.return)) <> drop (length md.params) ba.stack} analyseInstruction (InvokeDynamic _ _ md) ba = ba{stack = (StackEntry <$> maybeToList (returnDescriptorType md.return)) <> drop (1 + length md.params) ba.stack} - analyseInstruction other ba = error $ "Instruction not supported: " <> show other + analyseInstruction (PutStatic {}) ba = ba{stack = tail ba.stack} + analyseInstruction (GetField t _ _) ba = ba{stack = StackEntry (classInfoTypeToFieldType t) : tail ba.stack} + analyseInstruction (GetStatic t _ _) ba = ba{stack = StackEntry (classInfoTypeToFieldType t) : ba.stack} + analyseInstruction (Goto _) ba = ba + analyseInstruction (LDC l) ba = ba{stack = StackEntry (ldcEntryToFieldType l) : ba.stack} frameDiffToSMF :: (HasCallStack) => Frame -> BasicBlock -> StackMapFrame frameDiffToSMF f1@(Frame locals1 stack1) bb = do From d2fb85b3b87ad9440a3d438edb0b9947d26d8533 Mon Sep 17 00:00:00 2001 From: Alexander Wood Date: Tue, 5 Dec 2023 22:07:13 +0000 Subject: [PATCH 16/23] oh nix you are funny sometimes i love you and dont hate you at all --- flake.nix | 1 + 1 file changed, 1 insertion(+) diff --git a/flake.nix b/flake.nix index 23c77fd..f8352c8 100644 --- a/flake.nix +++ b/flake.nix @@ -52,6 +52,7 @@ }; fourmolu.check = false; hw-fingertree.check = false; + hw-prim.check = false; }; }; From 458896d07950a26fcd9946ea686ec6f39bbecff6 Mon Sep 17 00:00:00 2001 From: Alexander Wood Date: Tue, 5 Dec 2023 22:29:57 +0000 Subject: [PATCH 17/23] format --- src/JVM/Data/Abstract/Instruction.hs | 1 + src/JVM/Data/Analyse/StackMap.hs | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/src/JVM/Data/Abstract/Instruction.hs b/src/JVM/Data/Abstract/Instruction.hs index 6fd929a..d4778e0 100644 --- a/src/JVM/Data/Abstract/Instruction.hs +++ b/src/JVM/Data/Abstract/Instruction.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE UndecidableInstances #-} {- | High level representation of a JVM instruction, with type-safe arguments and no stack manipulation needed. This is not a 1-1 mapping to the actual instructions, use 'JVM.Data.Raw.Instruction' for that. diff --git a/src/JVM/Data/Analyse/StackMap.hs b/src/JVM/Data/Analyse/StackMap.hs index 53b9f2d..7765bba 100644 --- a/src/JVM/Data/Analyse/StackMap.hs +++ b/src/JVM/Data/Analyse/StackMap.hs @@ -98,7 +98,7 @@ analyseBlockDiff current block = foldl (flip analyseInstruction) current (takeWh analyseInstruction (InvokeVirtual _ _ md) ba = ba{stack = (StackEntry <$> maybeToList (returnDescriptorType md.return)) <> drop (1 + length md.params) ba.stack} analyseInstruction (InvokeInterface _ _ md) ba = ba{stack = (StackEntry <$> maybeToList (returnDescriptorType md.return)) <> drop (length md.params) ba.stack} analyseInstruction (InvokeDynamic _ _ md) ba = ba{stack = (StackEntry <$> maybeToList (returnDescriptorType md.return)) <> drop (1 + length md.params) ba.stack} - analyseInstruction (PutStatic {}) ba = ba{stack = tail ba.stack} + analyseInstruction (PutStatic{}) ba = ba{stack = tail ba.stack} analyseInstruction (GetField t _ _) ba = ba{stack = StackEntry (classInfoTypeToFieldType t) : tail ba.stack} analyseInstruction (GetStatic t _ _) ba = ba{stack = StackEntry (classInfoTypeToFieldType t) : ba.stack} analyseInstruction (Goto _) ba = ba From 3f8224a52d25a9f06d812b2b80e24e32d051c59b Mon Sep 17 00:00:00 2001 From: Alexander Wood Date: Tue, 5 Dec 2023 22:36:04 +0000 Subject: [PATCH 18/23] debug --- src/JVM/Data/Analyse/StackMap.hs | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/src/JVM/Data/Analyse/StackMap.hs b/src/JVM/Data/Analyse/StackMap.hs index 7765bba..f5ff201 100644 --- a/src/JVM/Data/Analyse/StackMap.hs +++ b/src/JVM/Data/Analyse/StackMap.hs @@ -65,7 +65,7 @@ topFrame :: MethodDescriptor -> Frame topFrame (MethodDescriptor args _) = Frame (map LocalVariable args) [] analyseBlockDiff :: Frame -> BasicBlock -> Frame -analyseBlockDiff current block = foldl (flip analyseInstruction) current (takeWhileInclusive (not . isConditionalJump) block.instructions) +analyseBlockDiff current block = foldl' (flip analyseInstruction) current (takeWhileInclusive (not . isConditionalJump) block.instructions) where isConditionalJump :: Instruction -> Bool isConditionalJump (IfEq _) = True @@ -78,8 +78,14 @@ analyseBlockDiff current block = foldl (flip analyseInstruction) current (takeWh analyseInstruction :: Instruction -> Frame -> Frame analyseInstruction (Label _) ba = error "Label should not be encountered in analyseInstruction" - analyseInstruction (ALoad i) ba = ba{stack = lvToStackEntry (ba.locals !! fromIntegral (i - 1)) : ba.stack} - analyseInstruction (ILoad i) ba = ba{stack = lvToStackEntry (ba.locals !! fromIntegral (i - 1)) : ba.stack} + analyseInstruction (ALoad i) ba = + if i - 1 > genericLength ba.locals + then error $ "ALoad index out of bounds. Given: " <> show i <> " Locals: " <> show ba.locals + else ba{stack = lvToStackEntry (ba.locals !! fromIntegral (i - 1)) : ba.stack} + analyseInstruction (ILoad i) ba = + if i - 1 > genericLength ba.locals + then error $ "ILoad index out of bounds. Given: " <> show i <> " Locals: " <> show ba.locals + else ba{stack = lvToStackEntry (ba.locals !! fromIntegral (i - 1)) : ba.stack} analyseInstruction (AStore i) ba = ba{locals = replaceAtOrGrow (fromIntegral (i - 1)) (stackEntryToLV $ head ba.stack) ba.locals, stack = tail ba.stack} analyseInstruction (IStore i) ba = ba{locals = replaceAtOrGrow (fromIntegral (i - 1)) (stackEntryToLV $ head ba.stack) ba.locals, stack = tail ba.stack} analyseInstruction AReturn ba = ba{stack = tail ba.stack} From 34d4071c0f470b68a42336126e2660a9df117a92 Mon Sep 17 00:00:00 2001 From: Alexander Wood Date: Tue, 5 Dec 2023 22:38:38 +0000 Subject: [PATCH 19/23] aload is zero indexed you dunce --- src/JVM/Data/Analyse/StackMap.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/JVM/Data/Analyse/StackMap.hs b/src/JVM/Data/Analyse/StackMap.hs index f5ff201..bf33621 100644 --- a/src/JVM/Data/Analyse/StackMap.hs +++ b/src/JVM/Data/Analyse/StackMap.hs @@ -79,13 +79,13 @@ analyseBlockDiff current block = foldl' (flip analyseInstruction) current (takeW analyseInstruction :: Instruction -> Frame -> Frame analyseInstruction (Label _) ba = error "Label should not be encountered in analyseInstruction" analyseInstruction (ALoad i) ba = - if i - 1 > genericLength ba.locals + if i > genericLength ba.locals then error $ "ALoad index out of bounds. Given: " <> show i <> " Locals: " <> show ba.locals - else ba{stack = lvToStackEntry (ba.locals !! fromIntegral (i - 1)) : ba.stack} + else ba{stack = lvToStackEntry (ba.locals !! fromIntegral i) : ba.stack} analyseInstruction (ILoad i) ba = - if i - 1 > genericLength ba.locals + if i > genericLength ba.locals then error $ "ILoad index out of bounds. Given: " <> show i <> " Locals: " <> show ba.locals - else ba{stack = lvToStackEntry (ba.locals !! fromIntegral (i - 1)) : ba.stack} + else ba{stack = lvToStackEntry (ba.locals !! fromIntegral i) : ba.stack} analyseInstruction (AStore i) ba = ba{locals = replaceAtOrGrow (fromIntegral (i - 1)) (stackEntryToLV $ head ba.stack) ba.locals, stack = tail ba.stack} analyseInstruction (IStore i) ba = ba{locals = replaceAtOrGrow (fromIntegral (i - 1)) (stackEntryToLV $ head ba.stack) ba.locals, stack = tail ba.stack} analyseInstruction AReturn ba = ba{stack = tail ba.stack} From 9ed5ee107def0525716eb6c5b2dceeccf326aaf7 Mon Sep 17 00:00:00 2001 From: Alexander Wood Date: Tue, 5 Dec 2023 22:42:40 +0000 Subject: [PATCH 20/23] hmm --- src/JVM/Data/Analyse/StackMap.hs | 4 ++-- test/Analyse.hs | 37 ++++++++++++++++++++++++++------ 2 files changed, 32 insertions(+), 9 deletions(-) diff --git a/src/JVM/Data/Analyse/StackMap.hs b/src/JVM/Data/Analyse/StackMap.hs index bf33621..b61c574 100644 --- a/src/JVM/Data/Analyse/StackMap.hs +++ b/src/JVM/Data/Analyse/StackMap.hs @@ -86,8 +86,8 @@ analyseBlockDiff current block = foldl' (flip analyseInstruction) current (takeW if i > genericLength ba.locals then error $ "ILoad index out of bounds. Given: " <> show i <> " Locals: " <> show ba.locals else ba{stack = lvToStackEntry (ba.locals !! fromIntegral i) : ba.stack} - analyseInstruction (AStore i) ba = ba{locals = replaceAtOrGrow (fromIntegral (i - 1)) (stackEntryToLV $ head ba.stack) ba.locals, stack = tail ba.stack} - analyseInstruction (IStore i) ba = ba{locals = replaceAtOrGrow (fromIntegral (i - 1)) (stackEntryToLV $ head ba.stack) ba.locals, stack = tail ba.stack} + analyseInstruction (AStore i) ba = ba{locals = replaceAtOrGrow (fromIntegral i) (stackEntryToLV $ head ba.stack) ba.locals, stack = tail ba.stack} + analyseInstruction (IStore i) ba = ba{locals = replaceAtOrGrow (fromIntegral i) (stackEntryToLV $ head ba.stack) ba.locals, stack = tail ba.stack} analyseInstruction AReturn ba = ba{stack = tail ba.stack} analyseInstruction Return ba = ba analyseInstruction (LDC (LDCInt _)) ba = ba{stack = StackEntry (PrimitiveFieldType Int) : ba.stack} diff --git a/test/Analyse.hs b/test/Analyse.hs index 69e6fa9..288202b 100644 --- a/test/Analyse.hs +++ b/test/Analyse.hs @@ -49,6 +49,29 @@ genFieldType = spec :: Spec spec = describe "Analysis checks" $ do describe "Does StackDiff concatenation correctly" $ do + it "Can identify incredibly simple blocks properly" $ do + let (_, code) = runCodeBuilder $ do + emit $ LDC (LDCInt 0) -- [0] + emit $ AStore 0 + emit $ ALoad 0 + emit AReturn + + hedgehog $ do + let blocks = splitIntoBasicBlocks code + + blocks + === [ BasicBlock 0 [LDC (LDCInt 0), AStore 0, ALoad 0, AReturn] Nothing + ] + + let top = topFrame (MethodDescriptor [] (TypeReturn (PrimitiveFieldType Int))) + let nextFrame = analyseBlockDiff top (head blocks) + + nextFrame + === Frame + { locals = [LocalVariable (PrimitiveFieldType Int)] + , stack = [] + } + it "Can identify sameframe blocks properly" $ do let (l, _, code) = runCodeBuilder' $ do label <- newLabel @@ -93,24 +116,24 @@ spec = describe "Analysis checks" $ do let (l, _, code) = runCodeBuilder' $ do label <- newLabel emit $ LDC (LDCInt 0) -- [0] - emit $ IStore 1 -- [] + emit $ IStore 0 -- [] emit $ LDC (LDCInt 0) -- [0] - emit $ IStore 2 -- [] - emit $ ILoad 1 -- [0] + emit $ IStore 1 -- [] + emit $ ILoad 0 -- [0] emit $ IfLe label -- [] emit $ LDC (LDCInt 0) -- [0] - emit $ IStore 3 -- [] + emit $ IStore 2 -- [] emit $ Label label -- [] emit $ LDC (LDCInt 0) -- [0] - emit $ IStore 3 -- [] + emit $ IStore 2 -- [] emit Return -- [] pure label hedgehog $ do let blocks = splitIntoBasicBlocks code blocks - === [ BasicBlock 0 [LDC (LDCInt 0), IStore 1, LDC (LDCInt 0), IStore 2, ILoad 1, IfLe l, LDC (LDCInt 0), IStore 3] (Just l) - , BasicBlock 1 [LDC (LDCInt 0), IStore 3, Return] Nothing + === [ BasicBlock 0 [LDC (LDCInt 0), IStore 0, LDC (LDCInt 0), IStore 1, ILoad 0, IfLe l, LDC (LDCInt 0), IStore 2] (Just l) + , BasicBlock 1 [LDC (LDCInt 0), IStore 2, Return] Nothing ] let top = topFrame (MethodDescriptor [] VoidReturn) From c15b3836b9b07c1efc3a0a318e34de26a436be66 Mon Sep 17 00:00:00 2001 From: Alexander Wood Date: Wed, 6 Dec 2023 21:44:34 +0000 Subject: [PATCH 21/23] update field name --- src/JVM/Data/Abstract/Descriptor.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/JVM/Data/Abstract/Descriptor.hs b/src/JVM/Data/Abstract/Descriptor.hs index 7f4f157..6717e0b 100644 --- a/src/JVM/Data/Abstract/Descriptor.hs +++ b/src/JVM/Data/Abstract/Descriptor.hs @@ -6,7 +6,7 @@ import JVM.Data.Pretty data MethodDescriptor = MethodDescriptor { params :: [FieldType] - , return :: ReturnDescriptor + , returnDesc :: ReturnDescriptor } deriving (Show, Eq, Ord, Data) From 32e98970f960ceb1a0051c1b908a0e1c636e269b Mon Sep 17 00:00:00 2001 From: Alexander Wood Date: Wed, 6 Dec 2023 21:47:15 +0000 Subject: [PATCH 22/23] SILLY GUY --- src/JVM/Data/Analyse/StackMap.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/JVM/Data/Analyse/StackMap.hs b/src/JVM/Data/Analyse/StackMap.hs index b61c574..6fb4925 100644 --- a/src/JVM/Data/Analyse/StackMap.hs +++ b/src/JVM/Data/Analyse/StackMap.hs @@ -100,10 +100,10 @@ analyseBlockDiff current block = foldl' (flip analyseInstruction) current (takeW analyseInstruction (IfGt _) ba = ba{stack = tail ba.stack} analyseInstruction (IfLe _) ba = ba{stack = tail ba.stack} analyseInstruction (CheckCast _) ba = ba - analyseInstruction (InvokeStatic _ _ md) ba = ba{stack = (StackEntry <$> maybeToList (returnDescriptorType md.return)) <> drop (length md.params) ba.stack} - analyseInstruction (InvokeVirtual _ _ md) ba = ba{stack = (StackEntry <$> maybeToList (returnDescriptorType md.return)) <> drop (1 + length md.params) ba.stack} - analyseInstruction (InvokeInterface _ _ md) ba = ba{stack = (StackEntry <$> maybeToList (returnDescriptorType md.return)) <> drop (length md.params) ba.stack} - analyseInstruction (InvokeDynamic _ _ md) ba = ba{stack = (StackEntry <$> maybeToList (returnDescriptorType md.return)) <> drop (1 + length md.params) ba.stack} + analyseInstruction (InvokeStatic _ _ md) ba = ba{stack = (StackEntry <$> maybeToList (returnDescriptorType md.returnDesc)) <> drop (length md.params) ba.stack} + analyseInstruction (InvokeVirtual _ _ md) ba = ba{stack = (StackEntry <$> maybeToList (returnDescriptorType md.returnDesc)) <> drop (1 + length md.params) ba.stack} + analyseInstruction (InvokeInterface _ _ md) ba = ba{stack = (StackEntry <$> maybeToList (returnDescriptorType md.returnDesc)) <> drop (length md.params) ba.stack} + analyseInstruction (InvokeDynamic _ _ md) ba = ba{stack = (StackEntry <$> maybeToList (returnDescriptorType md.returnDesc)) <> drop (1 + length md.params) ba.stack} analyseInstruction (PutStatic{}) ba = ba{stack = tail ba.stack} analyseInstruction (GetField t _ _) ba = ba{stack = StackEntry (classInfoTypeToFieldType t) : tail ba.stack} analyseInstruction (GetStatic t _ _) ba = ba{stack = StackEntry (classInfoTypeToFieldType t) : ba.stack} From 8001d5ce21f19920b6ed62b69798bea32a452f30 Mon Sep 17 00:00:00 2001 From: Alexander Wood Date: Thu, 7 Dec 2023 11:33:23 +0000 Subject: [PATCH 23/23] bump version --- h2jvm.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/h2jvm.cabal b/h2jvm.cabal index ff78517..530a0aa 100644 --- a/h2jvm.cabal +++ b/h2jvm.cabal @@ -21,7 +21,7 @@ name: h2jvm -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.4.4.2 +version: 0.4.4.3 -- A short (one-line) description of the package. synopsis: