module JVM.Builder.Monad where
import Control.Monad.State as St
import Data.Word
import Data.List
import Data.Binary
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.ByteString.Lazy as B
import JVM.Common ()
import JVM.ClassFile
import JVM.Assembler
data GState = GState {
generated :: [Instruction],
currentPool :: Pool Resolved,
doneMethods :: [Method Resolved],
currentMethod :: Maybe (Method Resolved)}
deriving (Eq,Show)
emptyGState = GState {
generated = [],
currentPool = M.empty,
doneMethods = [],
currentMethod = Nothing }
type Generate a = State GState a
appendPool :: Constant Resolved -> Pool Resolved -> (Pool Resolved, Word16)
appendPool c pool =
let size = fromIntegral (M.size pool)
pool' = M.insert size c pool
in (pool', size)
addItem :: Constant Resolved -> Generate Word16
addItem c = do
pool <- St.gets currentPool
case lookupPool c pool of
Just i -> return (i+1)
Nothing -> do
let (pool', i) = appendPool c pool
st <- St.get
St.put $ st {currentPool = pool'}
return (i+1)
lookupPool :: Constant Resolved -> Pool Resolved -> Maybe Word16
lookupPool c pool =
fromIntegral `fmap` findIndex (== c) (M.elems pool)
addNT :: Binary (Signature a) => NameType a -> Generate Word16
addNT (NameType name sig) = do
let bsig = encode sig
x <- addItem (CNameType name bsig)
addItem (CUTF8 name)
addItem (CUTF8 bsig)
return x
addSig :: MethodSignature -> Generate Word16
addSig c@(MethodSignature args ret) = do
let bsig = encode c
addItem (CUTF8 bsig)
addToPool :: Constant Resolved -> Generate Word16
addToPool c@(CClass str) = do
addItem (CUTF8 str)
addItem c
addToPool c@(CField cls name) = do
addToPool (CClass cls)
addNT name
addItem c
addToPool c@(CMethod cls name) = do
addToPool (CClass cls)
addNT name
addItem c
addToPool c@(CIfaceMethod cls name) = do
addToPool (CClass cls)
addNT name
addItem c
addToPool c@(CString str) = do
addToPool (CUTF8 str)
addItem c
addToPool c@(CNameType name sig) = do
addItem (CUTF8 name)
addItem (CUTF8 sig)
addItem c
addToPool c = addItem c
putInstruction :: Instruction -> Generate ()
putInstruction instr = do
st <- St.get
let code = generated st
St.put $ st {generated = code ++ [instr]}
i0 :: Instruction -> Generate ()
i0 = putInstruction
i1 :: (Word16 -> Instruction) -> Constant Resolved -> Generate ()
i1 fn c = do
ix <- addToPool c
i0 (fn ix)
i8 :: (Word8 -> Instruction) -> Constant Resolved -> Generate ()
i8 fn c = do
ix <- addToPool c
i0 (fn $ fromIntegral ix)
startMethod :: [AccessFlag] -> B.ByteString -> MethodSignature -> Generate ()
startMethod flags name sig = do
addToPool (CString name)
addSig sig
st <- St.get
let method = Method {
methodAccessFlags = S.fromList flags,
methodName = name,
methodSignature = sig,
methodAttributesCount = 0,
methodAttributes = AR M.empty }
St.put $ st {generated = [],
currentMethod = Just method }
endMethod :: Generate ()
endMethod = do
m <- St.gets currentMethod
code <- St.gets genCode
case m of
Nothing -> fail "endMethod without startMethod!"
Just method -> do
let method' = method {methodAttributes = AR $ M.fromList [("Code", encodeMethod code)],
methodAttributesCount = 1}
st <- St.get
St.put $ st {generated = [],
currentMethod = Nothing,
doneMethods = doneMethods st ++ [method']}
newMethod :: [AccessFlag] -> B.ByteString -> [ArgumentSignature] -> ReturnSignature -> Generate () -> Generate (NameType Method)
newMethod flags name args ret gen = do
let sig = MethodSignature args ret
startMethod flags name sig
gen
endMethod
return (NameType name sig)
genCode :: GState -> Code
genCode st = Code {
codeStackSize = 4096,
codeMaxLocals = 100,
codeLength = len,
codeInstructions = generated st,
codeExceptionsN = 0,
codeExceptions = [],
codeAttrsN = 0,
codeAttributes = AP [] }
where
len = fromIntegral $ B.length $ encodeInstructions (generated st)
initClass :: B.ByteString -> Generate Word16
initClass name = do
addToPool (CClass "java/lang/Object")
addToPool (CClass name)
addToPool (CString "Code")
generate :: B.ByteString -> Generate () -> Class Resolved
generate name gen =
let generator = do
initClass name
gen
res = execState generator emptyGState
code = genCode res
in Class {
magic = 0xCAFEBABE,
minorVersion = 0,
majorVersion = 50,
constsPoolSize = fromIntegral $ M.size (currentPool res),
constsPool = currentPool res,
accessFlags = S.fromList [ACC_PUBLIC, ACC_STATIC],
thisClass = name,
superClass = "java/lang/Object",
interfacesCount = 0,
interfaces = [],
classFieldsCount = 0,
classFields = [],
classMethodsCount = fromIntegral $ length (doneMethods res),
classMethods = doneMethods res,
classAttributesCount = 0,
classAttributes = AR M.empty }