1 {-# LANGUAGE FlexibleContexts, TypeFamilies, OverloadedStrings #-}
2 -- | This module defines Generate monad, which helps generating JVM code and
3 -- creating Java class constants pool.
4 module JVM.Builder.Monad
11 setStackSize, setMaxLocals,
13 getClassField, getClassMethod,
17 import Control.Monad.State as St
21 import qualified Data.Map as M
22 import qualified Data.Set as S
23 import qualified Data.ByteString.Lazy as B
25 import JVM.Common () -- import instances only
31 data GState = GState {
32 generated :: [Instruction], -- ^ Already generated code (in current method)
33 currentPool :: Pool Direct, -- ^ Already generated constants pool
34 doneMethods :: [Method Direct], -- ^ Already generated class methods
35 currentMethod :: Maybe (Method Direct), -- ^ Current method
36 stackSize :: Word16, -- ^ Maximum stack size for current method
37 locals :: Word16, -- ^ Maximum number of local variables for current method
38 classPath :: [Tree CPEntry]
42 -- | Empty generator state
44 emptyGState = GState {
46 currentPool = M.empty,
48 currentMethod = Nothing,
54 type Generate a = StateT GState IO a
57 withClassPath :: ClassPath () -> Generate ()
59 res <- liftIO $ execClassPath cp
61 St.put $ st {classPath = res}
63 -- | Append a constant to pool
64 appendPool :: Constant Direct -> Pool Direct -> (Pool Direct, Word16)
66 let size = fromIntegral (M.size pool)
67 pool' = M.insert size c pool
70 -- | Add a constant to pool
71 addItem :: Constant Direct -> Generate Word16
73 pool <- St.gets currentPool
74 case lookupPool c pool of
75 Just i -> return (i+1)
77 let (pool', i) = appendPool c pool
79 St.put $ st {currentPool = pool'}
83 lookupPool :: Constant Direct -> Pool Direct -> Maybe Word16
85 fromIntegral `fmap` findIndex (== c) (M.elems pool)
87 addNT :: HasSignature a => NameType a -> Generate Word16
88 addNT (NameType name sig) = do
90 x <- addItem (CNameType name bsig)
95 addSig :: MethodSignature -> Generate Word16
96 addSig c@(MethodSignature args ret) = do
100 -- | Add a constant into pool
101 addToPool :: Constant Direct -> Generate Word16
102 addToPool c@(CClass str) = do
105 addToPool c@(CField cls name) = do
106 addToPool (CClass cls)
109 addToPool c@(CMethod cls name) = do
110 addToPool (CClass cls)
113 addToPool c@(CIfaceMethod cls name) = do
114 addToPool (CClass cls)
117 addToPool c@(CString str) = do
118 addToPool (CUTF8 str)
120 addToPool c@(CNameType name sig) = do
124 addToPool c = addItem c
126 putInstruction :: Instruction -> Generate ()
127 putInstruction instr = do
129 let code = generated st
130 St.put $ st {generated = code ++ [instr]}
132 -- | Generate one (zero-arguments) instruction
133 i0 :: Instruction -> Generate ()
136 -- | Generate one one-argument instruction
137 i1 :: (Word16 -> Instruction) -> Constant Direct -> Generate ()
142 -- | Generate one one-argument instruction
143 i8 :: (Word8 -> Instruction) -> Constant Direct -> Generate ()
146 i0 (fn $ fromIntegral ix)
148 -- | Set maximum stack size for current method
149 setStackSize :: Word16 -> Generate ()
152 St.put $ st {stackSize = n}
154 -- | Set maximum number of local variables for current method
155 setMaxLocals :: Word16 -> Generate ()
158 St.put $ st {locals = n}
160 -- | Start generating new method
161 startMethod :: [AccessFlag] -> B.ByteString -> MethodSignature -> Generate ()
162 startMethod flags name sig = do
163 addToPool (CString name)
168 let method = Method {
169 methodAccessFlags = S.fromList flags,
171 methodSignature = sig,
172 methodAttributesCount = 0,
173 methodAttributes = AR M.empty }
174 St.put $ st {generated = [],
175 currentMethod = Just method }
177 -- | End of method generation
178 endMethod :: Generate ()
180 m <- St.gets currentMethod
181 code <- St.gets genCode
183 Nothing -> fail "endMethod without startMethod!"
185 let method' = method {methodAttributes = AR $ M.fromList [("Code", encodeMethod code)],
186 methodAttributesCount = 1}
188 St.put $ st {generated = [],
189 currentMethod = Nothing,
190 doneMethods = doneMethods st ++ [method']}
192 -- | Generate new method
193 newMethod :: [AccessFlag] -- ^ Access flags for method (public, static etc)
194 -> B.ByteString -- ^ Method name
195 -> [ArgumentSignature] -- ^ Signatures of method arguments
196 -> ReturnSignature -- ^ Method return signature
197 -> Generate () -- ^ Generator for method code
198 -> Generate (NameType Method)
199 newMethod flags name args ret gen = do
200 let sig = MethodSignature args ret
201 startMethod flags name sig
204 return (NameType name sig)
206 -- | Get a class from current ClassPath
207 getClass :: String -> Generate (Class Direct)
209 cp <- St.gets classPath
210 res <- liftIO $ getEntry cp name
212 Just (NotLoaded p) -> fail $ "Class file was not loaded: " ++ p
213 Just (Loaded _ c) -> return c
214 Just (NotLoadedJAR p c) -> fail $ "Class was not loaded from JAR " ++ p ++ ": " ++ c
215 Just (LoadedJAR _ c) -> return c
216 Nothing -> fail $ "No such class in ClassPath: " ++ name
218 -- | Get class field signature from current ClassPath
219 getClassField :: String -> B.ByteString -> Generate (NameType Field)
220 getClassField clsName fldName = do
221 cls <- getClass clsName
222 case lookupField fldName cls of
223 Just fld -> return (fieldNameType fld)
224 Nothing -> fail $ "No such field in class " ++ clsName ++ ": " ++ toString fldName
226 -- | Get class method signature from current ClassPath
227 getClassMethod :: String -> B.ByteString -> Generate (NameType Method)
228 getClassMethod clsName mName = do
229 cls <- getClass clsName
230 case lookupMethod mName cls of
231 Just m -> return (methodNameType m)
232 Nothing -> fail $ "No such method in class " ++ clsName ++ ": " ++ toString mName
234 -- | Convert Generator state to method Code.
235 genCode :: GState -> Code
237 codeStackSize = stackSize st,
238 codeMaxLocals = locals st,
240 codeInstructions = generated st,
244 codeAttributes = AP [] }
246 len = fromIntegral $ B.length $ encodeInstructions (generated st)
248 -- | Start class generation.
249 initClass :: B.ByteString -> Generate Word16
251 addToPool (CClass "java/lang/Object")
252 addToPool (CClass name)
253 addToPool (CString "Code")
255 -- | Generate a class
256 generate :: [Tree CPEntry] -> B.ByteString -> Generate () -> IO (Class Direct)
257 generate cp name gen = do
261 res <- execStateT generator (emptyGState {classPath = cp})
262 let code = genCode res
263 d = defaultClass :: Class Direct
265 constsPoolSize = fromIntegral $ M.size (currentPool res),
266 constsPool = currentPool res,
267 accessFlags = S.fromList [ACC_PUBLIC, ACC_STATIC],
269 superClass = "java/lang/Object",
270 classMethodsCount = fromIntegral $ length (doneMethods res),
271 classMethods = doneMethods res }