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
23 import qualified Data.Map as M
24 import qualified Data.Set as S
25 import qualified Data.ByteString.Lazy as B
34 data GState = GState {
35 generated :: [Instruction], -- ^ Already generated code (in current method)
36 currentPool :: Pool Direct, -- ^ Already generated constants pool
37 doneMethods :: [Method Direct], -- ^ Already generated class methods
38 currentMethod :: Maybe (Method Direct), -- ^ Current method
39 stackSize :: Word16, -- ^ Maximum stack size for current method
40 locals :: Word16, -- ^ Maximum number of local variables for current method
41 classPath :: [Tree CPEntry]
45 -- | Empty generator state
47 emptyGState = GState {
49 currentPool = M.empty,
51 currentMethod = Nothing,
56 class (Monad (g e), MonadState GState (g e)) => Generator e g where
57 throwG :: (Exception x, Throws x e) => x -> g e a
60 newtype Generate e a = Generate {
61 runGenerate :: EMT e (State GState) a }
62 deriving (Monad, MonadState GState)
64 instance MonadState st (EMT e (StateT st IO)) where
66 put x = lift (St.put x)
68 instance MonadState st (EMT e (State st)) where
70 put x = lift (St.put x)
72 -- | IO version of Generate monad
73 newtype GenerateIO e a = GenerateIO {
74 runGenerateIO :: EMT e (StateT GState IO) a }
75 deriving (Monad, MonadState GState, MonadIO)
77 instance MonadIO (EMT e (StateT GState IO)) where
78 liftIO action = lift $ liftIO action
80 instance Generator e GenerateIO where
81 throwG e = GenerateIO (throw e)
83 instance (MonadState GState (EMT e (State GState))) => Generator e Generate where
84 throwG e = Generate (throw e)
86 execGenerateIO cp (GenerateIO emt) = do
87 let caught = emt `catch` (\(e :: SomeException) -> fail $ show e)
88 execStateT (runEMT caught) (emptyGState {classPath = cp})
90 execGenerate cp (Generate emt) = do
91 let caught = emt `catch` (\(e :: SomeException) -> fail $ show e)
92 execState (runEMT caught) (emptyGState {classPath = cp})
95 withClassPath :: ClassPath () -> GenerateIO e ()
97 res <- liftIO $ execClassPath cp
99 St.put $ st {classPath = res}
101 -- | Append a constant to pool
102 appendPool :: Constant Direct -> Pool Direct -> (Pool Direct, Word16)
104 let ix = if M.null pool then 1 else maximum (M.keys pool) + 1
105 pool' = M.insert ix c pool
108 -- | Add a constant to pool
109 addItem :: (Generator e g) => Constant Direct -> g e Word16
111 pool <- St.gets currentPool
112 case lookupPool c pool of
115 let (pool', i) = appendPool c pool
117 St.put $ st {currentPool = pool'}
120 -- | Lookup in a pool
121 lookupPool :: Constant Direct -> Pool Direct -> Maybe Word16
123 fromIntegral `fmap` mapFindIndex (== c) pool
125 addNT :: (Generator e g, HasSignature a) => NameType a -> g e Word16
126 addNT (NameType name sig) = do
127 let bsig = encode sig
128 x <- addItem (CNameType name bsig)
133 addSig :: (Generator e g) => MethodSignature -> g e Word16
134 addSig c@(MethodSignature args ret) = do
138 -- | Add a constant into pool
139 addToPool :: (Generator e g) => Constant Direct -> g e Word16
140 addToPool c@(CClass str) = do
143 addToPool c@(CField cls name) = do
144 addToPool (CClass cls)
147 addToPool c@(CMethod cls name) = do
148 addToPool (CClass cls)
151 addToPool c@(CIfaceMethod cls name) = do
152 addToPool (CClass cls)
155 addToPool c@(CString str) = do
156 addToPool (CUTF8 str)
158 addToPool c@(CNameType name sig) = do
162 addToPool c = addItem c
164 putInstruction :: (Generator e g) => Instruction -> g e ()
165 putInstruction instr = do
167 let code = generated st
168 St.put $ st {generated = code ++ [instr]}
170 -- | Generate one (zero-arguments) instruction
171 i0 :: (Generator e g) => Instruction -> g e ()
174 -- | Generate one one-argument instruction
175 i1 :: (Generator e g) => (Word16 -> Instruction) -> Constant Direct -> g e ()
180 -- | Generate one one-argument instruction
181 i8 :: (Generator e g) => (Word8 -> Instruction) -> Constant Direct -> g e ()
184 i0 (fn $ fromIntegral ix)
186 -- | Set maximum stack size for current method
187 setStackSize :: (Generator e g) => Word16 -> g e ()
190 St.put $ st {stackSize = n}
192 -- | Set maximum number of local variables for current method
193 setMaxLocals :: (Generator e g) => Word16 -> g e ()
196 St.put $ st {locals = n}
198 -- | Start generating new method
199 startMethod :: (Generator e g) => [AccessFlag] -> B.ByteString -> MethodSignature -> g e ()
200 startMethod flags name sig = do
201 addToPool (CString name)
206 let method = Method {
207 methodAccessFlags = S.fromList flags,
209 methodSignature = sig,
210 methodAttributesCount = 0,
211 methodAttributes = AR M.empty }
212 St.put $ st {generated = [],
213 currentMethod = Just method }
215 -- | End of method generation
216 endMethod :: (Generator e g, Throws UnexpectedEndMethod e) => g e ()
218 m <- St.gets currentMethod
219 code <- St.gets genCode
221 Nothing -> throwG UnexpectedEndMethod
223 let method' = method {methodAttributes = AR $ M.fromList [("Code", encodeMethod code)],
224 methodAttributesCount = 1}
226 St.put $ st {generated = [],
227 currentMethod = Nothing,
228 doneMethods = doneMethods st ++ [method']}
230 -- | Generate new method
231 newMethod :: (Generator e g, Throws UnexpectedEndMethod e)
232 => [AccessFlag] -- ^ Access flags for method (public, static etc)
233 -> B.ByteString -- ^ Method name
234 -> [ArgumentSignature] -- ^ Signatures of method arguments
235 -> ReturnSignature -- ^ Method return signature
236 -> g e () -- ^ Generator for method code
237 -> g e (NameType Method)
238 newMethod flags name args ret gen = do
239 let sig = MethodSignature args ret
240 startMethod flags name sig
243 return (NameType name sig)
245 -- | Get a class from current ClassPath
246 getClass :: (Throws ENotLoaded e, Throws ENotFound e)
247 => String -> GenerateIO e (Class Direct)
249 cp <- St.gets classPath
250 res <- liftIO $ getEntry cp name
252 Just (NotLoaded p) -> throwG (ClassFileNotLoaded p)
253 Just (Loaded _ c) -> return c
254 Just (NotLoadedJAR p c) -> throwG (JARNotLoaded p c)
255 Just (LoadedJAR _ c) -> return c
256 Nothing -> throwG (ClassNotFound name)
258 -- | Get class field signature from current ClassPath
259 getClassField :: (Throws ENotFound e, Throws ENotLoaded e)
260 => String -> B.ByteString -> GenerateIO e (NameType Field)
261 getClassField clsName fldName = do
262 cls <- getClass clsName
263 case lookupField fldName cls of
264 Just fld -> return (fieldNameType fld)
265 Nothing -> throwG (FieldNotFound clsName fldName)
267 -- | Get class method signature from current ClassPath
268 getClassMethod :: (Throws ENotFound e, Throws ENotLoaded e)
269 => String -> B.ByteString -> GenerateIO e (NameType Method)
270 getClassMethod clsName mName = do
271 cls <- getClass clsName
272 case lookupMethod mName cls of
273 Just m -> return (methodNameType m)
274 Nothing -> throwG (MethodNotFound clsName mName)
276 -- | Convert Generator state to method Code.
277 genCode :: GState -> Code
279 codeStackSize = stackSize st,
280 codeMaxLocals = locals st,
282 codeInstructions = generated st,
286 codeAttributes = AP [] }
288 len = fromIntegral $ B.length $ encodeInstructions (generated st)
290 -- | Start class generation.
291 initClass :: (Generator e g) => B.ByteString -> g e Word16
293 addToPool (CClass "java/lang/Object")
294 addToPool (CClass name)
295 addToPool (CString "Code")
297 -- | Generate a class
298 generateIO cp name gen = do
302 res <- execGenerateIO cp generator
303 let code = genCode res
304 d = defaultClass :: Class Direct
306 constsPoolSize = fromIntegral $ M.size (currentPool res),
307 constsPool = currentPool res,
308 accessFlags = S.fromList [ACC_PUBLIC, ACC_STATIC],
310 superClass = "java/lang/Object",
311 classMethodsCount = fromIntegral $ length (doneMethods res),
312 classMethods = doneMethods res }
314 -- | Generate a class
315 generate cp name gen =
319 res = execGenerate cp generator
321 d = defaultClass :: Class Direct
323 constsPoolSize = fromIntegral $ M.size (currentPool res),
324 constsPool = currentPool res,
325 accessFlags = S.fromList [ACC_PUBLIC, ACC_STATIC],
327 superClass = "java/lang/Object",
328 classMethodsCount = fromIntegral $ length (doneMethods res),
329 classMethods = doneMethods res }