-{-# 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)
emptyGState = GState {
generated = [],
currentPool = M.empty,
+ nextPoolIndex = 1,
doneMethods = [],
currentMethod = Nothing,
stackSize = 496,
- locals = 0 }
+ 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 = State GState 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)
--- | 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)
+instance (MonadState GState (EMT e (State GState))) => Generator e Generate where
+ throwG e = Generate (throw e)
+
+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}
-- | 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)
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
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
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}
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
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 {
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 :: B.ByteString -> Generate () -> Class Direct
-generate name gen =
+generateIO :: [Tree CPEntry]
+ -> B.ByteString
+ -> GenerateIO (Caught SomeException NoExceptions) ()
+ -> IO (Class Direct)
+generateIO cp name gen = do
+ let generator = do
+ initClass name
+ gen
+ res <- execGenerateIO cp generator
+ 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",
+ 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 = execState generator emptyGState
+ res = execGenerate cp generator
code = genCode res
- in Class {
- magic = 0xCAFEBABE,
- minorVersion = 0,
- majorVersion = 50,
+ 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",
- interfacesCount = 0,
- interfaces = [],
- classFieldsCount = 0,
- classFields = [],
classMethodsCount = fromIntegral $ length (doneMethods res),
- classMethods = doneMethods res,
- classAttributesCount = 0,
- classAttributes = AR M.empty }
+ classMethods = doneMethods res }
projects / hs-java.git / blobdiff