1 {-# LANGUAGE FlexibleContexts, TypeFamilies, OverloadedStrings, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, GeneralizedNewtypeDeriving, ScopedTypeVariables #-}
2 -- | This module defines Generate monad, which helps generating JVM code and
3 -- creating Java class constants pool.
4 module JVM.Builder.Monad
12 setStackSize, setMaxLocals,
14 getClassField, getClassMethod,
18 import Prelude hiding (catch)
19 import Control.Monad.State as St
20 import Control.Monad.Exception
24 import qualified Data.Map as M
25 import qualified Data.Set as S
26 import qualified Data.ByteString.Lazy as B
28 import JVM.Common () -- import instances only
35 data GState = GState {
36 generated :: [Instruction], -- ^ Already generated code (in current method)
37 currentPool :: Pool Direct, -- ^ Already generated constants pool
38 doneMethods :: [Method Direct], -- ^ Already generated class methods
39 currentMethod :: Maybe (Method Direct), -- ^ Current method
40 stackSize :: Word16, -- ^ Maximum stack size for current method
41 locals :: Word16, -- ^ Maximum number of local variables for current method
42 classPath :: [Tree CPEntry]
46 -- | Empty generator state
48 emptyGState = GState {
50 currentPool = M.empty,
52 currentMethod = Nothing,
57 class (Monad (g e), MonadState GState (g e)) => Generator e g where
58 throwG :: (Exception x, Throws x e) => x -> g e a
61 newtype Generate e a = Generate {
62 runGenerate :: EMT e (State GState) a }
63 deriving (Monad, MonadState GState)
65 instance MonadState st (EMT e (StateT st IO)) where
67 put x = lift (St.put x)
69 instance MonadState st (EMT e (State st)) where
71 put x = lift (St.put x)
73 -- | IO version of Generate monad
74 newtype GenerateIO e a = GenerateIO {
75 runGenerateIO :: EMT e (StateT GState IO) a }
76 deriving (Monad, MonadState GState, MonadIO)
78 instance MonadIO (EMT e (StateT GState IO)) where
79 liftIO action = lift $ liftIO action
81 instance Generator e GenerateIO where
82 throwG e = GenerateIO (throw e)
84 instance (MonadState GState (EMT e (State GState))) => Generator e Generate where
85 throwG e = Generate (throw e)
87 execGenerateIO cp (GenerateIO emt) = do
88 let caught = emt `catch` (\(e :: SomeException) -> fail $ show e)
89 execStateT (runEMT caught) (emptyGState {classPath = cp})
91 execGenerate cp (Generate emt) = do
92 let caught = emt `catch` (\(e :: SomeException) -> fail $ show e)
93 execState (runEMT caught) (emptyGState {classPath = cp})
96 withClassPath :: ClassPath () -> GenerateIO e ()
98 res <- liftIO $ execClassPath cp
100 St.put $ st {classPath = res}
102 -- | Append a constant to pool
103 appendPool :: Constant Direct -> Pool Direct -> (Pool Direct, Word16)
105 let size = fromIntegral (M.size pool)
106 pool' = M.insert size c pool
109 -- | Add a constant to pool
110 addItem :: (Generator e g) => Constant Direct -> g e Word16
112 pool <- St.gets currentPool
113 case lookupPool c pool of
114 Just i -> return (i+1)
116 let (pool', i) = appendPool c pool
118 St.put $ st {currentPool = pool'}
121 -- | Lookup in a pool
122 lookupPool :: Constant Direct -> Pool Direct -> Maybe Word16
124 fromIntegral `fmap` findIndex (== c) (M.elems pool)
126 addNT :: (Generator e g, HasSignature a) => NameType a -> g e Word16
127 addNT (NameType name sig) = do
128 let bsig = encode sig
129 x <- addItem (CNameType name bsig)
134 addSig :: (Generator e g) => MethodSignature -> g e Word16
135 addSig c@(MethodSignature args ret) = do
139 -- | Add a constant into pool
140 addToPool :: (Generator e g) => Constant Direct -> g e Word16
141 addToPool c@(CClass str) = do
144 addToPool c@(CField cls name) = do
145 addToPool (CClass cls)
148 addToPool c@(CMethod cls name) = do
149 addToPool (CClass cls)
152 addToPool c@(CIfaceMethod cls name) = do
153 addToPool (CClass cls)
156 addToPool c@(CString str) = do
157 addToPool (CUTF8 str)
159 addToPool c@(CNameType name sig) = do
163 addToPool c = addItem c
165 putInstruction :: (Generator e g) => Instruction -> g e ()
166 putInstruction instr = do
168 let code = generated st
169 St.put $ st {generated = code ++ [instr]}
171 -- | Generate one (zero-arguments) instruction
172 i0 :: (Generator e g) => Instruction -> g e ()
175 -- | Generate one one-argument instruction
176 i1 :: (Generator e g) => (Word16 -> Instruction) -> Constant Direct -> g e ()
181 -- | Generate one one-argument instruction
182 i8 :: (Generator e g) => (Word8 -> Instruction) -> Constant Direct -> g e ()
185 i0 (fn $ fromIntegral ix)
187 -- | Set maximum stack size for current method
188 setStackSize :: (Generator e g) => Word16 -> g e ()
191 St.put $ st {stackSize = n}
193 -- | Set maximum number of local variables for current method
194 setMaxLocals :: (Generator e g) => Word16 -> g e ()
197 St.put $ st {locals = n}
199 -- | Start generating new method
200 startMethod :: (Generator e g) => [AccessFlag] -> B.ByteString -> MethodSignature -> g e ()
201 startMethod flags name sig = do
202 addToPool (CString name)
207 let method = Method {
208 methodAccessFlags = S.fromList flags,
210 methodSignature = sig,
211 methodAttributesCount = 0,
212 methodAttributes = AR M.empty }
213 St.put $ st {generated = [],
214 currentMethod = Just method }
216 -- | End of method generation
217 endMethod :: (Generator e g, Throws UnexpectedEndMethod e) => g e ()
219 m <- St.gets currentMethod
220 code <- St.gets genCode
222 Nothing -> throwG UnexpectedEndMethod
224 let method' = method {methodAttributes = AR $ M.fromList [("Code", encodeMethod code)],
225 methodAttributesCount = 1}
227 St.put $ st {generated = [],
228 currentMethod = Nothing,
229 doneMethods = doneMethods st ++ [method']}
231 -- | Generate new method
232 newMethod :: (Generator e g, Throws UnexpectedEndMethod e)
233 => [AccessFlag] -- ^ Access flags for method (public, static etc)
234 -> B.ByteString -- ^ Method name
235 -> [ArgumentSignature] -- ^ Signatures of method arguments
236 -> ReturnSignature -- ^ Method return signature
237 -> g e () -- ^ Generator for method code
238 -> g e (NameType Method)
239 newMethod flags name args ret gen = do
240 let sig = MethodSignature args ret
241 startMethod flags name sig
244 return (NameType name sig)
246 -- | Get a class from current ClassPath
247 getClass :: (Throws ENotLoaded e, Throws ENotFound e)
248 => String -> GenerateIO e (Class Direct)
250 cp <- St.gets classPath
251 res <- liftIO $ getEntry cp name
253 Just (NotLoaded p) -> throwG (ClassFileNotLoaded p)
254 Just (Loaded _ c) -> return c
255 Just (NotLoadedJAR p c) -> throwG (JARNotLoaded p c)
256 Just (LoadedJAR _ c) -> return c
257 Nothing -> throwG (ClassNotFound name)
259 -- | Get class field signature from current ClassPath
260 getClassField :: (Throws ENotFound e, Throws ENotLoaded e)
261 => String -> B.ByteString -> GenerateIO e (NameType Field)
262 getClassField clsName fldName = do
263 cls <- getClass clsName
264 case lookupField fldName cls of
265 Just fld -> return (fieldNameType fld)
266 Nothing -> throwG (FieldNotFound clsName fldName)
268 -- | Get class method signature from current ClassPath
269 getClassMethod :: (Throws ENotFound e, Throws ENotLoaded e)
270 => String -> B.ByteString -> GenerateIO e (NameType Method)
271 getClassMethod clsName mName = do
272 cls <- getClass clsName
273 case lookupMethod mName cls of
274 Just m -> return (methodNameType m)
275 Nothing -> throwG (MethodNotFound clsName mName)
277 -- | Convert Generator state to method Code.
278 genCode :: GState -> Code
280 codeStackSize = stackSize st,
281 codeMaxLocals = locals st,
283 codeInstructions = generated st,
287 codeAttributes = AP [] }
289 len = fromIntegral $ B.length $ encodeInstructions (generated st)
291 -- | Start class generation.
292 initClass :: (Generator e g) => B.ByteString -> g e Word16
294 addToPool (CClass "java/lang/Object")
295 addToPool (CClass name)
296 addToPool (CString "Code")
298 -- | Generate a class
299 generateIO cp name gen = do
303 res <- execGenerateIO cp generator
304 let code = genCode res
305 d = defaultClass :: Class Direct
307 constsPoolSize = fromIntegral $ M.size (currentPool res),
308 constsPool = currentPool res,
309 accessFlags = S.fromList [ACC_PUBLIC, ACC_STATIC],
311 superClass = "java/lang/Object",
312 classMethodsCount = fromIntegral $ length (doneMethods res),
313 classMethods = doneMethods res }
315 -- | Generate a class
316 generate cp name gen =
320 res = execGenerate cp generator
322 d = defaultClass :: Class Direct
324 constsPoolSize = fromIntegral $ M.size (currentPool res),
325 constsPool = currentPool res,
326 accessFlags = S.fromList [ACC_PUBLIC, ACC_STATIC],
328 superClass = "java/lang/Object",
329 classMethodsCount = fromIntegral $ length (doneMethods res),
330 classMethods = doneMethods res }