X-Git-Url: http://wien.tomnetworks.com/gitweb/?a=blobdiff_plain;f=JVM%2FBuilder%2FMonad.hs;h=b8c74583fc8825b6b4d34f4f0ac70ae4eb5d6702;hb=6c8dd0363f7b6231715cc608637fea83aac7cfa7;hp=f5b1d74dbb2b081f99c8f14663502923270e830e;hpb=22d4ad212c27135cea11b577c62f7d133d392d4e;p=hs-java.git diff --git a/JVM/Builder/Monad.hs b/JVM/Builder/Monad.hs index f5b1d74..b8c7458 100644 --- a/JVM/Builder/Monad.hs +++ b/JVM/Builder/Monad.hs @@ -1,38 +1,51 @@ -{-# LANGUAGE FlexibleContexts, TypeFamilies, OverloadedStrings #-} --- | This module defines Generate monad, which helps generating JVM code and +{-# LANGUAGE FlexibleContexts, TypeFamilies, OverloadedStrings, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, GeneralizedNewtypeDeriving, ScopedTypeVariables #-} +-- | This module defines Generate[IO] monad, which helps generating JVM code and -- creating Java class constants pool. +-- +-- Code generation could be done using one of two monads: Generate and GenerateIO. +-- Generate monad is pure (simply State monad), while GenerateIO is IO-related. +-- In GenerateIO additional actions are available, such as setting up ClassPath +-- and loading classes (from .class files or JAR archives). +-- module JVM.Builder.Monad (GState (..), emptyGState, - Generate, + Generator (..), + Generate, GenerateIO, addToPool, i0, i1, i8, newMethod, setStackSize, setMaxLocals, - generate + withClassPath, + getClassField, getClassMethod, + generate, generateIO ) where +import Prelude hiding (catch) import Control.Monad.State as St +import Control.Monad.Exception +import Control.Monad.Exception.Base import Data.Word -import Data.List import Data.Binary import qualified Data.Map as M import qualified Data.Set as S import qualified Data.ByteString.Lazy as B -import JVM.Common () -- import instances only +import JVM.Common import JVM.ClassFile import JVM.Assembler +import JVM.Exceptions import Java.ClassPath -- | Generator state data GState = GState { - generated :: [Instruction], -- ^ Already generated code (in current method) + generated :: [Instruction], -- ^ Already generated code (in current method) currentPool :: Pool Direct, -- ^ Already generated constants pool + nextPoolIndex :: Word16, -- ^ Next index to be used in 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 + stackSize :: Word16, -- ^ Maximum stack size for current method + locals :: Word16, -- ^ Maximum number of local variables for current method classPath :: [Tree CPEntry] } deriving (Eq,Show) @@ -42,46 +55,87 @@ emptyGState :: GState emptyGState = GState { generated = [], currentPool = M.empty, + nextPoolIndex = 1, doneMethods = [], currentMethod = Nothing, stackSize = 496, locals = 0, classPath = []} +class (Monad (g e), MonadState GState (g e)) => Generator e g where + throwG :: (Exception x, Throws x e) => x -> g e a + -- | Generate monad -type Generate a = StateT GState IO a +newtype Generate e a = Generate { + runGenerate :: EMT e (State GState) a } + deriving (Monad, MonadState GState) + +instance MonadState st (EMT e (StateT st IO)) where + get = lift St.get + put x = lift (St.put x) + +instance MonadState st (EMT e (State st)) where + get = lift St.get + put x = lift (St.put x) + +-- | IO version of Generate monad +newtype GenerateIO e a = GenerateIO { + runGenerateIO :: EMT e (StateT GState IO) a } + deriving (Monad, MonadState GState, MonadIO) + +instance MonadIO (EMT e (StateT GState IO)) where + liftIO action = lift $ liftIO action + +instance Generator e GenerateIO where + throwG e = GenerateIO (throw e) + +instance (MonadState GState (EMT e (State GState))) => Generator e Generate where + throwG e = Generate (throw e) -withClassPath :: ClassPath () -> Generate () +execGenerateIO :: [Tree CPEntry] + -> GenerateIO (Caught SomeException NoExceptions) a + -> IO GState +execGenerateIO cp (GenerateIO emt) = do + let caught = emt `catch` (\(e :: SomeException) -> fail $ show e) + execStateT (runEMT caught) (emptyGState {classPath = cp}) + +execGenerate :: [Tree CPEntry] + -> Generate (Caught SomeException NoExceptions) a + -> GState +execGenerate cp (Generate emt) = do + let caught = emt `catch` (\(e :: SomeException) -> fail $ show e) + execState (runEMT caught) (emptyGState {classPath = cp}) + +-- | Update ClassPath +withClassPath :: ClassPath () -> GenerateIO e () 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) - -- | Add a constant to pool -addItem :: Constant Direct -> Generate Word16 +addItem :: (Generator e g) => Constant Direct -> g e Word16 addItem c = do pool <- St.gets currentPool case lookupPool c pool of - Just i -> return (i+1) + Just i -> return i Nothing -> do - let (pool', i) = appendPool c pool + i <- St.gets nextPoolIndex + let pool' = M.insert i c pool + i' = if long c + then i+2 + else i+1 st <- St.get - St.put $ st {currentPool = pool'} - return (i+1) + St.put $ st {currentPool = pool', + nextPoolIndex = i'} + return i -- | Lookup in a pool lookupPool :: Constant Direct -> Pool Direct -> Maybe Word16 lookupPool c pool = - fromIntegral `fmap` findIndex (== c) (M.elems pool) + fromIntegral `fmap` mapFindIndex (== c) pool -addNT :: HasSignature a => NameType a -> Generate Word16 +addNT :: (Generator e g, HasSignature a) => NameType a -> g e Word16 addNT (NameType name sig) = do let bsig = encode sig x <- addItem (CNameType name bsig) @@ -89,13 +143,13 @@ addNT (NameType name sig) = do addItem (CUTF8 bsig) return x -addSig :: MethodSignature -> Generate Word16 +addSig :: (Generator e g) => MethodSignature -> g e 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 e g) => Constant Direct -> g e Word16 addToPool c@(CClass str) = do addItem (CUTF8 str) addItem c @@ -120,42 +174,42 @@ addToPool c@(CNameType name sig) = do addItem c addToPool c = addItem c -putInstruction :: Instruction -> Generate () +putInstruction :: (Generator e g) => Instruction -> g e () 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 e g) => Instruction -> g e () i0 = putInstruction -- | Generate one one-argument instruction -i1 :: (Word16 -> Instruction) -> Constant Direct -> Generate () +i1 :: (Generator e g) => (Word16 -> Instruction) -> Constant Direct -> g e () i1 fn c = do ix <- addToPool c i0 (fn ix) -- | Generate one one-argument instruction -i8 :: (Word8 -> Instruction) -> Constant Direct -> Generate () +i8 :: (Generator e g) => (Word8 -> Instruction) -> Constant Direct -> g e () i8 fn c = do ix <- addToPool c i0 (fn $ fromIntegral ix) -- | Set maximum stack size for current method -setStackSize :: Word16 -> Generate () +setStackSize :: (Generator e g) => Word16 -> g e () 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 e g) => Word16 -> g e () setMaxLocals n = do st <- St.get St.put $ st {locals = n} -- | Start generating new method -startMethod :: [AccessFlag] -> B.ByteString -> MethodSignature -> Generate () +startMethod :: (Generator e g) => [AccessFlag] -> B.ByteString -> MethodSignature -> g e () startMethod flags name sig = do addToPool (CString name) addSig sig @@ -172,12 +226,12 @@ startMethod flags name sig = do currentMethod = Just method } -- | End of method generation -endMethod :: Generate () +endMethod :: (Generator e g, Throws UnexpectedEndMethod e) => g e () endMethod = do m <- St.gets currentMethod code <- St.gets genCode case m of - Nothing -> fail "endMethod without startMethod!" + Nothing -> throwG UnexpectedEndMethod Just method -> do let method' = method {methodAttributes = AR $ M.fromList [("Code", encodeMethod code)], methodAttributesCount = 1} @@ -187,12 +241,13 @@ endMethod = do doneMethods = doneMethods st ++ [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 :: (Generator e g, Throws UnexpectedEndMethod e) + => [AccessFlag] -- ^ Access flags for method (public, static etc) + -> B.ByteString -- ^ Method name + -> [ArgumentSignature] -- ^ Signatures of method arguments + -> ReturnSignature -- ^ Method return signature + -> g e () -- ^ Generator for method code + -> g e (NameType Method) newMethod flags name args ret gen = do let sig = MethodSignature args ret startMethod flags name sig @@ -200,6 +255,37 @@ newMethod flags name args ret gen = do endMethod return (NameType name sig) +-- | Get a class from current ClassPath +getClass :: (Throws ENotLoaded e, Throws ENotFound e) + => String -> GenerateIO e (Class Direct) +getClass name = do + cp <- St.gets classPath + res <- liftIO $ getEntry cp name + case res of + Just (NotLoaded p) -> throwG (ClassFileNotLoaded p) + Just (Loaded _ c) -> return c + Just (NotLoadedJAR p c) -> throwG (JARNotLoaded p c) + Just (LoadedJAR _ c) -> return c + Nothing -> throwG (ClassNotFound name) + +-- | Get class field signature from current ClassPath +getClassField :: (Throws ENotFound e, Throws ENotLoaded e) + => String -> B.ByteString -> GenerateIO e (NameType Field) +getClassField clsName fldName = do + cls <- getClass clsName + case lookupField fldName cls of + Just fld -> return (fieldNameType fld) + Nothing -> throwG (FieldNotFound clsName fldName) + +-- | Get class method signature from current ClassPath +getClassMethod :: (Throws ENotFound e, Throws ENotLoaded e) + => String -> B.ByteString -> GenerateIO e (NameType Method) +getClassMethod clsName mName = do + cls <- getClass clsName + case lookupMethod mName cls of + Just m -> return (methodNameType m) + Nothing -> throwG (MethodNotFound clsName mName) + -- | Convert Generator state to method Code. genCode :: GState -> Code genCode st = Code { @@ -215,21 +301,22 @@ genCode st = Code { len = fromIntegral $ B.length $ encodeInstructions (generated st) -- | Start class generation. -initClass :: B.ByteString -> Generate Word16 +initClass :: (Generator e g) => B.ByteString -> g e 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 (Caught SomeException NoExceptions) () + -> IO (Class Direct) +generateIO cp name gen = do let generator = do initClass name - st <- St.get - St.put $ st {classPath = cp} gen - res <- execStateT generator emptyGState + res <- execGenerateIO cp generator let code = genCode res d = defaultClass :: Class Direct return $ d { @@ -241,3 +328,24 @@ generate cp name gen = do classMethodsCount = fromIntegral $ length (doneMethods res), classMethods = doneMethods res } +-- | Generate a class +generate :: [Tree CPEntry] + -> B.ByteString + -> Generate (Caught SomeException NoExceptions) () + -> Class Direct +generate cp name gen = + let generator = do + initClass name + gen + res = execGenerate cp generator + 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 } +