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