From 55d6741452443c59d700c01de495f50b56eb6f30 Mon Sep 17 00:00:00 2001 From: "Ilya V. Portnov" Date: Fri, 30 Sep 2011 14:55:53 +0600 Subject: [PATCH] Use type families: done. --- JVM/Assembler.hs | 8 +++--- JVM/ClassFile.hs | 42 +++++++++++++++++++++++--------- JVM/Converter.hs | 63 +++++++++++++++++++++++++++++------------------- JVM/Dump.hs | 9 ++++--- JVM/Generator.hs | 54 ++++++++++++++++++++++++----------------- dump-class.hs | 3 ++- rebuild-class.hs | 7 +++--- 7 files changed, 115 insertions(+), 71 deletions(-) diff --git a/JVM/Assembler.hs b/JVM/Assembler.hs index 31e00fe..b29eae8 100644 --- a/JVM/Assembler.hs +++ b/JVM/Assembler.hs @@ -53,7 +53,7 @@ data Code = Code { codeExceptionsN :: Word16, codeExceptions :: [CodeException], codeAttrsN :: Word16, - codeAttributes :: [AttributeInfo] } + codeAttributes :: Attributes Pointers } deriving (Eq, Show) -- | Exception descriptor @@ -73,7 +73,7 @@ instance BinaryState Integer CodeException where get = CodeException <$> get <*> get <*> get <*> get -instance BinaryState Integer AttributeInfo where +instance BinaryState Integer Attribute where put a = do let sz = 6 + attributeLength a -- full size of AttributeInfo structure liftOffset (fromIntegral sz) Binary.put a @@ -89,7 +89,7 @@ instance BinaryState Integer Code where put codeExceptionsN forM_ codeExceptions put put codeAttrsN - forM_ codeAttributes put + forM_ (attributesList codeAttributes) put get = do stackSz <- get @@ -102,7 +102,7 @@ instance BinaryState Integer Code where excs <- replicateM (fromIntegral excn) get nAttrs <- get attrs <- replicateM (fromIntegral nAttrs) get - return $ Code stackSz locals len code excn excs nAttrs attrs + return $ Code stackSz locals len code excn excs nAttrs (AP attrs) -- | Read sequence of instructions (to end of stream) readInstructions :: GetState Integer [Instruction] diff --git a/JVM/ClassFile.hs b/JVM/ClassFile.hs index 87acae4..18c2526 100644 --- a/JVM/ClassFile.hs +++ b/JVM/ClassFile.hs @@ -14,7 +14,8 @@ module JVM.ClassFile HasSignature (..), HasAttributes (..), AccessFlag (..), AccessFlags, Attributes (..), - className + className, + apsize, arsize, arlist ) where @@ -56,10 +57,21 @@ type instance AccessFlags Pointers = Word16 type instance AccessFlags Resolved = S.Set AccessFlag -type family Attributes stage +data family Attributes stage -type instance Attributes Pointers = [Attribute] -type instance Attributes Resolved = M.Map B.ByteString B.ByteString +data instance Attributes Pointers = AP {attributesList :: [Attribute]} + deriving (Eq, Show) +data instance Attributes Resolved = AR (M.Map B.ByteString B.ByteString) + deriving (Eq, Show) + +arsize :: Attributes Resolved -> Int +arsize (AR m) = M.size m + +arlist :: Attributes Resolved -> [(B.ByteString, B.ByteString)] +arlist (AR m) = M.assocs m + +apsize :: Attributes Pointers -> Int +apsize (AP list) = length list -- | Access flags. Used for classess, methods, variables. data AccessFlag = @@ -102,7 +114,7 @@ instance (Binary (Signature a)) => Binary (NameType a) where -- | Constant pool item data Constant stage = - CClass B.ByteString + CClass (Link stage B.ByteString) | CField {refClass :: Link stage B.ByteString, fieldNameType :: Link stage (NameType Field)} | CMethod {refClass :: Link stage B.ByteString, nameType :: Link stage (NameType Method)} | CIfaceMethod {refClass :: Link stage B.ByteString, nameType :: Link stage (NameType Method)} @@ -177,7 +189,7 @@ instance Binary (Class Pointers) where put classMethodsCount forM_ classMethods put put classAttributesCount - forM_ classAttributes put + forM_ (attributesList classAttributes) put get = do magic <- get @@ -198,7 +210,8 @@ instance Binary (Class Pointers) where as <- replicateM (fromIntegral $ asCount) get let pool' = M.fromList $ zip [1..] pool return $ Class magic minor major poolsize pool' af this super - interfacesCount ifaces classFieldsCount classFields classMethodsCount classMethods asCount as + interfacesCount ifaces classFieldsCount classFields + classMethodsCount classMethods asCount (AP as) -- | Field signature format data FieldType = @@ -426,7 +439,7 @@ instance Binary (Field Pointers) where put fieldName put fieldSignature put fieldAttributesCount - forM_ fieldAttributes put + forM_ (attributesList fieldAttributes) put get = do af <- get @@ -434,11 +447,11 @@ instance Binary (Field Pointers) where si <- get n <- get as <- replicateM (fromIntegral n) get - return $ Field af ni si n as + return $ Field af ni si n (AP as) -- | Class method format data Method stage = Method { - methodAccessFlags :: Attributes stage, + methodAccessFlags :: AccessFlags stage, methodName :: Link stage B.ByteString, methodSignature :: Link stage MethodSignature, methodAttributesCount :: Word16, @@ -455,7 +468,7 @@ instance Binary (Method Pointers) where put methodName put methodSignature put methodAttributesCount - forM_ methodAttributes put + forM_ (attributesList methodAttributes) put get = do offset <- bytesRead @@ -464,7 +477,12 @@ instance Binary (Method Pointers) where si <- get n <- get as <- replicateM (fromIntegral n) get - return $ Method af ni si n as + return $ Method { + methodAccessFlags = af, + methodName = ni, + methodSignature = si, + methodAttributesCount = n, + methodAttributes = AP as } -- | Any (class/ field/ method/ ...) attribute format. -- Some formats specify special formats for @attributeValue@. diff --git a/JVM/Converter.hs b/JVM/Converter.hs index e53f380..82a1782 100644 --- a/JVM/Converter.hs +++ b/JVM/Converter.hs @@ -73,10 +73,12 @@ classFile (Class {..}) = Class { classFields = map (fieldInfo poolInfo) classFields, classMethodsCount = fromIntegral (length classMethods), classMethods = map (methodInfo poolInfo) classMethods, - classAttributesCount = fromIntegral (M.size classAttributes), - classAttributes = map (attrInfo poolInfo) (M.assocs classAttributes) } + classAttributesCount = fromIntegral $ arsize classAttributes, + classAttributes = to (arlist classAttributes) } where poolInfo = toCPInfo constsPool + to :: [(B.ByteString, B.ByteString)] -> Attributes Pointers + to pairs = AP (map (attrInfo poolInfo) pairs) toCPInfo :: Pool Resolved -> Pool Pointers toCPInfo pool = result @@ -98,12 +100,12 @@ toCPInfo pool = result cpInfo (CDouble x) = CDouble x cpInfo (CNameType n t) = CNameType (force "name" $ poolIndex result n) (force "type" $ poolIndex result t) - cpInfo (CUTF8 s) = CUTF8 (fromIntegral $ B.length s) s - cpInfo (CUnicode s) = CUnicode (fromIntegral $ B.length s) s + cpInfo (CUTF8 s) = CUTF8 s + cpInfo (CUnicode s) = CUnicode s -- | Find index of given string in the list of constants poolIndex :: (Throws NoItemInPool e) => Pool Pointers -> B.ByteString -> EM e Word16 -poolIndex list name = case findIndex test list of +poolIndex list name = case findIndex test (M.elems list) of Nothing -> throw (NoItemInPool name) Just i -> return $ fromIntegral $ i+1 where @@ -113,9 +115,9 @@ poolIndex list name = case findIndex test list of -- | Find index of given string in the list of constants poolClassIndex :: (Throws NoItemInPool e) => Pool Pointers -> B.ByteString -> EM e Word16 -poolClassIndex list name = case findIndex checkString list of +poolClassIndex list name = case findIndex checkString (M.elems list) of Nothing -> throw (NoItemInPool name) - Just i -> case findIndex (checkClass $ fromIntegral $ i+1) list of + Just i -> case findIndex (checkClass $ fromIntegral $ i+1) (M.elems list) of Nothing -> throw (NoItemInPool $ i+1) Just j -> return $ fromIntegral $ j+1 where @@ -129,7 +131,7 @@ poolClassIndex list name = case findIndex checkString list of poolNTIndex list x@(NameType n t) = do ni <- poolIndex list n ti <- poolIndex list (byteString t) - case findIndex (check ni ti) list of + case findIndex (check ni ti) (M.elems list) of Nothing -> throw (NoItemInPool x) Just i -> return $ fromIntegral (i+1) where @@ -139,21 +141,27 @@ poolNTIndex list x@(NameType n t) = do fieldInfo :: Pool Pointers -> Field Resolved -> Field Pointers fieldInfo pool (Field {..}) = Field { - fieldAccessFlags = access2word16 fieldAccessFlags, - fieldName = force "field name" $ poolIndex pool fieldName, - fieldSignature = force "signature" $ poolIndex pool (encode fieldSignature), - fieldAttributesCount = fromIntegral (M.size fieldAttributes), - fieldAttributes = map (attrInfo pool) (M.assocs fieldAttributes) } + fieldAccessFlags = access2word16 fieldAccessFlags, + fieldName = force "field name" $ poolIndex pool fieldName, + fieldSignature = force "signature" $ poolIndex pool (encode fieldSignature), + fieldAttributesCount = fromIntegral (arsize fieldAttributes), + fieldAttributes = to (arlist fieldAttributes) } + where + to :: [(B.ByteString, B.ByteString)] -> Attributes Pointers + to pairs = AP (map (attrInfo pool) pairs) methodInfo :: Pool Pointers -> Method Resolved -> Method Pointers methodInfo pool (Method {..}) = Method { - methodAccessFlags = access2word16 methodAccessFlags, - methodName = force "method name" $ poolIndex pool methodName, - methodSignature = force "method sig" $ poolIndex pool (encode methodSignature), - methodAttributesCount = fromIntegral (M.size methodAttributes), - methodAttributes = map (attrInfo pool) (M.assocs methodAttributes) } + methodAccessFlags = access2word16 methodAccessFlags, + methodName = force "method name" $ poolIndex pool methodName, + methodSignature = force "method sig" $ poolIndex pool (encode methodSignature), + methodAttributesCount = fromIntegral (arsize methodAttributes), + methodAttributes = to (arlist methodAttributes) } + where + to :: [(B.ByteString, B.ByteString)] -> Attributes Pointers + to pairs = AP (map (attrInfo pool) pairs) -attrInfo :: Pool Pointers -> (B.ByteString, B.ByteString) -> Attributes Pointers +attrInfo :: Pool Pointers -> (B.ByteString, B.ByteString) -> Attribute attrInfo pool (name, value) = Attribute { attributeName = force "attr name" $ poolIndex pool name, attributeLength = fromIntegral (B.length value), @@ -162,10 +170,10 @@ attrInfo pool (name, value) = Attribute { constantPoolArray :: Pool Pointers -> Pool Resolved constantPoolArray ps = pool where - pool :: Pool + pool :: Pool Resolved pool = M.map convert ps - n = fromIntegral $ length ps + n = fromIntegral $ M.size ps convertNameType :: (HasSignature a, Binary (Signature a)) => Word16 -> NameType a convertNameType i = @@ -182,8 +190,8 @@ constantPoolArray ps = pool convert (CLong x) = CLong (fromIntegral x) convert (CDouble x) = CDouble x convert (CNameType i j) = CNameType (getString $ pool ! i) (getString $ pool ! j) - convert (CUTF8 _ bs) = CUTF8 bs - convert (CUnicode _ bs) = CUnicode bs + convert (CUTF8 bs) = CUTF8 bs + convert (CUnicode bs) = CUnicode bs convertAccess :: AccessFlags Pointers -> AccessFlags Resolved convertAccess w = S.fromList $ concat $ zipWith (\i f -> if testBit w i then [f] else []) [0..] $ [ @@ -210,6 +218,7 @@ convertField pool (Field {..}) = Field { fieldAccessFlags = convertAccess fieldAccessFlags, fieldName = getString $ pool ! fieldName, fieldSignature = decode $ getString $ pool ! fieldSignature, + fieldAttributesCount = fromIntegral (apsize fieldAttributes), fieldAttributes = convertAttrs pool fieldAttributes } convertMethod :: Pool Resolved -> Method Pointers -> Method Resolved @@ -217,11 +226,13 @@ convertMethod pool (Method {..}) = Method { methodAccessFlags = convertAccess methodAccessFlags, methodName = getString $ pool ! methodName, methodSignature = decode $ getString $ pool ! methodSignature, + methodAttributesCount = fromIntegral (apsize methodAttributes), methodAttributes = convertAttrs pool methodAttributes } convertAttrs :: Pool Resolved -> Attributes Pointers -> Attributes Resolved -convertAttrs pool attrs = M.fromList $ map go attrs +convertAttrs pool (AP attrs) = AR (M.fromList $ map go attrs) where + go :: Attribute -> (B.ByteString, B.ByteString) go (Attribute {..}) = (getString $ pool ! attributeName, attributeValue) @@ -232,7 +243,9 @@ methodByName cls name = -- | Try to get object attribute by name attrByName :: (HasAttributes a) => a Resolved -> B.ByteString -> Maybe B.ByteString -attrByName x name = M.lookup name (attributes x) +attrByName x name = + let (AR m) = attributes x + in M.lookup name m -- | Try to get Code for class method (no Code for interface methods) methodCode :: Class Resolved diff --git a/JVM/Dump.hs b/JVM/Dump.hs index 2012c8b..02da46a 100644 --- a/JVM/Dump.hs +++ b/JVM/Dump.hs @@ -7,18 +7,19 @@ import qualified Data.ByteString.Lazy as B import Text.Printf import JVM.Types +import JVM.ClassFile import JVM.Converter import JVM.Assembler -dumpClass :: Class -> IO () +dumpClass :: Class Resolved -> IO () dumpClass cls = do putStr "Class: " - B.putStrLn (this cls) + B.putStrLn (thisClass cls) putStrLn "Constants pool:" - forM_ (M.assocs $ constantPool cls) $ \(i, c) -> + forM_ (M.assocs $ constsPool cls) $ \(i, c) -> putStrLn $ printf " #%d:\t%s" i (show c) putStrLn "Methods:" - forM_ (methods cls) $ \m -> do + forM_ (classMethods cls) $ \m -> do putStr ">> Method " B.putStr (methodName m) print (methodSignature m) diff --git a/JVM/Generator.hs b/JVM/Generator.hs index 6291b06..2ee0240 100644 --- a/JVM/Generator.hs +++ b/JVM/Generator.hs @@ -15,9 +15,9 @@ import JVM.Assembler data GState = GState { generated :: [Instruction], - currentPool :: Pool, - doneMethods :: [Method], - currentMethod :: Maybe Method} + currentPool :: Pool Resolved, + doneMethods :: [Method Resolved], + currentMethod :: Maybe (Method Resolved)} deriving (Eq,Show) emptyGState = GState { @@ -28,13 +28,13 @@ emptyGState = GState { type Generate a = State GState a -appendPool :: Constant -> Pool -> (Pool, Word16) +appendPool :: Constant Resolved -> Pool Resolved -> (Pool Resolved, Word16) appendPool c pool = let size = fromIntegral (M.size pool) pool' = M.insert size c pool in (pool', size) -addItem :: Constant -> Generate Word16 +addItem :: Constant Resolved -> Generate Word16 addItem c = do pool <- St.gets currentPool case lookupPool c pool of @@ -45,7 +45,7 @@ addItem c = do St.put $ st {currentPool = pool'} return (i+1) -lookupPool :: Constant -> Pool -> Maybe Word16 +lookupPool :: Constant Resolved -> Pool Resolved -> Maybe Word16 lookupPool c pool = fromIntegral `fmap` findIndex (== c) (M.elems pool) @@ -62,7 +62,7 @@ addSig c@(MethodSignature args ret) = do let bsig = encode c addItem (CUTF8 bsig) -addToPool :: Constant -> Generate Word16 +addToPool :: Constant Resolved -> Generate Word16 addToPool c@(CClass str) = do addItem (CUTF8 str) addItem c @@ -96,12 +96,12 @@ putInstruction instr = do i0 :: Instruction -> Generate () i0 = putInstruction -i1 :: (Word16 -> Instruction) -> Constant -> Generate () +i1 :: (Word16 -> Instruction) -> Constant Resolved -> Generate () i1 fn c = do ix <- addToPool c i0 (fn ix) -i8 :: (Word8 -> Instruction) -> Constant -> Generate () +i8 :: (Word8 -> Instruction) -> Constant Resolved -> Generate () i8 fn c = do ix <- addToPool c i0 (fn $ fromIntegral ix) @@ -112,10 +112,11 @@ startMethod flags name sig = do addSig sig st <- St.get let method = Method { - methodAccess = S.fromList flags, + methodAccessFlags = S.fromList flags, methodName = name, methodSignature = sig, - methodAttrs = M.empty } + methodAttributesCount = 0, + methodAttributes = AR M.empty } St.put $ st {generated = [], currentMethod = Just method } @@ -126,7 +127,8 @@ endMethod = do case m of Nothing -> fail "endMethod without startMethod!" Just method -> do - let method' = method {methodAttrs = M.fromList [("Code", encodeMethod code)] } + let method' = method {methodAttributes = AR $ M.fromList [("Code", encodeMethod code)], + methodAttributesCount = 1} st <- St.get St.put $ st {generated = [], currentMethod = Nothing, @@ -147,7 +149,7 @@ genCode st = Code { codeExceptionsN = 0, codeExceptions = [], codeAttrsN = 0, - codeAttributes = [] } + codeAttributes = AP [] } where len = fromIntegral $ B.length $ encodeInstructions (generated st) @@ -157,7 +159,7 @@ initClass name = do addToPool (CClass name) addToPool (CString "Code") -generate :: B.ByteString -> Generate () -> Class +generate :: B.ByteString -> Generate () -> Class Resolved generate name gen = let generator = do initClass name @@ -165,12 +167,20 @@ generate name gen = res = execState generator emptyGState code = genCode res in Class { - constantPool = currentPool res, - classAccess = S.fromList [ACC_PUBLIC, ACC_STATIC], - this = name, - super = Just "java/lang/Object", - implements = [], - fields = [], - methods = doneMethods res, - classAttrs = M.empty } + magic = 0xCAFEBABE, + minorVersion = 0, + majorVersion = 50, + constsPoolSize = fromIntegral $ M.size (currentPool res), + constsPool = currentPool res, + accessFlags = S.fromList [ACC_PUBLIC, ACC_STATIC], + thisClass = name, + superClass = "java/lang/Object", + interfacesCount = 0, + interfaces = [], + classFieldsCount = 0, + classFields = [], + classMethodsCount = fromIntegral $ length (doneMethods res), + classMethods = doneMethods res, + classAttributesCount = 0, + classAttributes = AR M.empty } diff --git a/dump-class.hs b/dump-class.hs index 3c52965..86e714f 100644 --- a/dump-class.hs +++ b/dump-class.hs @@ -7,6 +7,7 @@ import Data.Binary import System.Environment import qualified Data.ByteString.Lazy as B import Text.Printf +import qualified Data.Map as M import JVM.Types import JVM.ClassFile @@ -18,7 +19,7 @@ main = do case args of [clspath] -> do clsFile <- decodeFile clspath - putStrLn $ showListIx $ constsPool clsFile + putStrLn $ showListIx $ M.elems $ constsPool (clsFile :: Class Pointers) cls <- parseClassFile clspath dumpClass cls _ -> error "Synopsis: dump-class File.class" diff --git a/rebuild-class.hs b/rebuild-class.hs index 1265cf1..337c5b2 100644 --- a/rebuild-class.hs +++ b/rebuild-class.hs @@ -6,6 +6,7 @@ import Data.Binary import System.Environment import qualified Data.ByteString.Lazy as B import Text.Printf +import qualified Data.Map as M import JVM.Types import JVM.ClassFile @@ -18,11 +19,11 @@ main = do case args of [clspath,outpath] -> do cls <- parseClassFile clspath - clsfile <- decodeFile clspath :: IO ClassFile + clsfile <- decodeFile clspath :: IO (Class Pointers) dumpClass cls - putStrLn $ "Source pool:\n" ++ showListIx (constsPool clsfile) + putStrLn $ "Source pool:\n" ++ showListIx (M.elems $ constsPool clsfile) let result = classFile cls - putStrLn $ "Result pool:\n" ++ showListIx (constsPool result) + putStrLn $ "Result pool:\n" ++ showListIx (M.elems $ constsPool result) B.writeFile outpath (encodeClass cls) _ -> error "Synopsis: rebuild-class File.class Output.class" -- 2.25.1