JVM/ClassFile.hs

   1 {-# LANGUAGE RecordWildCards, BangPatterns #-}
   2 module JVM.ClassFile where
   3
   4 import Control.Monad
   5 import Control.Applicative
   6 import Data.Binary
   7 import Data.Binary.IEEE754
   8 import Data.Binary.Get
   9 import Data.Binary.Put
  10 import Data.Word
  11 import Data.Char
  12 import Data.List
  13 import qualified Data.ByteString.Lazy as B
  14
  15 import Debug.Trace
  16
  17 traceS :: (Show a) => String -> a -> a
  18 traceS msg x = trace (msg ++ ": " ++ show x) x
  19
  20 char :: Word8 -> Char
  21 char n = chr (fromIntegral n)
  22
  23 getChar8 :: Get Char
  24 getChar8 = do
  25   x <- getWord8
  26   return (char x)
  27
  28 data ClassFile = ClassFile {
  29   magic :: Word32,
  30   minorVersion :: Word16,
  31   majorVersion :: Word16,
  32   constsPoolSize :: Word16,
  33   constsPool :: [CpInfo],
  34   accessFlags :: Word16,
  35   thisClass :: Word16,
  36   superClass :: Word16,
  37   interfacesCount :: Word16,
  38   interfaces :: [Word16],
  39   classFieldsCount :: Word16,
  40   classFields :: [FieldInfo],
  41   classMethodsCount :: Word16,
  42   classMethods :: [MethodInfo],
  43   classAttributesCount :: Word16,
  44   classAttributes :: [AttributeInfo]
  45   }
  46   deriving (Eq, Show)
  47
  48 traceM msg x = do
  49   r <- x
  50   return $ traceS msg r
  51
  52 replicateMT n m = replicateM n (traceM ">" m)
  53
  54 instance Binary ClassFile where
  55   put (ClassFile {..}) = do
  56     put magic
  57     put minorVersion
  58     put majorVersion
  59     put constsPoolSize
  60     forM_ constsPool put
  61     put accessFlags
  62     put thisClass
  63     put superClass
  64     put interfacesCount
  65     forM_ interfaces put
  66     put classFieldsCount
  67     forM_ classFields put
  68     put classMethodsCount
  69     forM_ classMethods put
  70     put classAttributesCount
  71     forM_ classAttributes put
  72
  73   get = do
  74     magic <- get
  75     minor <- get
  76     major <- get
  77     poolsize <- get
  78     pool <- replicateM (fromIntegral poolsize - 1) get
  79     af <- get
  80     this <- get
  81     super <- get
  82     interfacesCount <- get
  83     ifaces <- replicateM (fromIntegral interfacesCount) get
  84     classFieldsCount <- get
  85     classFields <- replicateM (fromIntegral classFieldsCount) get
  86     classMethodsCount <- get
  87     classMethods <- replicateM (fromIntegral classMethodsCount) get
  88     asCount <- get
  89     as <- replicateM (fromIntegral $ asCount - 1) get
  90     return $ ClassFile magic minor major poolsize pool af this super
  91                interfacesCount ifaces classFieldsCount classFields classMethodsCount classMethods asCount as
  92
  93 data FieldType =
  94     SignedByte -- B
  95   | CharByte   -- C
  96   | DoubleType -- D
  97   | FloatType  -- F
  98   | IntType    -- I
  99   | LongInt    -- J
 100   | ShortInt   -- S
 101   | BoolType   -- Z
 102   | ObjectType String -- L <class name>
 103   | Array (Maybe Int) FieldType
 104   deriving (Eq)
 105
 106 instance Show FieldType where
 107   show SignedByte = "byte"
 108   show CharByte = "char"
 109   show DoubleType = "double"
 110   show FloatType = "float"
 111   show IntType = "int"
 112   show LongInt = "long"
 113   show ShortInt = "short"
 114   show BoolType = "bool"
 115   show (ObjectType s) = "Object " ++ s
 116   show (Array Nothing t) = show t ++ "[]"
 117   show (Array (Just n) t) = show t ++ "[" ++ show n ++ "]"
 118
 119 type FieldSignature = FieldType
 120
 121 getInt :: Get (Maybe Int)
 122 getInt = do
 123     s <- getDigits
 124     if null s
 125       then return Nothing
 126       else return $ Just (read s)
 127   where
 128     getDigits :: Get [Char]
 129     getDigits = do
 130       c <- lookAhead getChar8
 131       if isDigit c
 132         then do
 133              skip 1
 134              next <- getDigits
 135              return (c: next)
 136         else return []
 137
 138 instance Binary FieldType where
 139   put SignedByte = put 'B'
 140   put CharByte   = put 'C'
 141   put DoubleType = put 'D'
 142   put FloatType  = put 'F'
 143   put IntType    = put 'I'
 144   put LongInt    = put 'J'
 145   put ShortInt   = put 'S'
 146   put BoolType   = put 'Z'
 147   put (ObjectType name) = put 'L' >> put name
 148   put (Array Nothing sig) = put '[' >> put sig
 149   put (Array (Just n) sig) = put '[' >> put (show n) >> put sig
 150
 151   get = do
 152     b <- getChar8
 153     case b of
 154       'B' -> return SignedByte
 155       'C' -> return CharByte
 156       'D' -> return DoubleType
 157       'F' -> return FloatType
 158       'I' -> return IntType
 159       'J' -> return LongInt
 160       'S' -> return ShortInt
 161       'Z' -> return BoolType
 162       'L' -> do
 163              name <- getToSemicolon
 164              return (ObjectType name)
 165       '[' -> do
 166              mbSize <- getInt
 167              sig <- get
 168              return (Array mbSize sig)
 169       _   -> fail $ "Unknown signature opening symbol: " ++ [b]
 170
 171 getToSemicolon :: Get String
 172 getToSemicolon = do
 173   x <- get
 174   if x == ';'
 175     then return []
 176     else do
 177          next <- getToSemicolon
 178          return (x: next)
 179
 180 data ReturnSignature =
 181     Returns FieldType
 182   | ReturnsVoid
 183   deriving (Eq)
 184
 185 instance Show ReturnSignature where
 186   show (Returns t) = show t
 187   show ReturnsVoid = "Void"
 188
 189 instance Binary ReturnSignature where
 190   put (Returns sig) = put sig
 191   put ReturnsVoid   = put 'V'
 192
 193   get = do
 194     x <- lookAhead getChar8
 195     case x of
 196       'V' -> skip 1 >> return ReturnsVoid
 197       _   -> Returns <$> get
 198
 199 type ArgumentSignature = FieldType
 200
 201 data MethodSignature =
 202     MethodSignature [ArgumentSignature] ReturnSignature
 203   deriving (Eq)
 204
 205 instance Show MethodSignature where
 206   show (MethodSignature args ret) = "(" ++ intercalate ", " (map show args) ++ ") returns " ++ show ret
 207
 208 instance Binary MethodSignature where
 209   put (MethodSignature args ret) = do
 210     put '('
 211     forM_ args put
 212     put ')'
 213     put ret
 214
 215   get =  do
 216     x <- getChar8
 217     when (x /= '(') $
 218       fail "Cannot parse method signature: no starting `(' !"
 219     args <- getArgs
 220     y <- getChar8
 221     when (y /= ')') $
 222       fail "Internal error: method signature without `)' !?"
 223     ret <- get
 224     return (MethodSignature args ret)
 225
 226 getArgs :: Get [ArgumentSignature]
 227 getArgs = whileJust getArg
 228   where
 229     getArg :: Get (Maybe ArgumentSignature)
 230     getArg = do
 231       x <- lookAhead getChar8
 232       if x == ')'
 233         then return Nothing
 234         else Just <$> get
 235
 236 whileJust :: (Monad m) => m (Maybe a) -> m [a]
 237 whileJust m = do
 238   r <- m
 239   case r of
 240     Just x -> do
 241               next <- whileJust m
 242               return (x: next)
 243     Nothing -> return []
 244
 245 data CpInfo =
 246     CONSTANT_Class {nameIndex :: Word16}                                          -- 7
 247   | CONSTANT_Fieldref {classIndex :: Word16, nameAndTypeIndex :: Word16}                -- 9
 248   | CONSTANT_Methodref  {classIndex :: Word16, nameAndTypeIndex :: Word16}        -- 10
 249   | CONSTANT_InterfaceMethodref {classIndex :: Word16, nameAndTypeIndex :: Word16}-- 11
 250   | CONSTANT_String {stringIndex :: Word16}                                       -- 8
 251   | CONSTANT_Integer {fourBytes :: Word32}                                            -- 3
 252   | CONSTANT_Float Float                                                          -- 4
 253   | CONSTANT_Long Word64                                                          -- 5
 254   | CONSTANT_Double Double                                                        -- 6
 255   | CONSTANT_NameAndType {nameIndex :: Word16, signatureIndex :: Word16}                -- 12
 256   | CONSTANT_Utf8 {stringLength :: Word16, stringBytes :: B.ByteString}               -- 1
 257   | CONSTANT_Unicode {stringLength :: Word16, stringBytes :: B.ByteString}          -- 2
 258   deriving (Eq, Show)
 259
 260 instance Binary CpInfo where
 261   put (CONSTANT_Class i) = putWord8 7 >> put i
 262   put (CONSTANT_Fieldref i j) = putWord8 9 >> put i >> put j
 263   put (CONSTANT_Methodref i j) = putWord8 10 >> put i >> put j
 264   put (CONSTANT_InterfaceMethodref i j) = putWord8 11 >> put i >> put j
 265   put (CONSTANT_String i) = putWord8 8 >> put i
 266   put (CONSTANT_Integer x) = putWord8 3 >> put x
 267   put (CONSTANT_Float x)   = putWord8 4 >> putFloat32be x
 268   put (CONSTANT_Long x)    = putWord8 5 >> put x
 269   put (CONSTANT_Double x)  = putWord8 6 >> putFloat64be x
 270   put (CONSTANT_NameAndType i j) = putWord8 12 >> put i >> put j
 271   put (CONSTANT_Utf8 l bs) = putWord8 1 >> put l >> putLazyByteString bs
 272   put (CONSTANT_Unicode l bs) = putWord8 2 >> put l >> putLazyByteString bs
 273
 274   get = do
 275     !offset <- bytesRead
 276     tag <- getWord8
 277     case tag of
 278       1 -> do
 279         l <- get
 280         bs <- getLazyByteString (fromIntegral l)
 281         return $ CONSTANT_Utf8 l bs
 282       2 -> do
 283         l <- get
 284         bs <- getLazyByteString (fromIntegral l)
 285         return $ CONSTANT_Unicode l bs
 286       3  -> CONSTANT_Integer   <$> get
 287       4  -> CONSTANT_Float     <$> getFloat32be
 288       5  -> CONSTANT_Long      <$> get
 289       6  -> CONSTANT_Double    <$> getFloat64be
 290       7  -> CONSTANT_Class     <$> get
 291       8  -> CONSTANT_String    <$> get
 292       9  -> CONSTANT_Fieldref  <$> get <*> get
 293       10 -> CONSTANT_Methodref <$> get <*> get
 294       11 -> CONSTANT_InterfaceMethodref <$> get <*> get
 295       12 -> CONSTANT_NameAndType <$> get <*> get
 296       _  -> fail $ "Unknown constants pool entry tag: " ++ show tag
 297
 298 data FieldInfo = FieldInfo {
 299   fieldAccessFlags :: Word16,
 300   fieldNameIndex :: Word16,
 301   fieldSignatureIndex :: Word16,
 302   fieldAttributesCount :: Word16,
 303   fieldAttributes :: [AttributeInfo] }
 304   deriving (Eq, Show)
 305
 306 instance Binary FieldInfo where
 307   put (FieldInfo {..}) = do
 308     put fieldAccessFlags
 309     put fieldNameIndex
 310     put fieldSignatureIndex
 311     put fieldAttributesCount
 312     forM_ fieldAttributes put
 313
 314   get = do
 315     af <- get
 316     ni <- get
 317     si <- get
 318     n <- get
 319     as <- replicateM (fromIntegral n) get
 320     return $ FieldInfo af ni si n as
 321
 322 data MethodInfo = MethodInfo {
 323   methodAccessFlags :: Word16,
 324   methodNameIndex :: Word16,
 325   methodSignatureIndex :: Word16,
 326   methodAttributesCount :: Word16,
 327   methodAttributes :: [AttributeInfo] }
 328   deriving (Eq, Show)
 329
 330 instance Binary MethodInfo where
 331   put (MethodInfo {..}) = do
 332     put methodAccessFlags
 333     put methodNameIndex
 334     put methodSignatureIndex
 335     put methodAttributesCount
 336     forM_ methodAttributes put
 337
 338   get = do
 339     offset <- bytesRead
 340     af <- get
 341     ni <- get
 342     si <- get
 343     n <- get
 344     as <- replicateM (fromIntegral n) get
 345     return $ MethodInfo af ni si n as
 346
 347 data AttributeInfo = AttributeInfo {
 348   attributeName :: Word16,
 349   attributeLength :: Word32,
 350   attributeValue :: B.ByteString }
 351   deriving (Eq, Show)
 352
 353 instance Binary AttributeInfo where
 354   put (AttributeInfo {..}) = do
 355     put attributeName
 356     putWord32be attributeLength
 357     putLazyByteString attributeValue
 358
 359   get = do
 360     offset <- bytesRead
 361     name <- get
 362     len <- getWord32be
 363     value <- getLazyByteString (fromIntegral len)
 364     return $ AttributeInfo name len value
 365
 366