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
56 withClassPath :: ClassPath () -> Generate ()
58 res <- liftIO $ execClassPath cp
60 St.put $ st {classPath = res}
62 -- | Append a constant to pool
63 appendPool :: Constant Direct -> Pool Direct -> (Pool Direct, Word16)
65 let size = fromIntegral (M.size pool)
66 pool' = M.insert size c pool
69 -- | Add a constant to pool
70 addItem :: Constant Direct -> Generate Word16
72 pool <- St.gets currentPool
73 case lookupPool c pool of
74 Just i -> return (i+1)
76 let (pool', i) = appendPool c pool
78 St.put $ st {currentPool = pool'}
82 lookupPool :: Constant Direct -> Pool Direct -> Maybe Word16
84 fromIntegral `fmap` findIndex (== c) (M.elems pool)
86 addNT :: HasSignature a => NameType a -> Generate Word16
87 addNT (NameType name sig) = do
89 x <- addItem (CNameType name bsig)
94 addSig :: MethodSignature -> Generate Word16
95 addSig c@(MethodSignature args ret) = do
99 -- | Add a constant into pool
100 addToPool :: Constant Direct -> Generate Word16
101 addToPool c@(CClass str) = do
104 addToPool c@(CField cls name) = do
105 addToPool (CClass cls)
108 addToPool c@(CMethod cls name) = do
109 addToPool (CClass cls)
112 addToPool c@(CIfaceMethod cls name) = do
113 addToPool (CClass cls)
116 addToPool c@(CString str) = do
117 addToPool (CUTF8 str)
119 addToPool c@(CNameType name sig) = do
123 addToPool c = addItem c
125 putInstruction :: Instruction -> Generate ()
126 putInstruction instr = do
128 let code = generated st
129 St.put $ st {generated = code ++ [instr]}
131 -- | Generate one (zero-arguments) instruction
132 i0 :: Instruction -> Generate ()
135 -- | Generate one one-argument instruction
136 i1 :: (Word16 -> Instruction) -> Constant Direct -> Generate ()
141 -- | Generate one one-argument instruction
142 i8 :: (Word8 -> Instruction) -> Constant Direct -> Generate ()
145 i0 (fn $ fromIntegral ix)
147 -- | Set maximum stack size for current method
148 setStackSize :: Word16 -> Generate ()
151 St.put $ st {stackSize = n}
153 -- | Set maximum number of local variables for current method
154 setMaxLocals :: Word16 -> Generate ()
157 St.put $ st {locals = n}
159 -- | Start generating new method
160 startMethod :: [AccessFlag] -> B.ByteString -> MethodSignature -> Generate ()
161 startMethod flags name sig = do
162 addToPool (CString name)
167 let method = Method {
168 methodAccessFlags = S.fromList flags,
170 methodSignature = sig,
171 methodAttributesCount = 0,
172 methodAttributes = AR M.empty }
173 St.put $ st {generated = [],
174 currentMethod = Just method }
176 -- | End of method generation
177 endMethod :: Generate ()
179 m <- St.gets currentMethod
180 code <- St.gets genCode
182 Nothing -> fail "endMethod without startMethod!"
184 let method' = method {methodAttributes = AR $ M.fromList [("Code", encodeMethod code)],
185 methodAttributesCount = 1}
187 St.put $ st {generated = [],
188 currentMethod = Nothing,
189 doneMethods = doneMethods st ++ [method']}
191 -- | Generate new method
192 newMethod :: [AccessFlag] -- ^ Access flags for method (public, static etc)
193 -> B.ByteString -- ^ Method name
194 -> [ArgumentSignature] -- ^ Signatures of method arguments
195 -> ReturnSignature -- ^ Method return signature
196 -> Generate () -- ^ Generator for method code
197 -> Generate (NameType Method)
198 newMethod flags name args ret gen = do
199 let sig = MethodSignature args ret
200 startMethod flags name sig
203 return (NameType name sig)
205 getClass :: String -> Generate (Class Direct)
207 cp <- St.gets classPath
208 res <- liftIO $ getEntry cp name
210 Just (NotLoaded p) -> fail $ "Class file was not loaded: " ++ p
211 Just (Loaded _ c) -> return c
212 Just (NotLoadedJAR p c) -> fail $ "Class was not loaded from JAR " ++ p ++ ": " ++ c
213 Just (LoadedJAR _ c) -> return c
214 Nothing -> fail $ "No such class in ClassPath: " ++ name
216 getClassField :: String -> B.ByteString -> Generate (NameType Field)
217 getClassField clsName fldName = do
218 cls <- getClass clsName
219 case lookupField fldName cls of
220 Just fld -> return (fieldNameType fld)
221 Nothing -> fail $ "No such field in class " ++ clsName ++ ": " ++ toString fldName
223 getClassMethod :: String -> B.ByteString -> Generate (NameType Method)
224 getClassMethod clsName mName = do
225 cls <- getClass clsName
226 case lookupMethod mName cls of
227 Just m -> return (methodNameType m)
228 Nothing -> fail $ "No such method in class " ++ clsName ++ ": " ++ toString mName
230 -- | Convert Generator state to method Code.
231 genCode :: GState -> Code
233 codeStackSize = stackSize st,
234 codeMaxLocals = locals st,
236 codeInstructions = generated st,
240 codeAttributes = AP [] }
242 len = fromIntegral $ B.length $ encodeInstructions (generated st)
244 -- | Start class generation.
245 initClass :: B.ByteString -> Generate Word16
247 addToPool (CClass "java/lang/Object")
248 addToPool (CClass name)
249 addToPool (CString "Code")
251 -- | Generate a class
252 generate :: [Tree CPEntry] -> B.ByteString -> Generate () -> IO (Class Direct)
253 generate cp name gen = do
257 St.put $ st {classPath = cp}
259 res <- execStateT generator emptyGState
260 let code = genCode res
261 d = defaultClass :: Class Direct
263 constsPoolSize = fromIntegral $ M.size (currentPool res),
264 constsPool = currentPool res,
265 accessFlags = S.fromList [ACC_PUBLIC, ACC_STATIC],
267 superClass = "java/lang/Object",
268 classMethodsCount = fromIntegral $ length (doneMethods res),
269 classMethods = doneMethods res }