JVM/Generator.hs

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