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 nextPoolIndex :: Word16,
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,
53 currentMethod = Nothing,
58 class (Monad (g e), MonadState GState (g e)) => Generator e g where
59 throwG :: (Exception x, Throws x e) => x -> g e a
62 newtype Generate e a = Generate {
63 runGenerate :: EMT e (State GState) a }
64 deriving (Monad, MonadState GState)
66 instance MonadState st (EMT e (StateT st IO)) where
68 put x = lift (St.put x)
70 instance MonadState st (EMT e (State st)) where
72 put x = lift (St.put x)
74 -- | IO version of Generate monad
75 newtype GenerateIO e a = GenerateIO {
76 runGenerateIO :: EMT e (StateT GState IO) a }
77 deriving (Monad, MonadState GState, MonadIO)
79 instance MonadIO (EMT e (StateT GState IO)) where
80 liftIO action = lift $ liftIO action
82 instance Generator e GenerateIO where
83 throwG e = GenerateIO (throw e)
85 instance (MonadState GState (EMT e (State GState))) => Generator e Generate where
86 throwG e = Generate (throw e)
88 execGenerateIO cp (GenerateIO emt) = do
89 let caught = emt `catch` (\(e :: SomeException) -> fail $ show e)
90 execStateT (runEMT caught) (emptyGState {classPath = cp})
92 execGenerate cp (Generate emt) = do
93 let caught = emt `catch` (\(e :: SomeException) -> fail $ show e)
94 execState (runEMT caught) (emptyGState {classPath = cp})
97 withClassPath :: ClassPath () -> GenerateIO e ()
99 res <- liftIO $ execClassPath cp
101 St.put $ st {classPath = res}
103 -- | Add a constant to pool
104 addItem :: (Generator e g) => Constant Direct -> g e Word16
106 pool <- St.gets currentPool
107 case lookupPool c pool of
110 i <- St.gets nextPoolIndex
111 let pool' = M.insert i c pool
116 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 }