JVM/Generator.hs

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