From 4174461dc7cd2b14183917db3cd11219a37e804c Mon Sep 17 00:00:00 2001 From: "Ilya V. Portnov" Date: Tue, 4 Oct 2011 15:18:25 +0600 Subject: [PATCH] Support both IO and clean version of Generate monad. --- JVM/Builder/Instructions.hs | 256 ++++++++++++++++++------------------ JVM/Builder/Monad.hs | 80 +++++++---- JVM/Common.hs | 6 + JVM/Converter.hs | 1 - TestGen.hs | 4 +- 5 files changed, 190 insertions(+), 157 deletions(-) diff --git a/JVM/Builder/Instructions.hs b/JVM/Builder/Instructions.hs index bc4948a..0d85d97 100644 --- a/JVM/Builder/Instructions.hs +++ b/JVM/Builder/Instructions.hs @@ -10,294 +10,294 @@ import JVM.ClassFile import JVM.Assembler import JVM.Builder.Monad -nop :: Generate () +nop :: Generator g => g () nop = i0 NOP -aconst_null :: Generate () +aconst_null :: Generator g => g () aconst_null = i0 ACONST_NULL -iconst_m1 :: Generate () +iconst_m1 :: Generator g => g () iconst_m1 = i0 ICONST_M1 -iconst_0 :: Generate () +iconst_0 :: Generator g => g () iconst_0 = i0 ICONST_0 -iconst_1 :: Generate () +iconst_1 :: Generator g => g () iconst_1 = i0 ICONST_1 -iconst_2 :: Generate () +iconst_2 :: Generator g => g () iconst_2 = i0 ICONST_2 -iconst_3 :: Generate () +iconst_3 :: Generator g => g () iconst_3 = i0 ICONST_3 -iconst_4 :: Generate () +iconst_4 :: Generator g => g () iconst_4 = i0 ICONST_4 -iconst_5 :: Generate () +iconst_5 :: Generator g => g () iconst_5 = i0 ICONST_5 -lconst_0 :: Generate () +lconst_0 :: Generator g => g () lconst_0 = i0 LCONST_0 -lconst_1 :: Generate () +lconst_1 :: Generator g => g () lconst_1 = i0 LCONST_1 -fconst_0 :: Generate () +fconst_0 :: Generator g => g () fconst_0 = i0 FCONST_0 -fconst_1 :: Generate () +fconst_1 :: Generator g => g () fconst_1 = i0 FCONST_1 -fconst_2 :: Generate () +fconst_2 :: Generator g => g () fconst_2 = i0 FCONST_2 -dconst_0 :: Generate () +dconst_0 :: Generator g => g () dconst_0 = i0 DCONST_0 -dconst_1 :: Generate () +dconst_1 :: Generator g => g () dconst_1 = i0 DCONST_1 -bipush :: Word8 -> Generate () +bipush :: Generator g => Word8 -> g () bipush x = i0 (BIPUSH x) -sipush :: Word16 -> Generate () +sipush :: Generator g => Word16 -> g () sipush x = i0 (SIPUSH x) -ldc1 :: Constant Direct -> Generate () +ldc1 :: Generator g => Constant Direct -> g () ldc1 x = i8 LDC1 x -ldc2 :: Constant Direct -> Generate () +ldc2 :: Generator g => Constant Direct -> g () ldc2 x = i1 LDC2 x -ldc2w :: Constant Direct -> Generate () +ldc2w :: Generator g => Constant Direct -> g () ldc2w x = i1 LDC2W x -iload :: Constant Direct -> Generate () +iload :: Generator g => Constant Direct -> g () iload x = i8 ILOAD x -lload :: Constant Direct -> Generate () +lload :: Generator g => Constant Direct -> g () lload x = i8 LLOAD x -fload :: Constant Direct -> Generate () +fload :: Generator g => Constant Direct -> g () fload x = i8 FLOAD x -dload :: Constant Direct -> Generate () +dload :: Generator g => Constant Direct -> g () dload x = i8 DLOAD x -aload :: Constant Direct -> Generate () +aload :: Generator g => Constant Direct -> g () aload x = i8 ALOAD x -iload_ :: IMM -> Generate () +iload_ :: Generator g => IMM -> g () iload_ x = i0 (ILOAD_ x) -lload_ :: IMM -> Generate () +lload_ :: Generator g => IMM -> g () lload_ x = i0 (LLOAD_ x) -fload_ :: IMM -> Generate () +fload_ :: Generator g => IMM -> g () fload_ x = i0 (FLOAD_ x) -dload_ :: IMM -> Generate () +dload_ :: Generator g => IMM -> g () dload_ x = i0 (DLOAD_ x) -aload_ :: IMM -> Generate () +aload_ :: Generator g => IMM -> g () aload_ x = i0 (ALOAD_ x) -iaload :: Generate () +iaload :: Generator g => g () iaload = i0 IALOAD -laload :: Generate () +laload :: Generator g => g () laload = i0 LALOAD -faload :: Generate () +faload :: Generator g => g () faload = i0 FALOAD -daload :: Generate () +daload :: Generator g => g () daload = i0 DALOAD -aaload :: Generate () +aaload :: Generator g => g () aaload = i0 AALOAD -caload :: Generate () +caload :: Generator g => g () caload = i0 CALOAD -saload :: Generate () +saload :: Generator g => g () saload = i0 SALOAD -istore :: Constant Direct -> Generate () +istore :: Generator g => Constant Direct -> g () istore x = i8 ISTORE x -lstore :: Constant Direct -> Generate () +lstore :: Generator g => Constant Direct -> g () lstore x = i8 LSTORE x -fstore :: Constant Direct -> Generate () +fstore :: Generator g => Constant Direct -> g () fstore x = i8 FSTORE x -dstore :: Constant Direct -> Generate () +dstore :: Generator g => Constant Direct -> g () dstore x = i8 DSTORE x -astore :: Constant Direct -> Generate () +astore :: Generator g => Constant Direct -> g () astore x = i8 ASTORE x -istore_ :: Word8 -> Generate () +istore_ :: Generator g => Word8 -> g () istore_ x = i0 (ISTORE x) -lstore_ :: Word8 -> Generate () +lstore_ :: Generator g => Word8 -> g () lstore_ x = i0 (LSTORE x) -fstore_ :: Word8 -> Generate () +fstore_ :: Generator g => Word8 -> g () fstore_ x = i0 (FSTORE x) -dstore_ :: Word8 -> Generate () +dstore_ :: Generator g => Word8 -> g () dstore_ x = i0 (DSTORE x) -astore_ :: Word8 -> Generate () +astore_ :: Generator g => Word8 -> g () astore_ x = i0 (ASTORE x) -iastore :: Generate () +iastore :: Generator g => g () iastore = i0 IASTORE -lastore :: Generate () +lastore :: Generator g => g () lastore = i0 LASTORE -fastore :: Generate () +fastore :: Generator g => g () fastore = i0 FASTORE -dastore :: Generate () +dastore :: Generator g => g () dastore = i0 DASTORE -aastore :: Generate () +aastore :: Generator g => g () aastore = i0 AASTORE -bastore :: Generate () +bastore :: Generator g => g () bastore = i0 BASTORE -castore :: Generate () +castore :: Generator g => g () castore = i0 CASTORE -sastore :: Generate () +sastore :: Generator g => g () sastore = i0 SASTORE -pop :: Generate () +pop :: Generator g => g () pop = i0 POP -pop2 :: Generate () +pop2 :: Generator g => g () pop2 = i0 POP2 -dup :: Generate () +dup :: Generator g => g () dup = i0 DUP -dup_x1 :: Generate () +dup_x1 :: Generator g => g () dup_x1 = i0 DUP_X1 -dup_x2 :: Generate () +dup_x2 :: Generator g => g () dup_x2 = i0 DUP_X2 -dup2 :: Generate () +dup2 :: Generator g => g () dup2 = i0 DUP2 -dup2_x1 :: Generate () +dup2_x1 :: Generator g => g () dup2_x1 = i0 DUP2_X1 -dup2_x2 :: Generate () +dup2_x2 :: Generator g => g () dup2_x2 = i0 DUP2_X2 -swap :: Generate () +swap :: Generator g => g () swap = i0 SWAP -iadd :: Generate () +iadd :: Generator g => g () iadd = i0 IADD -ladd :: Generate () +ladd :: Generator g => g () ladd = i0 LADD -fadd :: Generate () +fadd :: Generator g => g () fadd = i0 FADD -dadd :: Generate () +dadd :: Generator g => g () dadd = i0 DADD -isub :: Generate () +isub :: Generator g => g () isub = i0 ISUB -lsub :: Generate () +lsub :: Generator g => g () lsub = i0 LSUB -fsub :: Generate () +fsub :: Generator g => g () fsub = i0 FSUB -dsub :: Generate () +dsub :: Generator g => g () dsub = i0 DSUB -imul :: Generate () +imul :: Generator g => g () imul = i0 IMUL -lmul :: Generate () +lmul :: Generator g => g () lmul = i0 LMUL -fmul :: Generate () +fmul :: Generator g => g () fmul = i0 FMUL -dmul :: Generate () +dmul :: Generator g => g () dmul = i0 DMUL -idiv :: Generate () +idiv :: Generator g => g () idiv = i0 IDIV -ldiv :: Generate () +ldiv :: Generator g => g () ldiv = i0 LDIV -fdiv :: Generate () +fdiv :: Generator g => g () fdiv = i0 FDIV -ddiv :: Generate () +ddiv :: Generator g => g () ddiv = i0 DDIV -irem :: Generate () +irem :: Generator g => g () irem = i0 IREM -lrem :: Generate () +lrem :: Generator g => g () lrem = i0 LREM -frem :: Generate () +frem :: Generator g => g () frem = i0 FREM -drem :: Generate () +drem :: Generator g => g () drem = i0 DREM -ineg :: Generate () +ineg :: Generator g => g () ineg = i0 INEG -lneg :: Generate () +lneg :: Generator g => g () lneg = i0 LNEG -fneg :: Generate () +fneg :: Generator g => g () fneg = i0 FNEG -dneg :: Generate () +dneg :: Generator g => g () dneg = i0 DNEG -ishl :: Generate () +ishl :: Generator g => g () ishl = i0 ISHL -lshl :: Generate () +lshl :: Generator g => g () lshl = i0 LSHL -ishr :: Generate () +ishr :: Generator g => g () ishr = i0 ISHR -lshr :: Generate () +lshr :: Generator g => g () lshr = i0 LSHR -iushr :: Generate () +iushr :: Generator g => g () iushr = i0 IUSHR -lushr :: Generate () +lushr :: Generator g => g () lushr = i0 LUSHR -iand :: Generate () +iand :: Generator g => g () iand = i0 IAND -land :: Generate () +land :: Generator g => g () land = i0 LAND -ior :: Generate () +ior :: Generator g => g () ior = i0 IOR -lor :: Generate () +lor :: Generator g => g () lor = i0 LOR -ixor :: Generate () +ixor :: Generator g => g () ixor = i0 IXOR -lxor :: Generate () +lxor :: Generator g => g () lxor = i0 LXOR -iinc :: Word8 -> Word8 -> Generate () +iinc :: Generator g => Word8 -> Word8 -> g () iinc x y = i0 (IINC x y) -i2l :: Generate () +i2l :: Generator g => g () i2l = i0 I2L -i2f :: Generate () +i2f :: Generator g => g () i2f = i0 I2F -i2d :: Generate () +i2d :: Generator g => g () i2d = i0 I2D -l2i :: Generate () +l2i :: Generator g => g () l2i = i0 L2I -l2f :: Generate () +l2f :: Generator g => g () l2f = i0 L2F -l2d :: Generate () +l2d :: Generator g => g () l2d = i0 L2D -f2i :: Generate () +f2i :: Generator g => g () f2i = i0 F2I -f2l :: Generate () +f2l :: Generator g => g () f2l = i0 F2L -f2d :: Generate () +f2d :: Generator g => g () f2d = i0 F2D -d2i :: Generate () +d2i :: Generator g => g () d2i = i0 D2I -d2l :: Generate () +d2l :: Generator g => g () d2l = i0 D2L -d2f :: Generate () +d2f :: Generator g => g () d2f = i0 D2F -i2b :: Generate () +i2b :: Generator g => g () i2b = i0 I2B -i2c :: Generate () +i2c :: Generator g => g () i2c = i0 I2C -i2s :: Generate () +i2s :: Generator g => g () i2s = i0 I2S -lcmp :: Generate () +lcmp :: Generator g => g () lcmp = i0 LCMP -- | Wide instruction -wide :: (Word8 -> Instruction) -> Constant Direct -> Generate () +wide :: Generator g => (Word8 -> Instruction) -> Constant Direct -> g () wide fn c = do ix <- addToPool c let ix0 = fromIntegral (ix `div` 0x100) :: Word8 ix1 = fromIntegral (ix `mod` 0x100) :: Word8 i0 (WIDE ix0 $ fn ix1) -new :: B.ByteString -> Generate () +new :: Generator g => B.ByteString -> g () new cls = i1 NEW (CClass cls) -newArray :: ArrayType -> Generate () +newArray :: Generator g => ArrayType -> g () newArray t = i0 (NEWARRAY $ atype2byte t) -allocNewArray :: B.ByteString -> Generate () +allocNewArray :: Generator g => B.ByteString -> g () allocNewArray cls = i1 ANEWARRAY (CClass cls) -invokeVirtual :: B.ByteString -> NameType Method -> Generate () +invokeVirtual :: Generator g => B.ByteString -> NameType Method -> g () invokeVirtual cls sig = i1 INVOKEVIRTUAL (CMethod cls sig) -invokeStatic :: B.ByteString -> NameType Method -> Generate () +invokeStatic :: Generator g => B.ByteString -> NameType Method -> g () invokeStatic cls sig = i1 INVOKESTATIC (CMethod cls sig) -invokeSpecial :: B.ByteString -> NameType Method -> Generate () +invokeSpecial :: Generator g => B.ByteString -> NameType Method -> g () invokeSpecial cls sig = i1 INVOKESPECIAL (CMethod cls sig) -getStaticField :: B.ByteString -> NameType Field -> Generate () +getStaticField :: Generator g => B.ByteString -> NameType Field -> g () getStaticField cls sig = i1 GETSTATIC (CField cls sig) -loadString :: B.ByteString -> Generate () +loadString :: Generator g => B.ByteString -> g () loadString str = i8 LDC1 (CString str) -allocArray :: B.ByteString -> Generate () +allocArray :: Generator g => B.ByteString -> g () allocArray cls = i1 ANEWARRAY (CClass cls) diff --git a/JVM/Builder/Monad.hs b/JVM/Builder/Monad.hs index 005492f..1c44e92 100644 --- a/JVM/Builder/Monad.hs +++ b/JVM/Builder/Monad.hs @@ -1,17 +1,18 @@ -{-# LANGUAGE FlexibleContexts, TypeFamilies, OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts, TypeFamilies, OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-} -- | This module defines Generate monad, which helps generating JVM code and -- creating Java class constants pool. module JVM.Builder.Monad (GState (..), emptyGState, - Generate, + Generator (..), + Generate, GenerateIO, addToPool, i0, i1, i8, newMethod, setStackSize, setMaxLocals, withClassPath, getClassField, getClassMethod, - generate + generate, generateIO ) where import Control.Monad.State as St @@ -50,11 +51,19 @@ emptyGState = GState { locals = 0, classPath = []} +class (Monad m, MonadState GState m) => Generator m where + -- | Generate monad -type Generate a = StateT GState IO a +type GenerateIO a = StateT GState IO a + +type Generate a = State GState a + +instance Generator (StateT GState IO) where + +instance Generator (State GState) where -- | Update ClassPath -withClassPath :: ClassPath () -> Generate () +withClassPath :: ClassPath () -> GenerateIO () withClassPath cp = do res <- liftIO $ execClassPath cp st <- St.get @@ -68,7 +77,7 @@ appendPool c pool = in (pool', size) -- | Add a constant to pool -addItem :: Constant Direct -> Generate Word16 +addItem :: (Generator g) => Constant Direct -> g Word16 addItem c = do pool <- St.gets currentPool case lookupPool c pool of @@ -84,7 +93,7 @@ lookupPool :: Constant Direct -> Pool Direct -> Maybe Word16 lookupPool c pool = fromIntegral `fmap` findIndex (== c) (M.elems pool) -addNT :: HasSignature a => NameType a -> Generate Word16 +addNT :: (Generator g, HasSignature a) => NameType a -> g Word16 addNT (NameType name sig) = do let bsig = encode sig x <- addItem (CNameType name bsig) @@ -92,13 +101,13 @@ addNT (NameType name sig) = do addItem (CUTF8 bsig) return x -addSig :: MethodSignature -> Generate Word16 +addSig :: (Generator g) => MethodSignature -> g Word16 addSig c@(MethodSignature args ret) = do let bsig = encode c addItem (CUTF8 bsig) -- | Add a constant into pool -addToPool :: Constant Direct -> Generate Word16 +addToPool :: (Generator g) => Constant Direct -> g Word16 addToPool c@(CClass str) = do addItem (CUTF8 str) addItem c @@ -123,42 +132,42 @@ addToPool c@(CNameType name sig) = do addItem c addToPool c = addItem c -putInstruction :: Instruction -> Generate () +putInstruction :: (Generator g) => Instruction -> g () putInstruction instr = do st <- St.get let code = generated st St.put $ st {generated = code ++ [instr]} -- | Generate one (zero-arguments) instruction -i0 :: Instruction -> Generate () +i0 :: (Generator g) => Instruction -> g () i0 = putInstruction -- | Generate one one-argument instruction -i1 :: (Word16 -> Instruction) -> Constant Direct -> Generate () +i1 :: (Generator g) => (Word16 -> Instruction) -> Constant Direct -> g () i1 fn c = do ix <- addToPool c i0 (fn ix) -- | Generate one one-argument instruction -i8 :: (Word8 -> Instruction) -> Constant Direct -> Generate () +i8 :: (Generator g) => (Word8 -> Instruction) -> Constant Direct -> g () i8 fn c = do ix <- addToPool c i0 (fn $ fromIntegral ix) -- | Set maximum stack size for current method -setStackSize :: Word16 -> Generate () +setStackSize :: (Generator g) => Word16 -> g () setStackSize n = do st <- St.get St.put $ st {stackSize = n} -- | Set maximum number of local variables for current method -setMaxLocals :: Word16 -> Generate () +setMaxLocals :: (Generator g) => Word16 -> g () setMaxLocals n = do st <- St.get St.put $ st {locals = n} -- | Start generating new method -startMethod :: [AccessFlag] -> B.ByteString -> MethodSignature -> Generate () +startMethod :: (Generator g) => [AccessFlag] -> B.ByteString -> MethodSignature -> g () startMethod flags name sig = do addToPool (CString name) addSig sig @@ -175,7 +184,7 @@ startMethod flags name sig = do currentMethod = Just method } -- | End of method generation -endMethod :: Generate () +endMethod :: (Generator g) => g () endMethod = do m <- St.gets currentMethod code <- St.gets genCode @@ -190,12 +199,13 @@ endMethod = do doneMethods = doneMethods st ++ [method']} -- | Generate new method -newMethod :: [AccessFlag] -- ^ Access flags for method (public, static etc) +newMethod :: (Generator g) + => [AccessFlag] -- ^ Access flags for method (public, static etc) -> B.ByteString -- ^ Method name -> [ArgumentSignature] -- ^ Signatures of method arguments -> ReturnSignature -- ^ Method return signature - -> Generate () -- ^ Generator for method code - -> Generate (NameType Method) + -> g () -- ^ Generator for method code + -> g (NameType Method) newMethod flags name args ret gen = do let sig = MethodSignature args ret startMethod flags name sig @@ -204,7 +214,7 @@ newMethod flags name args ret gen = do return (NameType name sig) -- | Get a class from current ClassPath -getClass :: String -> Generate (Class Direct) +getClass :: String -> GenerateIO (Class Direct) getClass name = do cp <- St.gets classPath res <- liftIO $ getEntry cp name @@ -216,7 +226,7 @@ getClass name = do Nothing -> fail $ "No such class in ClassPath: " ++ name -- | Get class field signature from current ClassPath -getClassField :: String -> B.ByteString -> Generate (NameType Field) +getClassField :: String -> B.ByteString -> GenerateIO (NameType Field) getClassField clsName fldName = do cls <- getClass clsName case lookupField fldName cls of @@ -224,7 +234,7 @@ getClassField clsName fldName = do Nothing -> fail $ "No such field in class " ++ clsName ++ ": " ++ toString fldName -- | Get class method signature from current ClassPath -getClassMethod :: String -> B.ByteString -> Generate (NameType Method) +getClassMethod :: String -> B.ByteString -> GenerateIO (NameType Method) getClassMethod clsName mName = do cls <- getClass clsName case lookupMethod mName cls of @@ -246,15 +256,15 @@ genCode st = Code { len = fromIntegral $ B.length $ encodeInstructions (generated st) -- | Start class generation. -initClass :: B.ByteString -> Generate Word16 +initClass :: (Generator g) => B.ByteString -> g Word16 initClass name = do addToPool (CClass "java/lang/Object") addToPool (CClass name) addToPool (CString "Code") -- | Generate a class -generate :: [Tree CPEntry] -> B.ByteString -> Generate () -> IO (Class Direct) -generate cp name gen = do +generateIO :: [Tree CPEntry] -> B.ByteString -> GenerateIO () -> IO (Class Direct) +generateIO cp name gen = do let generator = do initClass name gen @@ -270,3 +280,21 @@ generate cp name gen = do classMethodsCount = fromIntegral $ length (doneMethods res), classMethods = doneMethods res } +-- | Generate a class +generate :: [Tree CPEntry] -> B.ByteString -> Generate () -> Class Direct +generate cp name gen = + let generator = do + initClass name + gen + res = execState generator (emptyGState {classPath = cp}) + code = genCode res + d = defaultClass :: Class Direct + in d { + constsPoolSize = fromIntegral $ M.size (currentPool res), + constsPool = currentPool res, + accessFlags = S.fromList [ACC_PUBLIC, ACC_STATIC], + thisClass = name, + superClass = "java/lang/Object", + classMethodsCount = fromIntegral $ length (doneMethods res), + classMethods = doneMethods res } + diff --git a/JVM/Common.hs b/JVM/Common.hs index 1b0e5eb..301c40c 100644 --- a/JVM/Common.hs +++ b/JVM/Common.hs @@ -8,14 +8,20 @@ module JVM.Common byteString ) where +import Codec.Binary.UTF8.String (encodeString, decodeString) import Data.Binary import Data.Binary.Put import qualified Data.ByteString.Lazy as B import qualified Data.Map as M import Data.Default +import Data.Char +import Data.String import JVM.ClassFile +instance IsString B.ByteString where + fromString s = B.pack $ map (fromIntegral . ord) $ encodeString s + instance Default B.ByteString where def = B.empty diff --git a/JVM/Converter.hs b/JVM/Converter.hs index 0c26dd1..52b3483 100644 --- a/JVM/Converter.hs +++ b/JVM/Converter.hs @@ -18,7 +18,6 @@ import Data.Bits import Data.Binary import Data.Default () -- import instances only import qualified Data.ByteString.Lazy as B -import qualified Data.ByteString.Lazy.Char8 () import qualified Data.Set as S import qualified Data.Map as M diff --git a/TestGen.hs b/TestGen.hs index f21912c..31e71c0 100644 --- a/TestGen.hs +++ b/TestGen.hs @@ -11,7 +11,7 @@ import Java.ClassPath import qualified Java.Lang import qualified Java.IO -test :: Generate () +test :: GenerateIO () test = do withClassPath $ do -- Add current directory (with Hello.class) to ClassPath @@ -63,6 +63,6 @@ test = do main :: IO () main = do - testClass <- generate [] "Test" test + testClass <- generateIO [] "Test" test B.writeFile "Test.class" (encodeClass testClass) -- 2.25.1