Add simple code generator monad.

diff --git a/JVM/Assembler.hs b/JVM/Assembler.hs
index f141389d5f10b7c234f03aa9bb8538eaf79983af..b86bdbba7c2372d362e3f1116cc96b06f6aaab88 100644 (file)
--- a/JVM/Assembler.hs
+++ b/JVM/Assembler.hs
@@ -10,6 +10,7 @@ module JVM.Assembler
    Code (..),
    IMM (..),
    CMP (..),
    Code (..),
    IMM (..),
    CMP (..),

+   encodeInstructions,

    encodeMethod,
    decodeMethod
   )
    encodeMethod,
    decodeMethod
   )


@@ -705,6 +706,11 @@ instance BinaryState Integer Instruction where
         | inRange (153, 158) c -> return $ IF (toEnum $ fromIntegral $ c-153)
         | inRange (159, 164) c -> IF_ICMP (toEnum $ fromIntegral $ c-159) <$> get
         | otherwise -> fail $ "Unknown instruction byte code: " ++ show c
         | inRange (153, 158) c -> return $ IF (toEnum $ fromIntegral $ c-153)
         | inRange (159, 164) c -> IF_ICMP (toEnum $ fromIntegral $ c-159) <$> get
         | otherwise -> fail $ "Unknown instruction byte code: " ++ show c

+
+encodeInstructions :: [Instruction] -> B.ByteString
+encodeInstructions code =
+  let p list = forM_ list put
+  in  encodeWith p (0 :: Integer) code

   
 -- | Decode Java method
 decodeMethod :: B.ByteString -> Code
   
 -- | Decode Java method
 decodeMethod :: B.ByteString -> Code

