From 8876aca404b4c111461b7582bb772d219babd3aa Mon Sep 17 00:00:00 2001 From: "Ilya V. Portnov" Date: Fri, 16 Sep 2011 16:12:30 +0600 Subject: [PATCH] JVM assembler/disassembler tested to work on Hello.java. --- Hello.java | 11 +++++++ JVM/ClassFile.hs | 8 +++-- JVM/Converter.hs | 79 ++++++++++++++++++++++++++++++++--------------- JVM/Exceptions.hs | 21 +++++++++++++ JVM/Types.hs | 24 +++++++++++++- rebuild-class.hs | 42 +++++++++++++++++++++++++ 6 files changed, 156 insertions(+), 29 deletions(-) create mode 100644 Hello.java create mode 100644 JVM/Exceptions.hs create mode 100644 rebuild-class.hs diff --git a/Hello.java b/Hello.java new file mode 100644 index 0000000..33b7645 --- /dev/null +++ b/Hello.java @@ -0,0 +1,11 @@ +public class Hello { + public static void main(String[] args) { + hello(5); + } + + static void hello(int n) { + System.out.println("Здравствуй, мир!"); + System.out.printf("Argument: %d", n); + } +} + diff --git a/JVM/ClassFile.hs b/JVM/ClassFile.hs index baac436..e9b1377 100644 --- a/JVM/ClassFile.hs +++ b/JVM/ClassFile.hs @@ -85,7 +85,7 @@ instance Binary ClassFile where classMethodsCount <- get classMethods <- replicateM (fromIntegral classMethodsCount) get asCount <- get - as <- replicateM (fromIntegral $ asCount - 1) get + as <- replicateM (fromIntegral $ asCount) get return $ ClassFile magic minor major poolsize pool af this super interfacesCount ifaces classFieldsCount classFields classMethodsCount classMethods asCount as @@ -137,6 +137,9 @@ getInt = do return (c: next) else return [] +putString :: String -> Put +putString str = forM_ str put + instance Binary FieldType where put SignedByte = put 'B' put CharByte = put 'C' @@ -146,7 +149,7 @@ instance Binary FieldType where put LongInt = put 'J' put ShortInt = put 'S' put BoolType = put 'Z' - put (ObjectType name) = put 'L' >> put name + put (ObjectType name) = put 'L' >> putString name >> put ';' put (Array Nothing sig) = put '[' >> put sig put (Array (Just n) sig) = put '[' >> put (show n) >> put sig @@ -375,4 +378,3 @@ instance Binary AttributeInfo where value <- getLazyByteString (fromIntegral len) return $ AttributeInfo name len value - diff --git a/JVM/Converter.hs b/JVM/Converter.hs index 41cf05f..4fb0ec3 100644 --- a/JVM/Converter.hs +++ b/JVM/Converter.hs @@ -3,13 +3,15 @@ -- high-level Java classes, methods etc representation module JVM.Converter (parseClass, parseClassFile, - convertClass, + convertClass, classFile, + encodeClass, methodByName, attrByName, methodCode ) where +import Control.Monad.Exception import Data.List import Data.Word import Data.Bits @@ -21,6 +23,7 @@ import qualified Data.Map as M import JVM.ClassFile import JVM.Types +import JVM.Exceptions -- | Parse .class file data parseClass :: B.ByteString -> Class @@ -52,13 +55,15 @@ classFile (Class {..}) = ClassFile { magic = 0xCAFEBABE, minorVersion = 0, majorVersion = 50, - constsPoolSize = fromIntegral (length poolInfo), + constsPoolSize = fromIntegral (length poolInfo + 1), constsPool = poolInfo, accessFlags = access2word16 classAccess, - thisClass = poolIndex poolInfo this, - superClass = poolIndex poolInfo this, + thisClass = force "this" $ poolClassIndex poolInfo this, + superClass = case super of + Just s -> force "super" $ poolClassIndex poolInfo s + Nothing -> 0, interfacesCount = fromIntegral (length implements), - interfaces = map (poolIndex poolInfo) implements, + interfaces = map (force "ifaces" . poolIndex poolInfo) implements, classFieldsCount = fromIntegral (length fields), classFields = map (fieldInfo poolInfo) fields, classMethodsCount = fromIntegral (length methods), @@ -73,57 +78,81 @@ toCPInfo pool = result where result = map cpInfo $ elems pool - cpInfo (CClass name) = CONSTANT_Class (poolIndex result name) + cpInfo (CClass name) = CONSTANT_Class (force "class" $ poolIndex result name) cpInfo (CField cls name) = - CONSTANT_Fieldref (poolIndex result cls) (poolIndex result name) + CONSTANT_Fieldref (force "field a" $ poolClassIndex result cls) (force "field b" $ poolNTIndex result name) cpInfo (CMethod cls name) = - CONSTANT_Methodref (poolIndex result cls) (poolIndex result name) + CONSTANT_Methodref (force "method a" $ poolClassIndex result cls) (force ("method b: " ++ show name) $ poolNTIndex result name) cpInfo (CIfaceMethod cls name) = - CONSTANT_InterfaceMethodref (poolIndex result cls) (poolIndex result name) - cpInfo (CString s) = CONSTANT_String (poolIndex result s) + CONSTANT_InterfaceMethodref (force "iface method a" $ poolIndex result cls) (force "iface method b" $ poolNTIndex result name) + cpInfo (CString s) = CONSTANT_String (force "string" $ poolIndex result s) cpInfo (CInteger x) = CONSTANT_Integer x cpInfo (CFloat x) = CONSTANT_Float x cpInfo (CLong x) = CONSTANT_Long (fromIntegral x) cpInfo (CDouble x) = CONSTANT_Double x cpInfo (CNameType n t) = - CONSTANT_NameAndType (poolIndex result n) (poolIndex result t) + CONSTANT_NameAndType (force "name" $ poolIndex result n) (force "type" $ poolIndex result t) cpInfo (CUTF8 s) = CONSTANT_Utf8 (fromIntegral $ B.length s) s cpInfo (CUnicode s) = CONSTANT_Unicode (fromIntegral $ B.length s) s -poolIndex :: [CpInfo] -> B.ByteString -> Word16 +-- | Find index of given string in the list of constants +poolIndex :: (Throws NoItemInPool e) => [CpInfo] -> B.ByteString -> EM e Word16 poolIndex list name = case findIndex test list of - Nothing -> error $ "Internal error: no such item in pool: " ++ toString name - Just i -> fromIntegral i + Nothing -> throw (NoItemInPool name) + Just i -> return $ fromIntegral $ i+1 where - test (CUTF8 s) | s == name = True - test (CUnicode s) | s == name = True - test _ = False - - + test (CONSTANT_Utf8 _ s) | s == name = True + test (CONSTANT_Unicode _ s) | s == name = True + test _ = False + +-- | Find index of given string in the list of constants +poolClassIndex :: (Throws NoItemInPool e) => [CpInfo] -> B.ByteString -> EM e Word16 +poolClassIndex list name = case findIndex checkString list of + Nothing -> throw (NoItemInPool name) + Just i -> case findIndex (checkClass $ fromIntegral $ i+1) list of + Nothing -> throw (NoItemInPool $ i+1) + Just j -> return $ fromIntegral $ j+1 + where + checkString (CONSTANT_Utf8 _ s) | s == name = True + checkString (CONSTANT_Unicode _ s) | s == name = True + checkString _ = False + + checkClass i (CONSTANT_Class x) | i == x = True + checkClass _ _ = False + +poolNTIndex list x@(NameType n t) = do + ni <- poolIndex list n + ti <- poolIndex list (byteString t) + case findIndex (check ni ti) list of + Nothing -> throw (NoItemInPool x) + Just i -> return $ fromIntegral (i+1) + where + check ni ti (CONSTANT_NameAndType n' t') + | (ni == n') && (ti == t') = True + check _ _ _ = False fieldInfo :: [CpInfo] -> Field -> FieldInfo fieldInfo pool (Field {..}) = FieldInfo { fieldAccessFlags = access2word16 fieldAccess, - fieldNameIndex = poolIndex pool fieldName, - fieldSignatureIndex = poolIndex pool (encode fieldSignature), + fieldNameIndex = force "field name" $ poolIndex pool fieldName, + fieldSignatureIndex = force "signature" $ poolIndex pool (encode fieldSignature), fieldAttributesCount = fromIntegral (M.size fieldAttrs), fieldAttributes = map (attrInfo pool) (M.assocs fieldAttrs) } methodInfo :: [CpInfo] -> Method -> MethodInfo methodInfo pool (Method {..}) = MethodInfo { methodAccessFlags = access2word16 methodAccess, - methodNameIndex = poolIndex pool methodName, - methodSignatureIndex = poolIndex pool (encode methodSignature), + methodNameIndex = force "method name" $ poolIndex pool methodName, + methodSignatureIndex = force "method sig" $ poolIndex pool (encode methodSignature), methodAttributesCount = fromIntegral (M.size methodAttrs), methodAttributes = map (attrInfo pool) (M.assocs methodAttrs) } attrInfo :: [CpInfo] -> (B.ByteString, B.ByteString) -> AttributeInfo attrInfo pool (name, value) = AttributeInfo { - attributeName = poolIndex pool name, + attributeName = force "attr name" $ poolIndex pool name, attributeLength = fromIntegral (B.length value), attributeValue = value } - constantPoolArray :: [CpInfo] -> Pool constantPoolArray list = pool where diff --git a/JVM/Exceptions.hs b/JVM/Exceptions.hs new file mode 100644 index 0000000..0f1f1df --- /dev/null +++ b/JVM/Exceptions.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE DeriveDataTypeable, ExistentialQuantification #-} +module JVM.Exceptions where + +import Control.Monad.Exception +import qualified Data.ByteString.Lazy as B + +import JVM.Types + +data NoItemInPool = forall a. Show a => NoItemInPool a + deriving (Typeable) + +instance Exception NoItemInPool + +instance Show NoItemInPool where + show (NoItemInPool s) = "Internal error: no such item in pool: <" ++ show s ++ ">" + +force :: String -> EM AnyException a -> a +force s x = + case tryEM x of + Right result -> result + Left exc -> error $ "Exception at " ++ s ++ ": " ++ show exc diff --git a/JVM/Types.hs b/JVM/Types.hs index 9c96144..b64da93 100644 --- a/JVM/Types.hs +++ b/JVM/Types.hs @@ -3,7 +3,10 @@ module JVM.Types where import Codec.Binary.UTF8.String hiding (encode, decode) +import Control.Applicative import Data.Array +import Data.Binary +import Data.Binary.Put import qualified Data.ByteString.Lazy as B import Data.Word import Data.Char @@ -22,6 +25,13 @@ toString bstr = decodeString $ map (chr . fromIntegral) $ B.unpack bstr -- | Constant pool type Pool = Array Word16 Constant +asize :: (Ix i) => Array i e -> Int +asize = length . elems + +showListIx :: (Show a) => [a] -> String +showListIx list = unlines $ zipWith s [1..] list + where s i x = show i ++ ":\t" ++ show x + class HasAttributes a where attributes :: a -> Attributes @@ -56,7 +66,7 @@ deriving instance Eq (Signature a) => Eq (NameType a) -- | Constant pool item data Constant = - CClass {className :: B.ByteString} + CClass B.ByteString | CField {refClass :: B.ByteString, fieldNameType :: NameType Field} | CMethod {refClass :: B.ByteString, nameType :: NameType Method} | CIfaceMethod {refClass :: B.ByteString, nameType :: NameType Method} @@ -70,6 +80,10 @@ data Constant = | CUnicode {getString :: B.ByteString} deriving (Eq) +className :: Constant -> B.ByteString +className (CClass s) = s +className x = error $ "Not a class: " ++ show x + instance Show Constant where show (CClass name) = "class " ++ toString name show (CField cls nt) = "field " ++ toString cls ++ "." ++ show nt @@ -139,3 +153,11 @@ data Attribute = Attribute { -- | Set of attributes type Attributes = M.Map B.ByteString B.ByteString +instance (Binary (Signature a)) => Binary (NameType a) where + put (NameType n t) = putLazyByteString n >> put t + + get = NameType <$> get <*> get + +byteString :: (Binary t) => t -> B.ByteString +byteString x = runPut (put x) + diff --git a/rebuild-class.hs b/rebuild-class.hs new file mode 100644 index 0000000..abe1918 --- /dev/null +++ b/rebuild-class.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE OverloadedStrings #-} + +import Control.Monad +import Data.Array +import Data.Binary +import System.Environment +import qualified Data.ByteString.Lazy as B +import Text.Printf + +import JVM.Types +import JVM.ClassFile +import JVM.Converter +import JVM.Assembler + +main = do + args <- getArgs + case args of + [clspath,outpath] -> do + cls <- parseClassFile clspath + clsfile <- decodeFile clspath :: IO ClassFile + 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 + putStrLn $ "Source pool:\n" ++ showListIx (constsPool clsfile) + let result = classFile cls + putStrLn $ "Result pool:\n" ++ showListIx (constsPool result) + B.writeFile outpath (encodeClass cls) + + _ -> error "Synopsis: rebuild-class File.class Output.class" -- 2.25.1