1 {-# LANGUAGE FlexibleContexts, TypeFamilies, OverloadedStrings #-}
2 module JVM.Builder.Monad where
4 import Control.Monad.State as St
8 import qualified Data.Map as M
9 import qualified Data.Set as S
10 import qualified Data.ByteString.Lazy as B
12 import JVM.Common () -- import instances only
16 data GState = GState {
17 generated :: [Instruction],
18 currentPool :: Pool Resolved,
19 doneMethods :: [Method Resolved],
20 currentMethod :: Maybe (Method Resolved),
25 emptyGState = GState {
27 currentPool = M.empty,
29 currentMethod = Nothing,
33 type Generate a = State GState a
35 appendPool :: Constant Resolved -> Pool Resolved -> (Pool Resolved, Word16)
37 let size = fromIntegral (M.size pool)
38 pool' = M.insert size c pool
41 addItem :: Constant Resolved -> Generate Word16
43 pool <- St.gets currentPool
44 case lookupPool c pool of
45 Just i -> return (i+1)
47 let (pool', i) = appendPool c pool
49 St.put $ st {currentPool = pool'}
52 lookupPool :: Constant Resolved -> Pool Resolved -> Maybe Word16
54 fromIntegral `fmap` findIndex (== c) (M.elems pool)
56 addNT :: Binary (Signature a) => NameType a -> Generate Word16
57 addNT (NameType name sig) = do
59 x <- addItem (CNameType name bsig)
64 addSig :: MethodSignature -> Generate Word16
65 addSig c@(MethodSignature args ret) = do
69 addToPool :: Constant Resolved -> Generate Word16
70 addToPool c@(CClass str) = do
73 addToPool c@(CField cls name) = do
74 addToPool (CClass cls)
77 addToPool c@(CMethod cls name) = do
78 addToPool (CClass cls)
81 addToPool c@(CIfaceMethod cls name) = do
82 addToPool (CClass cls)
85 addToPool c@(CString str) = do
88 addToPool c@(CNameType name sig) = do
92 addToPool c = addItem c
94 putInstruction :: Instruction -> Generate ()
95 putInstruction instr = do
97 let code = generated st
98 St.put $ st {generated = code ++ [instr]}
100 i0 :: Instruction -> Generate ()
103 i1 :: (Word16 -> Instruction) -> Constant Resolved -> Generate ()
108 i8 :: (Word8 -> Instruction) -> Constant Resolved -> Generate ()
111 i0 (fn $ fromIntegral ix)
113 setStackSize :: Word16 -> Generate ()
116 St.put $ st {stackSize = n}
118 setMaxLocals :: Word16 -> Generate ()
121 St.put $ st {locals = n}
123 startMethod :: [AccessFlag] -> B.ByteString -> MethodSignature -> Generate ()
124 startMethod flags name sig = do
125 addToPool (CString name)
130 let method = Method {
131 methodAccessFlags = S.fromList flags,
133 methodSignature = sig,
134 methodAttributesCount = 0,
135 methodAttributes = AR M.empty }
136 St.put $ st {generated = [],
137 currentMethod = Just method }
139 endMethod :: Generate ()
141 m <- St.gets currentMethod
142 code <- St.gets genCode
144 Nothing -> fail "endMethod without startMethod!"
146 let method' = method {methodAttributes = AR $ M.fromList [("Code", encodeMethod code)],
147 methodAttributesCount = 1}
149 St.put $ st {generated = [],
150 currentMethod = Nothing,
151 doneMethods = doneMethods st ++ [method']}
153 newMethod :: [AccessFlag] -> B.ByteString -> [ArgumentSignature] -> ReturnSignature -> Generate () -> Generate (NameType Method)
154 newMethod flags name args ret gen = do
155 let sig = MethodSignature args ret
156 startMethod flags name sig
159 return (NameType name sig)
161 genCode :: GState -> Code
163 codeStackSize = stackSize st,
164 codeMaxLocals = locals st,
166 codeInstructions = generated st,
170 codeAttributes = AP [] }
172 len = fromIntegral $ B.length $ encodeInstructions (generated st)
174 initClass :: B.ByteString -> Generate Word16
176 addToPool (CClass "java/lang/Object")
177 addToPool (CClass name)
178 addToPool (CString "Code")
180 generate :: B.ByteString -> Generate () -> Class Resolved
185 res = execState generator emptyGState
191 constsPoolSize = fromIntegral $ M.size (currentPool res),
192 constsPool = currentPool res,
193 accessFlags = S.fromList [ACC_PUBLIC, ACC_STATIC],
195 superClass = "java/lang/Object",
198 classFieldsCount = 0,
200 classMethodsCount = fromIntegral $ length (doneMethods res),
201 classMethods = doneMethods res,
202 classAttributesCount = 0,
203 classAttributes = AR M.empty }