diff --git a/JVM/Dump.hs b/JVM/Dump.hs
new file mode 100644 (file)
index 0000000..a5b2d19
--- /dev/null
+++ b/JVM/Dump.hs
@@ -0,0 +1,31 @@
+{-# LANGUAGE OverloadedStrings #-}
+module JVM.Dump where
+
+import Control.Monad
+import Data.Array
+import qualified Data.ByteString.Lazy as B
+import Text.Printf
+
+import JVM.Types
+import JVM.Converter
+import JVM.Assembler
+
+dumpClass :: Class -> IO ()
+dumpClass cls = do
+    putStr "Class: "
+    B.putStrLn (this cls)
+    putStrLn "Constants pool:"
+    forM_ (assocs $ constantPool cls) $ \(i, c) ->
+      putStrLn $ printf "  #%d:\t%s" i (show c)
+    putStrLn "Methods:"
+    forM_ (methods cls) $ \m -> do
+      putStr ">> Method "
+      B.putStr (methodName m)
+      print (methodSignature m)
+      case attrByName m "Code" of
+        Nothing -> putStrLn "(no code)\n"
+        Just bytecode -> let code = decodeMethod bytecode
+                         in  forM_ (codeInstructions code) $ \i -> do
+                               putStr "  "
+                               print i
+

diff --git a/JVM/Generator.hs b/JVM/Generator.hs
new file mode 100644 (file)
index 0000000..d5db62c
--- /dev/null
+++ b/JVM/Generator.hs
@@ -0,0 +1,157 @@
+{-# LANGUAGE FlexibleContexts, TypeFamilies, OverloadedStrings #-}
+module JVM.Generator where
+
+import Control.Monad.State as St
+import Data.Array
+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.Types
+import JVM.ClassFile
+import JVM.Assembler
+
+data GState = GState {
+  generated :: [Instruction],
+  currentPool :: Pool,
+  doneMethods :: [Method],
+  currentMethod :: Maybe Method}
+  deriving (Eq,Show)
+
+emptyGState = GState {
+  generated = [],
+  currentPool = listArray (0,0) [CInteger 0],
+  doneMethods = [],
+  currentMethod = Nothing }
+
+type Generate a = State GState a
+
+appendPool :: Constant -> Pool -> (Pool, Word16)
+appendPool c pool =
+  let list = assocs pool
+      size = fromIntegral (length list)
+      list' = list ++ [(size, c)]
+  in  (array (0, size) list',
+       size)
+
+addItem :: Constant -> Generate Word16
+addItem c = do
+  pool <- St.gets currentPool
+  case lookupPool c pool of
+    Just i -> return i
+    Nothing -> do
+      let (pool', i) = appendPool c pool
+      st <- St.get
+      St.put $ st {currentPool = pool'}
+      return i
+
+lookupPool :: Constant -> Pool -> Maybe Word16
+lookupPool c pool =
+  fromIntegral `fmap` findIndex (== c) (elems pool)
+
+addNT :: Binary (Signature a) => NameType a -> Generate Word16
+addNT (NameType name sig) = do
+  let bsig = encode sig
+  addItem (CUTF8 name)
+  addItem (CUTF8 bsig)
+  addItem (CNameType name bsig)
+
+addToPool :: Constant -> 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 -> Generate ()
+i1 fn c = do
+  ix <- addToPool c
+  i0 (fn ix)
+
+startMethod :: B.ByteString -> MethodSignature -> Generate ()
+startMethod name sig = do
+  st <- St.get
+  let method = Method {
+    methodAccess = S.fromList [ACC_PUBLIC],
+    methodName = name,
+    methodSignature = sig,
+    methodAttrs = 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 {methodAttrs = M.fromList [("Code", encodeMethod code)] }
+      st <- St.get
+      St.put $ st {generated = [],
+                   currentMethod = Nothing,
+                   doneMethods = doneMethods st ++ [method']}
+
+newMethod :: B.ByteString -> [ArgumentSignature] -> ReturnSignature -> Generate () -> Generate ()
+newMethod name args ret gen = do
+  startMethod name (MethodSignature args ret)
+  gen
+  endMethod
+
+genCode :: GState -> Code
+genCode st = Code {
+    codeStackSize = 4096,
+    codeMaxLocals = 100,
+    codeLength = len,
+    codeInstructions = generated st,
+    codeExceptionsN = 0,
+    codeExceptions = [],
+    codeAttrsN = 0,
+    codeAttributes = [] }
+  where
+    len = fromIntegral $ B.length $ encodeInstructions (generated st)
+
+generate :: B.ByteString -> Generate () -> Class
+generate name gen =
+  let res = execState gen emptyGState
+      code = genCode res
+  in  Class {
+        constantPool = currentPool res,
+        classAccess = S.fromList [ACC_PUBLIC],
+        this = name,
+        super = Nothing,
+        implements = [],
+        fields = [],
+        methods = doneMethods res,
+        classAttrs = M.empty }
+

diff --git a/JVM/Types.hs b/JVM/Types.hs
index e685e7933a56dc0539709c0d429dbf636d957984..5cdfb97608f9a0cb89549ca5f96d1d37fc3dc8a9 100644 (file)
--- a/JVM/Types.hs
+++ b/JVM/Types.hs
@@ -21,6 +21,9 @@ instance IsString B.ByteString where
 toString :: B.ByteString -> String
 toString bstr = decodeString $ map (chr . fromIntegral) $ B.unpack bstr
 
 toString :: B.ByteString -> String
 toString bstr = decodeString $ map (chr . fromIntegral) $ B.unpack bstr
 

+toCharList :: B.ByteString -> [Int]
+toCharList bstr = map fromIntegral $ B.unpack bstr
+

 -- | Constant pool
 type Pool = Array Word16 Constant
 
 -- | Constant pool
 type Pool = Array Word16 Constant
 

diff --git a/dump-class.hs b/dump-class.hs
index 37a52e614dd189f7b7cc01be1360eb35cf6e9b2e..d76c8f2f8cb64b00c527478aa5ee8e096efd9e7a 100644 (file)
--- a/dump-class.hs
+++ b/dump-class.hs
@@ -7,31 +7,14 @@ import System.Environment
 import qualified Data.ByteString.Lazy as B
 import Text.Printf
 
 import qualified Data.ByteString.Lazy as B
 import Text.Printf
 

-import JVM.Types

 import JVM.Converter
 import JVM.Converter

-import JVM.Assembler
+import JVM.Dump

 
 main = do
   args <- getArgs
   case args of
     [clspath] -> do
       cls <- parseClassFile clspath
 
 main = do
   args <- getArgs
   case args of
     [clspath] -> do
       cls <- parseClassFile clspath

-      putStr "Class: "
-      B.putStrLn (this cls)
-      putStrLn "Constants pool:"
-      forM_ (assocs $ constantPool cls) $ \(i, c) ->
-        putStrLn $ printf "  #%d:\t%s" i (show c)
-      putStrLn "Methods:"
-      forM_ (methods cls) $ \m -> do
-        putStr ">> Method "
-        B.putStr (methodName m)
-        print (methodSignature m)
-        case attrByName m "Code" of
-          Nothing -> putStrLn "(no code)\n"
-          Just bytecode -> let code = decodeMethod bytecode
-                           in  forM_ (codeInstructions code) $ \i -> do
-                                 putStr "  "
-                                 print i
-
+      dumpClass cls

     _ -> error "Synopsis: dump-class File.class"
 
     _ -> error "Synopsis: dump-class File.class"