1 {-# LANGUAGE FlexibleContexts, TypeFamilies, OverloadedStrings #-}
2 module JVM.Generator where
4 import Control.Monad.State as St
9 import qualified Data.Map as M
10 import qualified Data.Set as S
11 import qualified Data.ByteString.Lazy as B
17 data GState = GState {
18 generated :: [Instruction],
20 doneMethods :: [Method],
21 currentMethod :: Maybe Method}
24 emptyGState = GState {
26 currentPool = listArray (0,0) [CInteger 0],
28 currentMethod = Nothing }
30 type Generate a = State GState a
32 appendPool :: Constant -> Pool -> (Pool, Word16)
34 let list = assocs pool
35 size = fromIntegral (length list)
36 list' = list ++ [(size, c)]
37 in (array (0, size) list',
40 addItem :: Constant -> Generate Word16
42 pool <- St.gets currentPool
43 if pool ! 0 == CInteger 0
46 St.put $ st {currentPool = listArray (0,0) [c]}
48 else case lookupPool c pool of
51 let (pool', i) = appendPool c pool
53 St.put $ st {currentPool = pool'}
56 lookupPool :: Constant -> Pool -> Maybe Word16
58 fromIntegral `fmap` findIndex (== c) (elems pool)
60 addNT :: Binary (Signature a) => NameType a -> Generate Word16
61 addNT (NameType name sig) = do
63 x <- addItem (CNameType name bsig)
68 addSig :: MethodSignature -> Generate Word16
69 addSig c@(MethodSignature args ret) = do
73 addToPool :: Constant -> Generate Word16
74 addToPool c@(CClass str) = do
77 addToPool c@(CField cls name) = do
78 addToPool (CClass cls)
81 addToPool c@(CMethod cls name) = do
82 addToPool (CClass cls)
85 addToPool c@(CIfaceMethod cls name) = do
86 addToPool (CClass cls)
89 addToPool c@(CString str) = do
92 addToPool c@(CNameType name sig) = do
96 addToPool c = addItem c
98 putInstruction :: Instruction -> Generate ()
99 putInstruction instr = do
101 let code = generated st
102 St.put $ st {generated = code ++ [instr]}
104 i0 :: Instruction -> Generate ()
107 i1 :: (Word16 -> Instruction) -> Constant -> Generate ()
112 i8 :: (Word8 -> Instruction) -> Constant -> Generate ()
115 i0 (fn $ fromIntegral ix)
117 startMethod :: [AccessFlag] -> B.ByteString -> MethodSignature -> Generate ()
118 startMethod flags name sig = do
119 addToPool (CString name)
122 let method = Method {
123 methodAccess = S.fromList flags,
125 methodSignature = sig,
126 methodAttrs = M.empty }
127 St.put $ st {generated = [],
128 currentMethod = Just method }
130 endMethod :: Generate ()
132 m <- St.gets currentMethod
133 code <- St.gets genCode
135 Nothing -> fail "endMethod without startMethod!"
137 let method' = method {methodAttrs = M.fromList [("Code", encodeMethod code)] }
139 St.put $ st {generated = [],
140 currentMethod = Nothing,
141 doneMethods = doneMethods st ++ [method']}
143 newMethod :: [AccessFlag] -> B.ByteString -> [ArgumentSignature] -> ReturnSignature -> Generate () -> Generate ()
144 newMethod flags name args ret gen = do
145 startMethod flags name (MethodSignature args ret)
149 genCode :: GState -> Code
151 codeStackSize = 4096,
154 codeInstructions = generated st,
158 codeAttributes = [] }
160 len = fromIntegral $ B.length $ encodeInstructions (generated st)
162 initClass :: B.ByteString -> Generate Word16
164 addToPool (CClass "java/lang/Object")
165 addToPool (CClass name)
166 addToPool (CString "Code")
168 generate :: B.ByteString -> Generate () -> Class
173 res = execState generator emptyGState
176 constantPool = currentPool res,
177 classAccess = S.fromList [ACC_PUBLIC, ACC_STATIC],
179 super = Just "java/lang/Object",
182 methods = doneMethods res,
183 classAttrs = M.empty }