JVM/Builder/Monad.hs

   1 {-# LANGUAGE FlexibleContexts, TypeFamilies, OverloadedStrings #-}
   2 module JVM.Builder.Monad where
   3
   4 import Control.Monad.State as St
   5 import Data.Word
   6 import Data.List
   7 import Data.Binary
   8 import qualified Data.Map as M
   9 import qualified Data.Set as S
  10 import qualified Data.ByteString.Lazy as B
  11
  12 import JVM.Common ()  -- import instances only
  13 import JVM.ClassFile
  14 import JVM.Assembler
  15
  16 data GState = GState {
  17   generated :: [Instruction],
  18   currentPool :: Pool Resolved,
  19   doneMethods :: [Method Resolved],
  20   currentMethod :: Maybe (Method Resolved),
  21   stackSize :: Word16,
  22   locals :: Word16 }
  23   deriving (Eq,Show)
  24
  25 emptyGState = GState {
  26   generated = [],
  27   currentPool = M.empty,
  28   doneMethods = [],
  29   currentMethod = Nothing,
  30   stackSize = 496,
  31   locals = 0 }
  32
  33 type Generate a = State GState a
  34
  35 appendPool :: Constant Resolved -> Pool Resolved -> (Pool Resolved, Word16)
  36 appendPool c pool =
  37   let size = fromIntegral (M.size pool)
  38       pool' = M.insert size c pool
  39   in  (pool', size)
  40
  41 addItem :: Constant Resolved -> Generate Word16
  42 addItem c = do
  43   pool <- St.gets currentPool
  44   case lookupPool c pool of
  45     Just i -> return (i+1)
  46     Nothing -> do
  47       let (pool', i) = appendPool c pool
  48       st <- St.get
  49       St.put $ st {currentPool = pool'}
  50       return (i+1)
  51
  52 lookupPool :: Constant Resolved -> Pool Resolved -> Maybe Word16
  53 lookupPool c pool =
  54   fromIntegral `fmap` findIndex (== c) (M.elems pool)
  55
  56 addNT :: Binary (Signature a) => NameType a -> Generate Word16
  57 addNT (NameType name sig) = do
  58   let bsig = encode sig
  59   x <- addItem (CNameType name bsig)
  60   addItem (CUTF8 name)
  61   addItem (CUTF8 bsig)
  62   return x
  63
  64 addSig :: MethodSignature -> Generate Word16
  65 addSig c@(MethodSignature args ret) = do
  66   let bsig = encode c
  67   addItem (CUTF8 bsig)
  68
  69 addToPool :: Constant Resolved -> Generate Word16
  70 addToPool c@(CClass str) = do
  71   addItem (CUTF8 str)
  72   addItem c
  73 addToPool c@(CField cls name) = do
  74   addToPool (CClass cls)
  75   addNT name
  76   addItem c
  77 addToPool c@(CMethod cls name) = do
  78   addToPool (CClass cls)
  79   addNT name
  80   addItem c
  81 addToPool c@(CIfaceMethod cls name) = do
  82   addToPool (CClass cls)
  83   addNT name
  84   addItem c
  85 addToPool c@(CString str) = do
  86   addToPool (CUTF8 str)
  87   addItem c
  88 addToPool c@(CNameType name sig) = do
  89   addItem (CUTF8 name)
  90   addItem (CUTF8 sig)
  91   addItem c
  92 addToPool c = addItem c
  93
  94 putInstruction :: Instruction -> Generate ()
  95 putInstruction instr = do
  96   st <- St.get
  97   let code = generated st
  98   St.put $ st {generated = code ++ [instr]}
  99
 100 i0 :: Instruction -> Generate ()
 101 i0 = putInstruction
 102
 103 i1 :: (Word16 -> Instruction) -> Constant Resolved -> Generate ()
 104 i1 fn c = do
 105   ix <- addToPool c
 106   i0 (fn ix)
 107
 108 i8 :: (Word8 -> Instruction) -> Constant Resolved -> Generate ()
 109 i8 fn c = do
 110   ix <- addToPool c
 111   i0 (fn $ fromIntegral ix)
 112
 113 setStackSize :: Word16 -> Generate ()
 114 setStackSize n = do
 115   st <- St.get
 116   St.put $ st {stackSize = n}
 117
 118 setMaxLocals :: Word16 -> Generate ()
 119 setMaxLocals n = do
 120   st <- St.get
 121   St.put $ st {locals = n}
 122
 123 startMethod :: [AccessFlag] -> B.ByteString -> MethodSignature -> Generate ()
 124 startMethod flags name sig = do
 125   addToPool (CString name)
 126   addSig sig
 127   setStackSize 4096
 128   setMaxLocals 100
 129   st <- St.get
 130   let method = Method {
 131     methodAccessFlags = S.fromList flags,
 132     methodName = name,
 133     methodSignature = sig,
 134     methodAttributesCount = 0,
 135     methodAttributes = AR M.empty }
 136   St.put $ st {generated = [],
 137                currentMethod = Just method }
 138
 139 endMethod :: Generate ()
 140 endMethod = do
 141   m <- St.gets currentMethod
 142   code <- St.gets genCode
 143   case m of
 144     Nothing -> fail "endMethod without startMethod!"
 145     Just method -> do
 146       let method' = method {methodAttributes = AR $ M.fromList [("Code", encodeMethod code)],
 147                             methodAttributesCount = 1}
 148       st <- St.get
 149       St.put $ st {generated = [],
 150                    currentMethod = Nothing,
 151                    doneMethods = doneMethods st ++ [method']}
 152
 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
 157   gen
 158   endMethod
 159   return (NameType name sig)
 160
 161 genCode :: GState -> Code
 162 genCode st = Code {
 163     codeStackSize = stackSize st,
 164     codeMaxLocals = locals st,
 165     codeLength = len,
 166     codeInstructions = generated st,
 167     codeExceptionsN = 0,
 168     codeExceptions = [],
 169     codeAttrsN = 0,
 170     codeAttributes = AP [] }
 171   where
 172     len = fromIntegral $ B.length $ encodeInstructions (generated st)
 173
 174 initClass :: B.ByteString -> Generate Word16
 175 initClass name = do
 176   addToPool (CClass "java/lang/Object")
 177   addToPool (CClass name)
 178   addToPool (CString "Code")
 179
 180 generate :: B.ByteString -> Generate () -> Class Resolved
 181 generate name gen =
 182   let generator = do
 183         initClass name
 184         gen
 185       res = execState generator emptyGState
 186       code = genCode res
 187   in  Class {
 188         magic = 0xCAFEBABE,
 189         minorVersion = 0,
 190         majorVersion = 50,
 191         constsPoolSize = fromIntegral $ M.size (currentPool res),
 192         constsPool = currentPool res,
 193         accessFlags = S.fromList [ACC_PUBLIC, ACC_STATIC],
 194         thisClass = name,
 195         superClass = "java/lang/Object",
 196         interfacesCount = 0,
 197         interfaces = [],
 198         classFieldsCount = 0,
 199         classFields = [],
 200         classMethodsCount = fromIntegral $ length (doneMethods res),
 201         classMethods = doneMethods res,
 202         classAttributesCount = 0,
 203         classAttributes = AR M.empty }
 204