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,
15 import Control.Monad.State as St
19 import qualified Data.Map as M
20 import qualified Data.Set as S
21 import qualified Data.ByteString.Lazy as B
23 import JVM.Common () -- import instances only
29 data GState = GState {
30 generated :: [Instruction], -- ^ Already generated code (in current method)
31 currentPool :: Pool Direct, -- ^ Already generated constants pool
32 doneMethods :: [Method Direct], -- ^ Already generated class methods
33 currentMethod :: Maybe (Method Direct), -- ^ Current method
34 stackSize :: Word16, -- ^ Maximum stack size for current method
35 locals :: Word16, -- ^ Maximum number of local variables for current method
36 classPath :: [Tree CPEntry]
40 -- | Empty generator state
42 emptyGState = GState {
44 currentPool = M.empty,
46 currentMethod = Nothing,
52 type Generate a = StateT GState IO a
54 withClassPath :: ClassPath () -> Generate ()
56 res <- liftIO $ execClassPath cp
58 St.put $ st {classPath = res}
60 -- | Append a constant to pool
61 appendPool :: Constant Direct -> Pool Direct -> (Pool Direct, Word16)
63 let size = fromIntegral (M.size pool)
64 pool' = M.insert size c pool
67 -- | Add a constant to pool
68 addItem :: Constant Direct -> Generate Word16
70 pool <- St.gets currentPool
71 case lookupPool c pool of
72 Just i -> return (i+1)
74 let (pool', i) = appendPool c pool
76 St.put $ st {currentPool = pool'}
80 lookupPool :: Constant Direct -> Pool Direct -> Maybe Word16
82 fromIntegral `fmap` findIndex (== c) (M.elems pool)
84 addNT :: HasSignature a => NameType a -> Generate Word16
85 addNT (NameType name sig) = do
87 x <- addItem (CNameType name bsig)
92 addSig :: MethodSignature -> Generate Word16
93 addSig c@(MethodSignature args ret) = do
97 -- | Add a constant into pool
98 addToPool :: Constant Direct -> Generate Word16
99 addToPool c@(CClass str) = do
102 addToPool c@(CField cls name) = do
103 addToPool (CClass cls)
106 addToPool c@(CMethod cls name) = do
107 addToPool (CClass cls)
110 addToPool c@(CIfaceMethod cls name) = do
111 addToPool (CClass cls)
114 addToPool c@(CString str) = do
115 addToPool (CUTF8 str)
117 addToPool c@(CNameType name sig) = do
121 addToPool c = addItem c
123 putInstruction :: Instruction -> Generate ()
124 putInstruction instr = do
126 let code = generated st
127 St.put $ st {generated = code ++ [instr]}
129 -- | Generate one (zero-arguments) instruction
130 i0 :: Instruction -> Generate ()
133 -- | Generate one one-argument instruction
134 i1 :: (Word16 -> Instruction) -> Constant Direct -> Generate ()
139 -- | Generate one one-argument instruction
140 i8 :: (Word8 -> Instruction) -> Constant Direct -> Generate ()
143 i0 (fn $ fromIntegral ix)
145 -- | Set maximum stack size for current method
146 setStackSize :: Word16 -> Generate ()
149 St.put $ st {stackSize = n}
151 -- | Set maximum number of local variables for current method
152 setMaxLocals :: Word16 -> Generate ()
155 St.put $ st {locals = n}
157 -- | Start generating new method
158 startMethod :: [AccessFlag] -> B.ByteString -> MethodSignature -> Generate ()
159 startMethod flags name sig = do
160 addToPool (CString name)
165 let method = Method {
166 methodAccessFlags = S.fromList flags,
168 methodSignature = sig,
169 methodAttributesCount = 0,
170 methodAttributes = AR M.empty }
171 St.put $ st {generated = [],
172 currentMethod = Just method }
174 -- | End of method generation
175 endMethod :: Generate ()
177 m <- St.gets currentMethod
178 code <- St.gets genCode
180 Nothing -> fail "endMethod without startMethod!"
182 let method' = method {methodAttributes = AR $ M.fromList [("Code", encodeMethod code)],
183 methodAttributesCount = 1}
185 St.put $ st {generated = [],
186 currentMethod = Nothing,
187 doneMethods = doneMethods st ++ [method']}
189 -- | Generate new method
190 newMethod :: [AccessFlag] -- ^ Access flags for method (public, static etc)
191 -> B.ByteString -- ^ Method name
192 -> [ArgumentSignature] -- ^ Signatures of method arguments
193 -> ReturnSignature -- ^ Method return signature
194 -> Generate () -- ^ Generator for method code
195 -> Generate (NameType Method)
196 newMethod flags name args ret gen = do
197 let sig = MethodSignature args ret
198 startMethod flags name sig
201 return (NameType name sig)
203 -- | Convert Generator state to method Code.
204 genCode :: GState -> Code
206 codeStackSize = stackSize st,
207 codeMaxLocals = locals st,
209 codeInstructions = generated st,
213 codeAttributes = AP [] }
215 len = fromIntegral $ B.length $ encodeInstructions (generated st)
217 -- | Start class generation.
218 initClass :: B.ByteString -> Generate Word16
220 addToPool (CClass "java/lang/Object")
221 addToPool (CClass name)
222 addToPool (CString "Code")
224 -- | Generate a class
225 generate :: [Tree CPEntry] -> B.ByteString -> Generate () -> IO (Class Direct)
226 generate cp name gen = do
230 St.put $ st {classPath = cp}
232 res <- execStateT generator emptyGState
233 let code = genCode res
234 d = defaultClass :: Class Direct
236 constsPoolSize = fromIntegral $ M.size (currentPool res),
237 constsPool = currentPool res,
238 accessFlags = S.fromList [ACC_PUBLIC, ACC_STATIC],
240 superClass = "java/lang/Object",
241 classMethodsCount = fromIntegral $ length (doneMethods res),
242 classMethods = doneMethods res }