X-Git-Url: http://wien.tomnetworks.com/gitweb/?a=blobdiff_plain;f=JVM%2FBuilder%2FMonad.hs;h=623a44e2c2c3a3bbd8c2e39cc2c19f06f9dd8e44;hb=c6d4e51116f1ca78ecbbbc4ce422fb33ce25ad19;hp=85916e29c85de454b93a55690415c8af33d50ac5;hpb=e15d36946e3bff9b68576cb16a49ee9f90f62956;p=hs-java.git diff --git a/JVM/Builder/Monad.hs b/JVM/Builder/Monad.hs index 85916e2..623a44e 100644 --- a/JVM/Builder/Monad.hs +++ b/JVM/Builder/Monad.hs @@ -1,5 +1,18 @@ {-# LANGUAGE FlexibleContexts, TypeFamilies, OverloadedStrings #-} -module JVM.Builder.Monad where +-- | This module defines Generate monad, which helps generating JVM code and +-- creating Java class constants pool. +module JVM.Builder.Monad + (GState (..), + emptyGState, + Generate, + addToPool, + i0, i1, i8, + newMethod, + setStackSize, setMaxLocals, + withClassPath, + getClassField, getClassMethod, + generate + ) where import Control.Monad.State as St import Data.Word @@ -12,29 +25,49 @@ import qualified Data.ByteString.Lazy as B import JVM.Common () -- import instances only import JVM.ClassFile import JVM.Assembler +import Java.ClassPath +-- | Generator state data GState = GState { - generated :: [Instruction], - currentPool :: Pool Resolved, - doneMethods :: [Method Resolved], - currentMethod :: Maybe (Method Resolved)} + generated :: [Instruction], -- ^ Already generated code (in current method) + currentPool :: Pool Direct, -- ^ Already generated constants pool + doneMethods :: [Method Direct], -- ^ Already generated class methods + currentMethod :: Maybe (Method Direct), -- ^ Current method + stackSize :: Word16, -- ^ Maximum stack size for current method + locals :: Word16, -- ^ Maximum number of local variables for current method + classPath :: [Tree CPEntry] + } deriving (Eq,Show) +-- | Empty generator state +emptyGState :: GState emptyGState = GState { generated = [], currentPool = M.empty, doneMethods = [], - currentMethod = Nothing } + currentMethod = Nothing, + stackSize = 496, + locals = 0, + classPath = []} -type Generate a = State GState a +-- | Generate monad +type Generate a = StateT GState IO a -appendPool :: Constant Resolved -> Pool Resolved -> (Pool Resolved, Word16) +withClassPath :: ClassPath () -> Generate () +withClassPath cp = do + res <- liftIO $ execClassPath cp + st <- St.get + St.put $ st {classPath = res} + +-- | Append a constant to pool +appendPool :: Constant Direct -> Pool Direct -> (Pool Direct, Word16) appendPool c pool = let size = fromIntegral (M.size pool) pool' = M.insert size c pool in (pool', size) -addItem :: Constant Resolved -> Generate Word16 +-- | Add a constant to pool +addItem :: Constant Direct -> Generate Word16 addItem c = do pool <- St.gets currentPool case lookupPool c pool of @@ -45,11 +78,12 @@ addItem c = do St.put $ st {currentPool = pool'} return (i+1) -lookupPool :: Constant Resolved -> Pool Resolved -> Maybe Word16 +-- | Lookup in a pool +lookupPool :: Constant Direct -> Pool Direct -> Maybe Word16 lookupPool c pool = fromIntegral `fmap` findIndex (== c) (M.elems pool) -addNT :: Binary (Signature a) => NameType a -> Generate Word16 +addNT :: HasSignature a => NameType a -> Generate Word16 addNT (NameType name sig) = do let bsig = encode sig x <- addItem (CNameType name bsig) @@ -62,7 +96,8 @@ addSig c@(MethodSignature args ret) = do let bsig = encode c addItem (CUTF8 bsig) -addToPool :: Constant Resolved -> Generate Word16 +-- | Add a constant into pool +addToPool :: Constant Direct -> Generate Word16 addToPool c@(CClass str) = do addItem (CUTF8 str) addItem c @@ -93,23 +128,41 @@ putInstruction instr = do let code = generated st St.put $ st {generated = code ++ [instr]} +-- | Generate one (zero-arguments) instruction i0 :: Instruction -> Generate () i0 = putInstruction -i1 :: (Word16 -> Instruction) -> Constant Resolved -> Generate () +-- | Generate one one-argument instruction +i1 :: (Word16 -> Instruction) -> Constant Direct -> Generate () i1 fn c = do ix <- addToPool c i0 (fn ix) -i8 :: (Word8 -> Instruction) -> Constant Resolved -> Generate () +-- | Generate one one-argument instruction +i8 :: (Word8 -> Instruction) -> Constant Direct -> Generate () i8 fn c = do ix <- addToPool c i0 (fn $ fromIntegral ix) +-- | Set maximum stack size for current method +setStackSize :: Word16 -> Generate () +setStackSize n = do + st <- St.get + St.put $ st {stackSize = n} + +-- | Set maximum number of local variables for current method +setMaxLocals :: Word16 -> Generate () +setMaxLocals n = do + st <- St.get + St.put $ st {locals = n} + +-- | Start generating new method startMethod :: [AccessFlag] -> B.ByteString -> MethodSignature -> Generate () startMethod flags name sig = do addToPool (CString name) addSig sig + setStackSize 4096 + setMaxLocals 100 st <- St.get let method = Method { methodAccessFlags = S.fromList flags, @@ -120,6 +173,7 @@ startMethod flags name sig = do St.put $ st {generated = [], currentMethod = Just method } +-- | End of method generation endMethod :: Generate () endMethod = do m <- St.gets currentMethod @@ -134,7 +188,13 @@ endMethod = do currentMethod = Nothing, doneMethods = doneMethods st ++ [method']} -newMethod :: [AccessFlag] -> B.ByteString -> [ArgumentSignature] -> ReturnSignature -> Generate () -> Generate (NameType Method) +-- | Generate new method +newMethod :: [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) newMethod flags name args ret gen = do let sig = MethodSignature args ret startMethod flags name sig @@ -142,10 +202,36 @@ newMethod flags name args ret gen = do endMethod return (NameType name sig) +getClass :: String -> Generate (Class Direct) +getClass name = do + cp <- St.gets classPath + res <- liftIO $ getEntry cp name + case res of + Just (NotLoaded p) -> fail $ "Class file was not loaded: " ++ p + Just (Loaded _ c) -> return c + Just (NotLoadedJAR p c) -> fail $ "Class was not loaded from JAR " ++ p ++ ": " ++ c + Just (LoadedJAR _ c) -> return c + Nothing -> fail $ "No such class in ClassPath: " ++ name + +getClassField :: String -> B.ByteString -> Generate (NameType Field) +getClassField clsName fldName = do + cls <- getClass clsName + case lookupField fldName cls of + Just fld -> return (fieldNameType fld) + Nothing -> fail $ "No such field in class " ++ clsName ++ ": " ++ toString fldName + +getClassMethod :: String -> B.ByteString -> Generate (NameType Method) +getClassMethod clsName mName = do + cls <- getClass clsName + case lookupMethod mName cls of + Just m -> return (methodNameType m) + Nothing -> fail $ "No such method in class " ++ clsName ++ ": " ++ toString mName + +-- | Convert Generator state to method Code. genCode :: GState -> Code genCode st = Code { - codeStackSize = 4096, - codeMaxLocals = 100, + codeStackSize = stackSize st, + codeMaxLocals = locals st, codeLength = len, codeInstructions = generated st, codeExceptionsN = 0, @@ -155,34 +241,30 @@ genCode st = Code { where len = fromIntegral $ B.length $ encodeInstructions (generated st) +-- | Start class generation. initClass :: B.ByteString -> Generate Word16 initClass name = do addToPool (CClass "java/lang/Object") addToPool (CClass name) addToPool (CString "Code") -generate :: B.ByteString -> Generate () -> Class Resolved -generate name gen = +-- | Generate a class +generate :: [Tree CPEntry] -> B.ByteString -> Generate () -> IO (Class Direct) +generate cp name gen = do let generator = do initClass name + st <- St.get + St.put $ st {classPath = cp} gen - res = execState generator emptyGState - code = genCode res - in Class { - magic = 0xCAFEBABE, - minorVersion = 0, - majorVersion = 50, + res <- execStateT generator emptyGState + let code = genCode res + d = defaultClass :: Class Direct + return $ d { constsPoolSize = fromIntegral $ M.size (currentPool res), constsPool = currentPool res, accessFlags = S.fromList [ACC_PUBLIC, ACC_STATIC], thisClass = name, superClass = "java/lang/Object", - interfacesCount = 0, - interfaces = [], - classFieldsCount = 0, - classFields = [], classMethodsCount = fromIntegral $ length (doneMethods res), - classMethods = doneMethods res, - classAttributesCount = 0, - classAttributes = AR M.empty } + classMethods = doneMethods res }