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   case lookupPool c pool of
  44     Just i -> return i
  45     Nothing -> do
  46       let (pool', i) = appendPool c pool
  47       st <- St.get
  48       St.put $ st {currentPool = pool'}
  49       return i
  50
  51 lookupPool :: Constant -> Pool -> Maybe Word16
  52 lookupPool c pool =
  53   fromIntegral `fmap` findIndex (== c) (elems pool)
  54
  55 addNT :: Binary (Signature a) => NameType a -> Generate Word16
  56 addNT (NameType name sig) = do
  57   let bsig = encode sig
  58   addItem (CUTF8 name)
  59   addItem (CUTF8 bsig)
  60   addItem (CNameType name bsig)
  61
  62 addToPool :: Constant -> Generate Word16
  63 addToPool c@(CClass str) = do
  64   addItem (CUTF8 str)
  65   addItem c
  66 addToPool c@(CField cls name) = do
  67   addToPool (CClass cls)
  68   addNT name
  69   addItem c
  70 addToPool c@(CMethod cls name) = do
  71   addToPool (CClass cls)
  72   addNT name
  73   addItem c
  74 addToPool c@(CIfaceMethod cls name) = do
  75   addToPool (CClass cls)
  76   addNT name
  77   addItem c
  78 addToPool c@(CString str) = do
  79   addToPool (CUTF8 str)
  80   addItem c
  81 addToPool c@(CNameType name sig) = do
  82   addItem (CUTF8 name)
  83   addItem (CUTF8 sig)
  84   addItem c
  85 addToPool c = addItem c
  86
  87 putInstruction :: Instruction -> Generate ()
  88 putInstruction instr = do
  89   st <- St.get
  90   let code = generated st
  91   St.put $ st {generated = code ++ [instr]}
  92
  93 i0 :: Instruction -> Generate ()
  94 i0 = putInstruction
  95
  96 i1 :: (Word16 -> Instruction) -> Constant -> Generate ()
  97 i1 fn c = do
  98   ix <- addToPool c
  99   i0 (fn ix)
 100
 101 startMethod :: B.ByteString -> MethodSignature -> Generate ()
 102 startMethod name sig = do
 103   st <- St.get
 104   let method = Method {
 105     methodAccess = S.fromList [ACC_PUBLIC],
 106     methodName = name,
 107     methodSignature = sig,
 108     methodAttrs = M.empty }
 109   St.put $ st {generated = [],
 110                currentMethod = Just method }
 111
 112 endMethod :: Generate ()
 113 endMethod = do
 114   m <- St.gets currentMethod
 115   code <- St.gets genCode
 116   case m of
 117     Nothing -> fail "endMethod without startMethod!"
 118     Just method -> do
 119       let method' = method {methodAttrs = M.fromList [("Code", encodeMethod code)] }
 120       st <- St.get
 121       St.put $ st {generated = [],
 122                    currentMethod = Nothing,
 123                    doneMethods = doneMethods st ++ [method']}
 124
 125 newMethod :: B.ByteString -> [ArgumentSignature] -> ReturnSignature -> Generate () -> Generate ()
 126 newMethod name args ret gen = do
 127   startMethod name (MethodSignature args ret)
 128   gen
 129   endMethod
 130
 131 genCode :: GState -> Code
 132 genCode st = Code {
 133     codeStackSize = 4096,
 134     codeMaxLocals = 100,
 135     codeLength = len,
 136     codeInstructions = generated st,
 137     codeExceptionsN = 0,
 138     codeExceptions = [],
 139     codeAttrsN = 0,
 140     codeAttributes = [] }
 141   where
 142     len = fromIntegral $ B.length $ encodeInstructions (generated st)
 143
 144 generate :: B.ByteString -> Generate () -> Class
 145 generate name gen =
 146   let res = execState gen emptyGState
 147       code = genCode res
 148   in  Class {
 149         constantPool = currentPool res,
 150         classAccess = S.fromList [ACC_PUBLIC],
 151         this = name,
 152         super = Nothing,
 153         implements = [],
 154         fields = [],
 155         methods = doneMethods res,
 156         classAttrs = M.empty }
 157