diff --git a/JVM/Assembler.hs b/JVM/Assembler.hs new file mode 100644 --- /dev/null +++ b/JVM/Assembler.hs @@ -0,0 +1,716 @@ +{-# LANGUAGE TypeFamilies, StandaloneDeriving, FlexibleInstances, + FlexibleContexts, UndecidableInstances, RecordWildCards, OverloadedStrings, + TypeSynonymInstances, MultiParamTypeClasses #-} +-- | This module declares data type for JVM instructions, and BinaryState +-- instances to read/write them. +module JVM.Assembler + (Instruction (..), + ArrayType (..), + CodeException (..), + Code (..), + IMM (..), + CMP (..), + encodeMethod, + decodeMethod + ) + where + +import Control.Monad +import Control.Applicative +import Data.Word +import qualified Data.Binary as Binary +import qualified Data.ByteString.Lazy as B +import Data.Array + +import Data.BinaryState +import JVM.ClassFile + +-- | Immediate constant. Corresponding value will be added to base opcode. +data IMM = + I0 -- ^ 0 + | I1 -- ^ 1 + | I2 -- ^ 2 + | I3 -- ^ 3 + deriving (Eq, Ord, Enum, Show) + +-- | Comparation operation type. Not all CMP instructions support all operations. +data CMP = + C_EQ + | C_NE + | C_LT + | C_GE + | C_GT + | C_LE + deriving (Eq, Ord, Enum, Show) + +-- | Format of Code method attribute. +data Code = Code { + codeStackSize :: Word16, + codeMaxLocals :: Word16, + codeLength :: Word32, + codeInstructions :: [Instruction], + codeExceptionsN :: Word16, + codeExceptions :: [CodeException], + codeAttrsN :: Word16, + codeAttributes :: [AttributeInfo] } + deriving (Eq, Show) + +-- | Exception descriptor +data CodeException = CodeException { + eStartPC :: Word16, + eEndPC :: Word16, + eHandlerPC :: Word16, + eCatchType :: Word16 } + deriving (Eq, Show) + +instance BinaryState Integer CodeException where + put (CodeException {..}) = do + put eStartPC + put eEndPC + put eHandlerPC + put eCatchType + + get = CodeException <$> get <*> get <*> get <*> get + +instance BinaryState Integer AttributeInfo where + put a = do + let sz = 6 + attributeLength a -- full size of AttributeInfo structure + liftOffset (fromIntegral sz) Binary.put a + + get = getZ + +instance BinaryState Integer Code where + put (Code {..}) = do + put codeStackSize + put codeMaxLocals + put codeLength + forM_ codeInstructions put + put codeExceptionsN + forM_ codeExceptions put + put codeAttrsN + forM_ codeAttributes put + + get = do + stackSz <- get + locals <- get + len <- get + bytes <- replicateM (fromIntegral len) get + let bytecode = B.pack bytes + code = decodeWith readInstructions 0 bytecode + excn <- get + excs <- replicateM (fromIntegral excn) get + nAttrs <- get + attrs <- replicateM (fromIntegral nAttrs) get + return $ Code stackSz locals len code excn excs nAttrs attrs + +-- | Read sequence of instructions (to end of stream) +readInstructions :: GetState Integer [Instruction] +readInstructions = do + end <- isEmpty + if end + then return [] + else do + x <- get + next <- readInstructions + return (x: next) + +-- | JVM instruction set +data Instruction = + NOP -- ^ 0 + | ACONST_NULL -- ^ 1 + | ICONST_M1 -- ^ 2 + | ICONST_0 -- ^ 3 + | ICONST_1 -- ^ 4 + | ICONST_2 -- ^ 5 + | ICONST_3 -- ^ 6 + | ICONST_4 -- ^ 7 + | ICONST_5 -- ^ 8 + | LCONST_0 -- ^ 9 + | LCONST_1 -- ^ 10 + | FCONST_0 -- ^ 11 + | FCONST_1 -- ^ 12 + | FCONST_2 -- ^ 13 + | DCONST_0 -- ^ 14 + | DCONST_1 -- ^ 15 + | BIPUSH Word8 -- ^ 16 + | SIPUSH Word16 -- ^ 17 + | LDC1 Word8 -- ^ 18 + | LDC2 Word16 -- ^ 19 + | LDC2W Word16 -- ^ 20 + | ILOAD Word8 -- ^ 21 + | LLOAD Word8 -- ^ 22 + | FLOAD Word8 -- ^ 23 + | DLOAD Word8 -- ^ 24 + | ALOAD Word8 -- ^ 25 + | ILOAD_ IMM -- ^ 26, 27, 28, 29 + | LLOAD_ IMM -- ^ 30, 31, 32, 33 + | FLOAD_ IMM -- ^ 34, 35, 36, 37 + | DLOAD_ IMM -- ^ 38, 39, 40, 41 + | ALOAD_ IMM -- ^ 42, 43, 44, 45 + | IALOAD -- ^ 46 + | LALOAD -- ^ 47 + | FALOAD -- ^ 48 + | DALOAD -- ^ 49 + | AALOAD -- ^ 50 + | BALOAD -- ^ 51 + | CALOAD -- ^ 52 + | SALOAD -- ^ 53 + | ISTORE Word8 -- ^ 54 + | LSTORE Word8 -- ^ 55 + | FSTORE Word8 -- ^ 56 + | DSTORE Word8 -- ^ 57 + | ASTORE Word8 -- ^ 58 + | ISTORE_ IMM -- ^ 59, 60, 61, 62 + | LSTORE_ IMM -- ^ 63, 64, 65, 66 + | FSTORE_ IMM -- ^ 67, 68, 69, 70 + | DSTORE_ IMM -- ^ 71, 72, 73, 74 + | ASTORE_ IMM -- ^ 75, 76, 77, 78 + | IASTORE -- ^ 79 + | LASTORE -- ^ 80 + | FASTORE -- ^ 81 + | DASTORE -- ^ 82 + | AASTORE -- ^ 83 + | BASTORE -- ^ 84 + | CASTORE -- ^ 85 + | SASTORE -- ^ 86 + | POP -- ^ 87 + | POP2 -- ^ 88 + | DUP -- ^ 89 + | DUP_X1 -- ^ 90 + | DUP_X2 -- ^ 91 + | DUP2 -- ^ 92 + | DUP2_X1 -- ^ 93 + | DUP2_X2 -- ^ 94 + | SWAP -- ^ 95 + | IADD -- ^ 96 + | LADD -- ^ 97 + | FADD -- ^ 98 + | DADD -- ^ 99 + | ISUB -- ^ 100 + | LSUB -- ^ 101 + | FSUB -- ^ 102 + | DSUB -- ^ 103 + | IMUL -- ^ 104 + | LMUL -- ^ 105 + | FMUL -- ^ 106 + | DMUL -- ^ 107 + | IDIV -- ^ 108 + | LDIV -- ^ 109 + | FDIV -- ^ 110 + | DDIV -- ^ 111 + | IREM -- ^ 112 + | LREM -- ^ 113 + | FREM -- ^ 114 + | DREM -- ^ 115 + | INEG -- ^ 116 + | LNEG -- ^ 117 + | FNEG -- ^ 118 + | DNEG -- ^ 119 + | ISHL -- ^ 120 + | LSHL -- ^ 121 + | ISHR -- ^ 122 + | LSHR -- ^ 123 + | IUSHR -- ^ 124 + | LUSHR -- ^ 125 + | IAND -- ^ 126 + | LAND -- ^ 127 + | IOR -- ^ 128 + | LOR -- ^ 129 + | IXOR -- ^ 130 + | LXOR -- ^ 131 + | IINC Word8 Word8 -- ^ 132 + | I2L -- ^ 133 + | I2F -- ^ 134 + | I2D -- ^ 135 + | L2I -- ^ 136 + | L2F -- ^ 137 + | L2D -- ^ 138 + | F2I -- ^ 139 + | F2L -- ^ 140 + | F2D -- ^ 141 + | D2I -- ^ 142 + | D2L -- ^ 143 + | D2F -- ^ 144 + | I2B -- ^ 145 + | I2C -- ^ 146 + | I2S -- ^ 147 + | LCMP -- ^ 148 + | FCMP CMP -- ^ 149, 150 + | DCMP CMP -- ^ 151, 152 + | IF CMP -- ^ 153, 154, 155, 156, 157, 158 + | IF_ICMP CMP Word16 -- ^ 159, 160, 161, 162, 163, 164 + | IF_ACMP CMP Word16 -- ^ 165, 166 + | GOTO -- ^ 167 + | JSR Word16 -- ^ 168 + | RET -- ^ 169 + | TABLESWITCH Word32 Word32 Word32 [Word32] -- ^ 170 + | LOOKUPSWITCH Word32 Word32 [(Word32, Word32)] -- ^ 171 + | IRETURN -- ^ 172 + | LRETURN -- ^ 173 + | FRETURN -- ^ 174 + | DRETURN -- ^ 175 + | RETURN -- ^ 177 + | GETSTATIC Word16 -- ^ 178 + | PUTSTATIC Word16 -- ^ 179 + | GETFIELD Word16 -- ^ 180 + | PUTFIELD Word16 -- ^ 181 + | INVOKEVIRTUAL Word16 -- ^ 182 + | INVOKESPECIAL Word16 -- ^ 183 + | INVOKESTATIC Word16 -- ^ 184 + | INVOKEINTERFACE Word16 Word8 -- ^ 185 + | NEW Word16 -- ^ 187 + | NEWARRAY Word8 -- ^ 188, see @ArrayType@ + | ANEWARRAY Word16 -- ^ 189 + | ARRAYLENGTH -- ^ 190 + | ATHROW -- ^ 191 + | CHECKCAST Word16 -- ^ 192 + | INSTANCEOF Word16 -- ^ 193 + | MONITORENTER -- ^ 194 + | MONITOREXIT -- ^ 195 + | WIDE Word8 Instruction -- ^ 196 + | MULTINANEWARRAY Word16 Word8 -- ^ 197 + | IFNULL Word16 -- ^ 198 + | IFNONNULL Word16 -- ^ 199 + | GOTO_W Word32 -- ^ 200 + | JSR_W Word32 -- ^ 201 + deriving (Eq, Show) + +-- | JVM array type (primitive types) +data ArrayType = + T_BOOLEAN -- ^ 4 + | T_CHAR -- ^ 5 + | T_FLOAT -- ^ 6 + | T_DOUBLE -- ^ 7 + | T_BYTE -- ^ 8 + | T_SHORT -- ^ 9 + | T_INT -- ^ 10 + | T_LONG -- ^ 11 + deriving (Eq, Show, Enum) + +-- | Parse opcode with immediate constant +imm :: Word8 -- ^ Base opcode + -> (IMM -> Instruction) -- ^ Instruction constructor + -> Word8 -- ^ Opcode to parse + -> GetState s Instruction +imm base constr x = return $ constr $ toEnum $ fromIntegral (x-base) + +-- | Put opcode with immediate constant +putImm :: Word8 -- ^ Base opcode + -> IMM -- ^ Constant to add to opcode + -> PutState Integer () +putImm base i = putByte $ base + (fromIntegral $ fromEnum i) + +atype2byte :: ArrayType -> Word8 +atype2byte T_BOOLEAN = 4 +atype2byte T_CHAR = 5 +atype2byte T_FLOAT = 6 +atype2byte T_DOUBLE = 7 +atype2byte T_BYTE = 8 +atype2byte T_SHORT = 9 +atype2byte T_INT = 10 +atype2byte T_LONG = 11 + +byte2atype :: Word8 -> GetState s ArrayType +byte2atype 4 = return T_BOOLEAN +byte2atype 5 = return T_CHAR +byte2atype 6 = return T_FLOAT +byte2atype 7 = return T_DOUBLE +byte2atype 8 = return T_BYTE +byte2atype 9 = return T_SHORT +byte2atype 10 = return T_INT +byte2atype 11 = return T_LONG +byte2atype x = fail $ "Unknown array type byte: " ++ show x + +instance BinaryState Integer ArrayType where + get = do + x <- getByte + byte2atype x + + put t = putByte (atype2byte t) + +-- | Put opcode with one argument +put1 :: (BinaryState Integer a) + => Word8 -- ^ Opcode + -> a -- ^ First argument + -> PutState Integer () +put1 code x = do + putByte code + put x + +put2 :: (BinaryState Integer a, BinaryState Integer b) + => Word8 -- ^ Opcode + -> a -- ^ First argument + -> b -- ^ Second argument + -> PutState Integer () +put2 code x y = do + putByte code + put x + put y + +instance BinaryState Integer Instruction where + put NOP = putByte 0 + put ACONST_NULL = putByte 1 + put ICONST_M1 = putByte 2 + put ICONST_0 = putByte 3 + put ICONST_1 = putByte 4 + put ICONST_2 = putByte 5 + put ICONST_3 = putByte 6 + put ICONST_4 = putByte 7 + put ICONST_5 = putByte 8 + put LCONST_0 = putByte 9 + put LCONST_1 = putByte 10 + put FCONST_0 = putByte 11 + put FCONST_1 = putByte 12 + put FCONST_2 = putByte 13 + put DCONST_0 = putByte 14 + put DCONST_1 = putByte 15 + put (BIPUSH x) = put1 16 x + put (SIPUSH x) = put1 17 x + put (LDC1 x) = put1 18 x + put (LDC2 x) = put1 19 x + put (LDC2W x) = put1 20 x + put (ILOAD x) = put1 21 x + put (LLOAD x) = put1 22 x + put (FLOAD x) = put1 23 x + put (DLOAD x) = put1 24 x + put (ALOAD x) = put1 25 x + put (ILOAD_ i) = putImm 26 i + put (LLOAD_ i) = putImm 30 i + put (FLOAD_ i) = putImm 34 i + put (DLOAD_ i) = putImm 38 i + put (ALOAD_ i) = putImm 42 i + put IALOAD = putByte 46 + put LALOAD = putByte 47 + put FALOAD = putByte 48 + put DALOAD = putByte 49 + put AALOAD = putByte 50 + put BALOAD = putByte 51 + put CALOAD = putByte 52 + put SALOAD = putByte 53 + put (ISTORE x) = put1 54 x + put (LSTORE x) = put1 55 x + put (FSTORE x) = put1 56 x + put (DSTORE x) = put1 57 x + put (ASTORE x) = put1 58 x + put (ISTORE_ i) = putImm 59 i + put (LSTORE_ i) = putImm 63 i + put (FSTORE_ i) = putImm 67 i + put (DSTORE_ i) = putImm 71 i + put (ASTORE_ i) = putImm 75 i + put IASTORE = putByte 79 + put LASTORE = putByte 80 + put FASTORE = putByte 81 + put DASTORE = putByte 82 + put AASTORE = putByte 83 + put BASTORE = putByte 84 + put CASTORE = putByte 85 + put SASTORE = putByte 86 + put POP = putByte 87 + put POP2 = putByte 88 + put DUP = putByte 89 + put DUP_X1 = putByte 90 + put DUP_X2 = putByte 91 + put DUP2 = putByte 92 + put DUP2_X1 = putByte 93 + put DUP2_X2 = putByte 94 + put SWAP = putByte 95 + put IADD = putByte 96 + put LADD = putByte 97 + put FADD = putByte 98 + put DADD = putByte 99 + put ISUB = putByte 100 + put LSUB = putByte 101 + put FSUB = putByte 102 + put DSUB = putByte 103 + put IMUL = putByte 104 + put LMUL = putByte 105 + put FMUL = putByte 106 + put DMUL = putByte 107 + put IDIV = putByte 108 + put LDIV = putByte 109 + put FDIV = putByte 110 + put DDIV = putByte 111 + put IREM = putByte 112 + put LREM = putByte 113 + put FREM = putByte 114 + put DREM = putByte 115 + put INEG = putByte 116 + put LNEG = putByte 117 + put FNEG = putByte 118 + put DNEG = putByte 119 + put ISHL = putByte 120 + put LSHL = putByte 121 + put ISHR = putByte 122 + put LSHR = putByte 123 + put IUSHR = putByte 124 + put LUSHR = putByte 125 + put IAND = putByte 126 + put LAND = putByte 127 + put IOR = putByte 128 + put LOR = putByte 129 + put IXOR = putByte 130 + put LXOR = putByte 131 + put (IINC x y) = put2 132 x y + put I2L = putByte 133 + put I2F = putByte 134 + put I2D = putByte 135 + put L2I = putByte 136 + put L2F = putByte 137 + put L2D = putByte 138 + put F2I = putByte 139 + put F2L = putByte 140 + put F2D = putByte 141 + put D2I = putByte 142 + put D2L = putByte 143 + put D2F = putByte 144 + put I2B = putByte 145 + put I2C = putByte 146 + put I2S = putByte 147 + put LCMP = putByte 148 + put (FCMP C_LT) = putByte 149 + put (FCMP C_GT) = putByte 150 + put (FCMP c) = fail $ "No such instruction: FCMP " ++ show c + put (DCMP C_LT) = putByte 151 + put (DCMP C_GT) = putByte 152 + put (DCMP c) = fail $ "No such instruction: DCMP " ++ show c + put (IF c) = putByte (fromIntegral $ 153 + fromEnum c) + put (IF_ACMP C_EQ x) = put1 165 x + put (IF_ACMP C_NE x) = put1 166 x + put (IF_ACMP c _) = fail $ "No such instruction: IF_ACMP " ++ show c + put (IF_ICMP c x) = putByte (fromIntegral $ 159 + fromEnum c) >> put x + put GOTO = putByte 167 + put (JSR x) = put1 168 x + put RET = putByte 169 + put (TABLESWITCH def low high offs) = do + putByte 170 + offset <- getOffset + let pads = 4 - (offset `mod` 4) + replicateM (fromIntegral pads) (putByte 0) + put low + put high + forM_ offs put + put (LOOKUPSWITCH def n pairs) = do + putByte 171 + offset <- getOffset + let pads = 4 - (offset `mod` 4) + replicateM (fromIntegral pads) (putByte 0) + put def + put n + forM_ pairs put + put IRETURN = putByte 172 + put LRETURN = putByte 173 + put FRETURN = putByte 174 + put DRETURN = putByte 175 + put RETURN = putByte 177 + put (GETSTATIC x) = put1 178 x + put (PUTSTATIC x) = put1 179 x + put (GETFIELD x) = put1 180 x + put (PUTFIELD x) = put1 181 x + put (INVOKEVIRTUAL x) = put1 182 x + put (INVOKESPECIAL x) = put1 183 x + put (INVOKESTATIC x) = put1 184 x + put (INVOKEINTERFACE x c) = put2 185 x c >> putByte 0 + put (NEW x) = put1 187 x + put (NEWARRAY x) = put1 188 x + put (ANEWARRAY x) = put1 189 x + put ARRAYLENGTH = putByte 190 + put ATHROW = putByte 191 + put (CHECKCAST x) = put1 192 x + put (INSTANCEOF x) = put1 193 x + put MONITORENTER = putByte 194 + put MONITOREXIT = putByte 195 + put (WIDE x inst) = put2 196 x inst + put (MULTINANEWARRAY x y) = put2 197 x y + put (IFNULL x) = put1 198 x + put (IFNONNULL x) = put1 199 x + put (GOTO_W x) = put1 200 x + put (JSR_W x) = put1 201 x + + get = do + c <- getByte + case c of + 0 -> return NOP + 1 -> return ACONST_NULL + 2 -> return ICONST_M1 + 3 -> return ICONST_0 + 4 -> return ICONST_1 + 5 -> return ICONST_2 + 6 -> return ICONST_3 + 7 -> return ICONST_4 + 8 -> return ICONST_5 + 9 -> return LCONST_0 + 10 -> return LCONST_1 + 11 -> return FCONST_0 + 12 -> return FCONST_1 + 13 -> return FCONST_2 + 14 -> return DCONST_0 + 15 -> return DCONST_1 + 16 -> BIPUSH <$> get + 17 -> SIPUSH <$> get + 18 -> LDC1 <$> get + 19 -> LDC2 <$> get + 20 -> LDC2W <$> get + 21 -> ILOAD <$> get + 22 -> LLOAD <$> get + 23 -> FLOAD <$> get + 24 -> DLOAD <$> get + 25 -> ALOAD <$> get + 46 -> return IALOAD + 47 -> return LALOAD + 48 -> return FALOAD + 49 -> return DALOAD + 50 -> return AALOAD + 51 -> return BALOAD + 52 -> return CALOAD + 53 -> return SALOAD + 54 -> ISTORE <$> get + 55 -> LSTORE <$> get + 56 -> FSTORE <$> get + 57 -> DSTORE <$> get + 58 -> ASTORE <$> get + 79 -> return IASTORE + 80 -> return LASTORE + 81 -> return FASTORE + 82 -> return DASTORE + 83 -> return AASTORE + 84 -> return BASTORE + 85 -> return CASTORE + 86 -> return SASTORE + 87 -> return POP + 88 -> return POP2 + 89 -> return DUP + 90 -> return DUP_X1 + 91 -> return DUP_X2 + 92 -> return DUP2 + 93 -> return DUP2_X1 + 94 -> return DUP2_X2 + 95 -> return SWAP + 96 -> return IADD + 97 -> return LADD + 98 -> return FADD + 99 -> return DADD + 100 -> return ISUB + 101 -> return LSUB + 102 -> return FSUB + 103 -> return DSUB + 104 -> return IMUL + 105 -> return LMUL + 106 -> return FMUL + 107 -> return DMUL + 108 -> return IDIV + 109 -> return LDIV + 110 -> return FDIV + 111 -> return DDIV + 112 -> return IREM + 113 -> return LREM + 114 -> return FREM + 115 -> return DREM + 116 -> return INEG + 117 -> return LNEG + 118 -> return FNEG + 119 -> return DNEG + 120 -> return ISHL + 121 -> return LSHL + 122 -> return ISHR + 123 -> return LSHR + 124 -> return IUSHR + 125 -> return LUSHR + 126 -> return IAND + 127 -> return LAND + 128 -> return IOR + 129 -> return LOR + 130 -> return IXOR + 131 -> return LXOR + 132 -> IINC <$> get <*> get + 133 -> return I2L + 134 -> return I2F + 135 -> return I2D + 136 -> return L2I + 137 -> return L2F + 138 -> return L2D + 139 -> return F2I + 140 -> return F2L + 141 -> return F2D + 142 -> return D2I + 143 -> return D2L + 144 -> return D2F + 145 -> return I2B + 146 -> return I2C + 147 -> return I2S + 148 -> return LCMP + 149 -> return $ FCMP C_LT + 150 -> return $ FCMP C_GT + 151 -> return $ DCMP C_LT + 152 -> return $ DCMP C_GT + 165 -> IF_ACMP C_EQ <$> get + 166 -> IF_ACMP C_NE <$> get + 167 -> return GOTO + 168 -> JSR <$> get + 169 -> return RET + 170 -> do + offset <- bytesRead + let pads = 4 - (offset `mod` 4) + skip (fromIntegral pads) + def <- get + low <- get + high <- get + offs <- replicateM (fromIntegral $ high - low + 1) get + return $ TABLESWITCH def low high offs + 171 -> do + offset <- bytesRead + let pads = 4 - (offset `mod` 4) + skip (fromIntegral pads) + def <- get + n <- get + pairs <- replicateM (fromIntegral n) get + return $ LOOKUPSWITCH def n pairs + 172 -> return IRETURN + 173 -> return LRETURN + 174 -> return FRETURN + 175 -> return DRETURN + 177 -> return RETURN + 178 -> GETSTATIC <$> get + 179 -> PUTSTATIC <$> get + 180 -> GETFIELD <$> get + 181 -> PUTFIELD <$> get + 182 -> INVOKEVIRTUAL <$> get + 183 -> INVOKESPECIAL <$> get + 184 -> INVOKESTATIC <$> get + 185 -> (INVOKEINTERFACE <$> get <*> get) <* skip 1 + 187 -> NEW <$> get + 188 -> NEWARRAY <$> get + 189 -> ANEWARRAY <$> get + 190 -> return ARRAYLENGTH + 191 -> return ATHROW + 192 -> CHECKCAST <$> get + 193 -> INSTANCEOF <$> get + 194 -> return MONITORENTER + 195 -> return MONITOREXIT + 196 -> WIDE <$> get <*> get + 197 -> MULTINANEWARRAY <$> get <*> get + 198 -> IFNULL <$> get + 199 -> IFNONNULL <$> get + 200 -> GOTO_W <$> get + 201 -> JSR_W <$> get + _ | inRange (59, 62) c -> imm 59 ISTORE_ c + | inRange (63, 66) c -> imm 63 LSTORE_ c + | inRange (67, 70) c -> imm 67 FSTORE_ c + | inRange (71, 74) c -> imm 71 DSTORE_ c + | inRange (75, 78) c -> imm 75 ASTORE_ c + | inRange (26, 29) c -> imm 26 ILOAD_ c + | inRange (30, 33) c -> imm 30 LLOAD_ c + | inRange (34, 37) c -> imm 34 FLOAD_ c + | inRange (38, 41) c -> imm 38 DLOAD_ c + | inRange (42, 45) c -> imm 42 ALOAD_ 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 + +-- | Decode Java method +decodeMethod :: B.ByteString -> Code +decodeMethod str = decodeS (0 :: Integer) str + +-- | Encode Java method +encodeMethod :: Code -> B.ByteString +encodeMethod code = encodeS (0 :: Integer) code + diff --git a/JVM/ClassFile.hs b/JVM/ClassFile.hs new file mode 100644 --- /dev/null +++ b/JVM/ClassFile.hs @@ -0,0 +1,380 @@ +{-# LANGUAGE RecordWildCards, BangPatterns #-} +-- | This module declares (low-level) data types for Java .class files +-- structures, and Binary instances to read/write them. +module JVM.ClassFile + (ClassFile (..), + CpInfo (..), + FieldInfo (..), + MethodInfo (..), + AttributeInfo (..), + FieldType (..), + FieldSignature, MethodSignature (..), ReturnSignature (..), + ArgumentSignature (..) + ) + where + +import Control.Monad +import Control.Applicative +import Data.Binary +import Data.Binary.IEEE754 +import Data.Binary.Get +import Data.Binary.Put +import Data.Char +import Data.List +import qualified Data.ByteString.Lazy as B + +-- | Read one-byte Char +getChar8 :: Get Char +getChar8 = do + x <- getWord8 + return $ chr (fromIntegral x) + +-- | Generic .class file format +data ClassFile = ClassFile { + magic :: Word32, -- ^ Magic value: 0xCAFEBABE + minorVersion :: Word16, + majorVersion :: Word16, + constsPoolSize :: Word16, -- ^ Number of items in constants pool + constsPool :: [CpInfo], -- ^ Constants pool itself + accessFlags :: Word16, -- ^ See @JVM.Types.AccessFlag@ + thisClass :: Word16, -- ^ Constants pool item index for this class + superClass :: Word16, -- ^ --/-- for super class, zero for java.lang.Object + interfacesCount :: Word16, -- ^ Number of implemented interfaces + interfaces :: [Word16], -- ^ Constants pool item indexes for implemented interfaces + classFieldsCount :: Word16, -- ^ Number of class fileds + classFields :: [FieldInfo], -- ^ Class fields + classMethodsCount :: Word16, -- ^ Number of class methods + classMethods :: [MethodInfo], -- ^ Class methods + classAttributesCount :: Word16, -- ^ Number of class attributes + classAttributes :: [AttributeInfo] -- ^ Class attributes + } + deriving (Eq, Show) + +instance Binary ClassFile where + put (ClassFile {..}) = do + put magic + put minorVersion + put majorVersion + put constsPoolSize + forM_ constsPool put + put accessFlags + put thisClass + put superClass + put interfacesCount + forM_ interfaces put + put classFieldsCount + forM_ classFields put + put classMethodsCount + forM_ classMethods put + put classAttributesCount + forM_ classAttributes put + + get = do + magic <- get + minor <- get + major <- get + poolsize <- get + pool <- replicateM (fromIntegral poolsize - 1) get + af <- get + this <- get + super <- get + interfacesCount <- get + ifaces <- replicateM (fromIntegral interfacesCount) get + classFieldsCount <- get + classFields <- replicateM (fromIntegral classFieldsCount) get + classMethodsCount <- get + classMethods <- replicateM (fromIntegral classMethodsCount) get + asCount <- get + as <- replicateM (fromIntegral $ asCount) get + return $ ClassFile magic minor major poolsize pool af this super + interfacesCount ifaces classFieldsCount classFields classMethodsCount classMethods asCount as + +-- | Field signature format +data FieldType = + SignedByte -- ^ B + | CharByte -- ^ C + | DoubleType -- ^ D + | FloatType -- ^ F + | IntType -- ^ I + | LongInt -- ^ J + | ShortInt -- ^ S + | BoolType -- ^ Z + | ObjectType String -- ^ L @{class name}@ + | Array (Maybe Int) FieldType -- ^ @[{type}@ + deriving (Eq) + +instance Show FieldType where + show SignedByte = "byte" + show CharByte = "char" + show DoubleType = "double" + show FloatType = "float" + show IntType = "int" + show LongInt = "long" + show ShortInt = "short" + show BoolType = "bool" + show (ObjectType s) = "Object " ++ s + show (Array Nothing t) = show t ++ "[]" + show (Array (Just n) t) = show t ++ "[" ++ show n ++ "]" + +-- | Class field signature +type FieldSignature = FieldType + +-- | Try to read integer value from decimal representation +getInt :: Get (Maybe Int) +getInt = do + s <- getDigits + if null s + then return Nothing + else return $ Just (read s) + where + getDigits :: Get [Char] + getDigits = do + c <- lookAhead getChar8 + if isDigit c + then do + skip 1 + next <- getDigits + 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' + put DoubleType = put 'D' + put FloatType = put 'F' + put IntType = put 'I' + put LongInt = put 'J' + put ShortInt = put 'S' + put BoolType = put 'Z' + 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 + + get = do + b <- getChar8 + case b of + 'B' -> return SignedByte + 'C' -> return CharByte + 'D' -> return DoubleType + 'F' -> return FloatType + 'I' -> return IntType + 'J' -> return LongInt + 'S' -> return ShortInt + 'Z' -> return BoolType + 'L' -> do + name <- getToSemicolon + return (ObjectType name) + '[' -> do + mbSize <- getInt + sig <- get + return (Array mbSize sig) + _ -> fail $ "Unknown signature opening symbol: " ++ [b] + +-- | Read string up to `;' +getToSemicolon :: Get String +getToSemicolon = do + x <- get + if x == ';' + then return [] + else do + next <- getToSemicolon + return (x: next) + +-- | Return value signature +data ReturnSignature = + Returns FieldType + | ReturnsVoid + deriving (Eq) + +instance Show ReturnSignature where + show (Returns t) = show t + show ReturnsVoid = "Void" + +instance Binary ReturnSignature where + put (Returns sig) = put sig + put ReturnsVoid = put 'V' + + get = do + x <- lookAhead getChar8 + case x of + 'V' -> skip 1 >> return ReturnsVoid + _ -> Returns <$> get + +-- | Method argument signature +type ArgumentSignature = FieldType + +-- | Class method argument signature +data MethodSignature = + MethodSignature [ArgumentSignature] ReturnSignature + deriving (Eq) + +instance Show MethodSignature where + show (MethodSignature args ret) = "(" ++ intercalate ", " (map show args) ++ ") returns " ++ show ret + +instance Binary MethodSignature where + put (MethodSignature args ret) = do + put '(' + forM_ args put + put ')' + put ret + + get = do + x <- getChar8 + when (x /= '(') $ + fail "Cannot parse method signature: no starting `(' !" + args <- getArgs + y <- getChar8 + when (y /= ')') $ + fail "Internal error: method signature without `)' !?" + ret <- get + return (MethodSignature args ret) + +-- | Read arguments signatures (up to `)') +getArgs :: Get [ArgumentSignature] +getArgs = whileJust getArg + where + getArg :: Get (Maybe ArgumentSignature) + getArg = do + x <- lookAhead getChar8 + if x == ')' + then return Nothing + else Just <$> get + +whileJust :: (Monad m) => m (Maybe a) -> m [a] +whileJust m = do + r <- m + case r of + Just x -> do + next <- whileJust m + return (x: next) + Nothing -> return [] + +-- | Constant pool item format +data CpInfo = + CONSTANT_Class {nameIndex :: Word16} -- ^ 7 + | CONSTANT_Fieldref {classIndex :: Word16, nameAndTypeIndex :: Word16} -- ^ 9 + | CONSTANT_Methodref {classIndex :: Word16, nameAndTypeIndex :: Word16} -- ^ 10 + | CONSTANT_InterfaceMethodref {classIndex :: Word16, nameAndTypeIndex :: Word16}-- ^ 11 + | CONSTANT_String {stringIndex :: Word16} -- ^ 8 + | CONSTANT_Integer {fourBytes :: Word32} -- ^ 3 + | CONSTANT_Float Float -- ^ 4 + | CONSTANT_Long Word64 -- ^ 5 + | CONSTANT_Double Double -- ^ 6 + | CONSTANT_NameAndType {nameIndex :: Word16, signatureIndex :: Word16} -- ^ 12 + | CONSTANT_Utf8 {stringLength :: Word16, stringBytes :: B.ByteString} -- ^ 1 + | CONSTANT_Unicode {stringLength :: Word16, stringBytes :: B.ByteString} -- ^ 2 + deriving (Eq, Show) + +instance Binary CpInfo where + put (CONSTANT_Class i) = putWord8 7 >> put i + put (CONSTANT_Fieldref i j) = putWord8 9 >> put i >> put j + put (CONSTANT_Methodref i j) = putWord8 10 >> put i >> put j + put (CONSTANT_InterfaceMethodref i j) = putWord8 11 >> put i >> put j + put (CONSTANT_String i) = putWord8 8 >> put i + put (CONSTANT_Integer x) = putWord8 3 >> put x + put (CONSTANT_Float x) = putWord8 4 >> putFloat32be x + put (CONSTANT_Long x) = putWord8 5 >> put x + put (CONSTANT_Double x) = putWord8 6 >> putFloat64be x + put (CONSTANT_NameAndType i j) = putWord8 12 >> put i >> put j + put (CONSTANT_Utf8 l bs) = putWord8 1 >> put l >> putLazyByteString bs + put (CONSTANT_Unicode l bs) = putWord8 2 >> put l >> putLazyByteString bs + + get = do + !offset <- bytesRead + tag <- getWord8 + case tag of + 1 -> do + l <- get + bs <- getLazyByteString (fromIntegral l) + return $ CONSTANT_Utf8 l bs + 2 -> do + l <- get + bs <- getLazyByteString (fromIntegral l) + return $ CONSTANT_Unicode l bs + 3 -> CONSTANT_Integer <$> get + 4 -> CONSTANT_Float <$> getFloat32be + 5 -> CONSTANT_Long <$> get + 6 -> CONSTANT_Double <$> getFloat64be + 7 -> CONSTANT_Class <$> get + 8 -> CONSTANT_String <$> get + 9 -> CONSTANT_Fieldref <$> get <*> get + 10 -> CONSTANT_Methodref <$> get <*> get + 11 -> CONSTANT_InterfaceMethodref <$> get <*> get + 12 -> CONSTANT_NameAndType <$> get <*> get + _ -> fail $ "Unknown constants pool entry tag: " ++ show tag + +-- | Class field format +data FieldInfo = FieldInfo { + fieldAccessFlags :: Word16, + fieldNameIndex :: Word16, + fieldSignatureIndex :: Word16, + fieldAttributesCount :: Word16, + fieldAttributes :: [AttributeInfo] } + deriving (Eq, Show) + +instance Binary FieldInfo where + put (FieldInfo {..}) = do + put fieldAccessFlags + put fieldNameIndex + put fieldSignatureIndex + put fieldAttributesCount + forM_ fieldAttributes put + + get = do + af <- get + ni <- get + si <- get + n <- get + as <- replicateM (fromIntegral n) get + return $ FieldInfo af ni si n as + +-- | Class method format +data MethodInfo = MethodInfo { + methodAccessFlags :: Word16, + methodNameIndex :: Word16, + methodSignatureIndex :: Word16, + methodAttributesCount :: Word16, + methodAttributes :: [AttributeInfo] } + deriving (Eq, Show) + +instance Binary MethodInfo where + put (MethodInfo {..}) = do + put methodAccessFlags + put methodNameIndex + put methodSignatureIndex + put methodAttributesCount + forM_ methodAttributes put + + get = do + offset <- bytesRead + af <- get + ni <- get + si <- get + n <- get + as <- replicateM (fromIntegral n) get + return $ MethodInfo af ni si n as + +-- | Any (class/ field/ method/ ...) attribute format. +-- Some formats specify special formats for @attributeValue@. +data AttributeInfo = AttributeInfo { + attributeName :: Word16, + attributeLength :: Word32, + attributeValue :: B.ByteString } + deriving (Eq, Show) + +instance Binary AttributeInfo where + put (AttributeInfo {..}) = do + put attributeName + putWord32be attributeLength + putLazyByteString attributeValue + + get = do + offset <- bytesRead + name <- get + len <- getWord32be + value <- getLazyByteString (fromIntegral len) + return $ AttributeInfo name len value + diff --git a/JVM/Converter.hs b/JVM/Converter.hs new file mode 100644 --- /dev/null +++ b/JVM/Converter.hs @@ -0,0 +1,237 @@ +{-# LANGUAGE TypeFamilies, StandaloneDeriving, FlexibleInstances, FlexibleContexts, UndecidableInstances, RecordWildCards, OverloadedStrings #-} +-- | Functions to convert from low-level .class format representation and +-- high-level Java classes, methods etc representation +module JVM.Converter + (parseClass, parseClassFile, + convertClass, classFile, + encodeClass, + methodByName, + attrByName, + methodCode + ) + where + +import Control.Monad.Exception +import Data.List +import Data.Word +import Data.Bits +import Data.Binary +import qualified Data.ByteString.Lazy as B +import Data.Array +import qualified Data.Set as S +import qualified Data.Map as M + +import JVM.ClassFile +import JVM.Types +import JVM.Exceptions + +-- | Parse .class file data +parseClass :: B.ByteString -> Class +parseClass bstr = convertClass $ decode bstr + +-- | Parse class data from file +parseClassFile :: FilePath -> IO Class +parseClassFile path = convertClass `fmap` decodeFile path + +encodeClass :: Class -> B.ByteString +encodeClass cls = encode $ classFile cls + +convertClass :: ClassFile -> Class +convertClass (ClassFile {..}) = + let pool = constantPoolArray constsPool + superName = className $ pool ! superClass + in Class { + constantPool = pool, + classAccess = convertAccess accessFlags, + this = className $ pool ! thisClass, + super = if superClass == 0 then Nothing else Just superName, + implements = map (\i -> className $ pool ! i) interfaces, + fields = map (convertField pool) classFields, + methods = map (convertMethod pool) classMethods, + classAttrs = convertAttrs pool classAttributes } + +classFile :: Class -> ClassFile +classFile (Class {..}) = ClassFile { + magic = 0xCAFEBABE, + minorVersion = 0, + majorVersion = 50, + constsPoolSize = fromIntegral (length poolInfo + 1), + constsPool = poolInfo, + accessFlags = access2word16 classAccess, + 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 (force "ifaces" . poolIndex poolInfo) implements, + classFieldsCount = fromIntegral (length fields), + classFields = map (fieldInfo poolInfo) fields, + classMethodsCount = fromIntegral (length methods), + classMethods = map (methodInfo poolInfo) methods, + classAttributesCount = fromIntegral (M.size classAttrs), + classAttributes = map (attrInfo poolInfo) (M.assocs classAttrs) } + where + poolInfo = toCPInfo constantPool + +toCPInfo :: Pool -> [CpInfo] +toCPInfo pool = result + where + result = map cpInfo $ elems pool + + cpInfo (CClass name) = CONSTANT_Class (force "class" $ poolIndex result name) + cpInfo (CField cls name) = + CONSTANT_Fieldref (force "field a" $ poolClassIndex result cls) (force "field b" $ poolNTIndex result name) + cpInfo (CMethod cls name) = + CONSTANT_Methodref (force "method a" $ poolClassIndex result cls) (force ("method b: " ++ show name) $ poolNTIndex result name) + cpInfo (CIfaceMethod cls name) = + 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 (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 + +-- | 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 -> throw (NoItemInPool name) + Just i -> return $ fromIntegral $ i+1 + where + 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 = 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 = 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 = force "attr name" $ poolIndex pool name, + attributeLength = fromIntegral (B.length value), + attributeValue = value } + +constantPoolArray :: [CpInfo] -> Pool +constantPoolArray list = pool + where + pool :: Pool + pool = listArray (1,n) $ map convert list + n = fromIntegral $ length list + + convertNameType :: (HasSignature a, Binary (Signature a)) => Word16 -> NameType a + convertNameType i = + let (CNameType n s) = pool ! i + in NameType n (decode s) + + convert (CONSTANT_Class i) = CClass $ getString $ pool ! i + convert (CONSTANT_Fieldref i j) = CField (className $ pool ! i) (convertNameType j) + convert (CONSTANT_Methodref i j) = CMethod (className $ pool ! i) (convertNameType j) + convert (CONSTANT_InterfaceMethodref i j) = CIfaceMethod (className $ pool ! i) (convertNameType j) + convert (CONSTANT_String i) = CString $ getString $ pool ! i + convert (CONSTANT_Integer x) = CInteger x + convert (CONSTANT_Float x) = CFloat x + convert (CONSTANT_Long x) = CLong (fromIntegral x) + convert (CONSTANT_Double x) = CDouble x + convert (CONSTANT_NameAndType i j) = CNameType (getString $ pool ! i) (getString $ pool ! j) + convert (CONSTANT_Utf8 _ bs) = CUTF8 bs + convert (CONSTANT_Unicode _ bs) = CUnicode bs + +convertAccess :: Word16 -> Access +convertAccess w = S.fromList $ concat $ zipWith (\i f -> if testBit w i then [f] else []) [0..] $ [ + ACC_PUBLIC, + ACC_PRIVATE, + ACC_PROTECTED, + ACC_STATIC, + ACC_FINAL, + ACC_SYNCHRONIZED, + ACC_VOLATILE, + ACC_TRANSIENT, + ACC_NATIVE, + ACC_INTERFACE, + ACC_ABSTRACT ] + +access2word16 :: Access -> Word16 +access2word16 fs = bitsOr $ map toBit $ S.toList fs + where + bitsOr = foldl (.|.) 0 + toBit f = 1 `shiftL` (fromIntegral $ fromEnum f) + +convertField :: Pool -> FieldInfo -> Field +convertField pool (FieldInfo {..}) = Field { + fieldAccess = convertAccess fieldAccessFlags, + fieldName = getString $ pool ! fieldNameIndex, + fieldSignature = decode $ getString $ pool ! fieldSignatureIndex, + fieldAttrs = convertAttrs pool fieldAttributes } + +convertMethod :: Pool -> MethodInfo -> Method +convertMethod pool (MethodInfo {..}) = Method { + methodAccess = convertAccess methodAccessFlags, + methodName = getString $ pool ! methodNameIndex, + methodSignature = decode $ getString $ pool ! methodSignatureIndex, + methodAttrs = convertAttrs pool methodAttributes } + +convertAttrs :: Pool -> [AttributeInfo] -> Attributes +convertAttrs pool attrs = M.fromList $ map go attrs + where + go (AttributeInfo {..}) = (getString $ pool ! attributeName, + attributeValue) + +-- | Try to get class method by name +methodByName :: Class -> B.ByteString -> Maybe Method +methodByName cls name = + find (\m -> methodName m == name) (methods cls) + +-- | Try to get object attribute by name +attrByName :: (HasAttributes a) => a -> B.ByteString -> Maybe B.ByteString +attrByName x name = M.lookup name (attributes x) + +-- | Try to get Code for class method (no Code for interface methods) +methodCode :: Class + -> B.ByteString -- ^ Method name + -> Maybe B.ByteString +methodCode cls name = do + method <- methodByName cls name + attrByName method "Code" + diff --git a/JVM/Types.hs b/JVM/Types.hs new file mode 100644 --- /dev/null +++ b/JVM/Types.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE TypeFamilies, StandaloneDeriving, FlexibleInstances, FlexibleContexts, UndecidableInstances #-} +-- | This module declares `high-level' data types for Java classes, methods etc. +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.Char +import Data.String +import qualified Data.Set as S +import qualified Data.Map as M + +import JVM.ClassFile + +instance IsString B.ByteString where + fromString s = B.pack $ map (fromIntegral . ord) $ encodeString s + +toString :: B.ByteString -> String +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 + +-- | Java class +data Class = Class { + constantPool :: Pool, + classAccess :: Access, + this :: B.ByteString, -- ^ this class name + super :: Maybe B.ByteString, -- ^ super class name + implements :: [B.ByteString], -- ^ implemented interfaces + fields :: [Field], + methods :: [Method], + classAttrs :: Attributes + } + deriving (Eq, Show) + +instance HasAttributes Class where + attributes = classAttrs + +class HasSignature a where + type Signature a + +-- | Name and signature pair. Used for methods and fields. +data NameType a = NameType { + ntName :: B.ByteString, + ntSignature :: Signature a } + +instance Show (Signature a) => Show (NameType a) where + show (NameType n t) = toString n ++ ": " ++ show t + +deriving instance Eq (Signature a) => Eq (NameType a) + +-- | Constant pool item +data Constant = + CClass B.ByteString + | CField {refClass :: B.ByteString, fieldNameType :: NameType Field} + | CMethod {refClass :: B.ByteString, nameType :: NameType Method} + | CIfaceMethod {refClass :: B.ByteString, nameType :: NameType Method} + | CString B.ByteString + | CInteger Word32 + | CFloat Float + | CLong Integer + | CDouble Double + | CNameType B.ByteString B.ByteString + | CUTF8 {getString :: B.ByteString} + | 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 + show (CMethod cls nt) = "method " ++ toString cls ++ "." ++ show nt + show (CIfaceMethod cls nt) = "interface method " ++ toString cls ++ "." ++ show nt + show (CString s) = "String \"" ++ toString s ++ "\"" + show (CInteger x) = show x + show (CFloat x) = show x + show (CLong x) = show x + show (CDouble x) = show x + show (CNameType name tp) = toString name ++ ": " ++ toString tp + show (CUTF8 s) = "UTF8 \"" ++ toString s ++ "\"" + show (CUnicode s) = "Unicode \"" ++ toString s ++ "\"" + +-- | Class field +data Field = Field { + fieldAccess :: Access, + fieldName :: B.ByteString, + fieldSignature :: FieldSignature, + fieldAttrs :: Attributes } + deriving (Eq, Show) + +instance HasSignature Field where + type Signature Field = FieldSignature + +instance HasAttributes Field where + attributes = fieldAttrs + +-- | Class method +data Method = Method { + methodAccess :: Access, + methodName :: B.ByteString, + methodSignature :: MethodSignature, + methodAttrs :: Attributes } + deriving (Eq, Show) + +instance HasSignature Method where + type Signature Method = MethodSignature + +instance HasAttributes Method where + attributes = methodAttrs + +-- | Set of access flags +type Access = S.Set AccessFlag + +-- | Access flags. Used for classess, methods, variables. +data AccessFlag = + ACC_PUBLIC -- ^ 0x0001 Visible for all + | ACC_PRIVATE -- ^ 0x0002 Visible only for defined class + | ACC_PROTECTED -- ^ 0x0004 Visible only for subclasses + | ACC_STATIC -- ^ 0x0008 Static method or variable + | ACC_FINAL -- ^ 0x0010 No further subclassing or assignments + | ACC_SYNCHRONIZED -- ^ 0x0020 Uses monitors + | ACC_VOLATILE -- ^ 0x0040 Could not be cached + | ACC_TRANSIENT -- ^ 0x0080 + | ACC_NATIVE -- ^ 0x0100 Implemented in other language + | ACC_INTERFACE -- ^ 0x0200 Class is interface + | ACC_ABSTRACT -- ^ 0x0400 + deriving (Eq, Show, Ord, Enum) + +-- | Generic attribute +data Attribute = Attribute { + attrName :: B.ByteString, + attrValue :: B.ByteString } + deriving (Eq, Show) + +-- | 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/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,165 @@ + GNU LESSER GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + + This version of the GNU Lesser General Public License incorporates +the terms and conditions of version 3 of the GNU General Public +License, supplemented by the additional permissions listed below. + + 0. Additional Definitions. + + As used herein, "this License" refers to version 3 of the GNU Lesser +General Public License, and the "GNU GPL" refers to version 3 of the GNU +General Public License. + + "The Library" refers to a covered work governed by this License, +other than an Application or a Combined Work as defined below. + + An "Application" is any work that makes use of an interface provided +by the Library, but which is not otherwise based on the Library. +Defining a subclass of a class defined by the Library is deemed a mode +of using an interface provided by the Library. + + A "Combined Work" is a work produced by combining or linking an +Application with the Library. The particular version of the Library +with which the Combined Work was made is also called the "Linked +Version". + + The "Minimal Corresponding Source" for a Combined Work means the +Corresponding Source for the Combined Work, excluding any source code +for portions of the Combined Work that, considered in isolation, are +based on the Application, and not on the Linked Version. + + The "Corresponding Application Code" for a Combined Work means the +object code and/or source code for the Application, including any data +and utility programs needed for reproducing the Combined Work from the +Application, but excluding the System Libraries of the Combined Work. + + 1. Exception to Section 3 of the GNU GPL. + + You may convey a covered work under sections 3 and 4 of this License +without being bound by section 3 of the GNU GPL. + + 2. Conveying Modified Versions. + + If you modify a copy of the Library, and, in your modifications, a +facility refers to a function or data to be supplied by an Application +that uses the facility (other than as an argument passed when the +facility is invoked), then you may convey a copy of the modified +version: + + a) under this License, provided that you make a good faith effort to + ensure that, in the event an Application does not supply the + function or data, the facility still operates, and performs + whatever part of its purpose remains meaningful, or + + b) under the GNU GPL, with none of the additional permissions of + this License applicable to that copy. + + 3. Object Code Incorporating Material from Library Header Files. + + The object code form of an Application may incorporate material from +a header file that is part of the Library. You may convey such object +code under terms of your choice, provided that, if the incorporated +material is not limited to numerical parameters, data structure +layouts and accessors, or small macros, inline functions and templates +(ten or fewer lines in length), you do both of the following: + + a) Give prominent notice with each copy of the object code that the + Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the object code with a copy of the GNU GPL and this license + document. + + 4. Combined Works. + + You may convey a Combined Work under terms of your choice that, +taken together, effectively do not restrict modification of the +portions of the Library contained in the Combined Work and reverse +engineering for debugging such modifications, if you also do each of +the following: + + a) Give prominent notice with each copy of the Combined Work that + the Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the Combined Work with a copy of the GNU GPL and this license + document. + + c) For a Combined Work that displays copyright notices during + execution, include the copyright notice for the Library among + these notices, as well as a reference directing the user to the + copies of the GNU GPL and this license document. + + d) Do one of the following: + + 0) Convey the Minimal Corresponding Source under the terms of this + License, and the Corresponding Application Code in a form + suitable for, and under terms that permit, the user to + recombine or relink the Application with a modified version of + the Linked Version to produce a modified Combined Work, in the + manner specified by section 6 of the GNU GPL for conveying + Corresponding Source. + + 1) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (a) uses at run time + a copy of the Library already present on the user's computer + system, and (b) will operate properly with a modified version + of the Library that is interface-compatible with the Linked + Version. + + e) Provide Installation Information, but only if you would otherwise + be required to provide such information under section 6 of the + GNU GPL, and only to the extent that such information is + necessary to install and execute a modified version of the + Combined Work produced by recombining or relinking the + Application with a modified version of the Linked Version. (If + you use option 4d0, the Installation Information must accompany + the Minimal Corresponding Source and Corresponding Application + Code. If you use option 4d1, you must provide the Installation + Information in the manner specified by section 6 of the GNU GPL + for conveying Corresponding Source.) + + 5. Combined Libraries. + + You may place library facilities that are a work based on the +Library side by side in a single library together with other library +facilities that are not Applications and are not covered by this +License, and convey such a combined library under terms of your +choice, if you do both of the following: + + a) Accompany the combined library with a copy of the same work based + on the Library, uncombined with any other library facilities, + conveyed under the terms of this License. + + b) Give prominent notice with the combined library that part of it + is a work based on the Library, and explaining where to find the + accompanying uncombined form of the same work. + + 6. Revised Versions of the GNU Lesser General Public License. + + The Free Software Foundation may publish revised and/or new versions +of the GNU Lesser General Public License from time to time. Such new +versions will be similar in spirit to the present version, but may +differ in detail to address new problems or concerns. + + Each version is given a distinguishing version number. If the +Library as you received it specifies that a certain numbered version +of the GNU Lesser General Public License "or any later version" +applies to it, you have the option of following the terms and +conditions either of that published version or of any later version +published by the Free Software Foundation. If the Library as you +received it does not specify a version number of the GNU Lesser +General Public License, you may choose any version of the GNU Lesser +General Public License ever published by the Free Software Foundation. + + If the Library as you received it specifies that a proxy can decide +whether future versions of the GNU Lesser General Public License shall +apply, that proxy's public statement of acceptance of any version is +permanent authorization for you to choose that version for the +Library. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/dump-class.hs b/dump-class.hs new file mode 100644 --- /dev/null +++ b/dump-class.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Control.Monad +import Data.Array +import System.Environment +import qualified Data.ByteString.Lazy as B +import Text.Printf + +import JVM.Types +import JVM.Converter +import JVM.Assembler + +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 + + _ -> error "Synopsis: dump-class File.class" + diff --git a/hs-java.cabal b/hs-java.cabal new file mode 100644 --- /dev/null +++ b/hs-java.cabal @@ -0,0 +1,29 @@ +Name: hs-java +Version: 0.1 +Cabal-Version: >= 1.6 +License: BSD3 +License-File: LICENSE +Author: Ilya V. Portnov +Maintainer: portnov84@rambler.ru +Synopsis: Java .class files assembler/disassembler +Category: Jvm +Build-Type: Simple +Description: This package declares data types for Java .class files format and functions + to assemble/disassemble Java bytecode. + +Extra-source-files: dump-class.hs + +library + Exposed-Modules: JVM.Types + JVM.ClassFile + JVM.Assembler + JVM.Converter + + Build-Depends: base >= 3 && <= 5, haskell98, containers, binary, + mtl, directory, filepath, utf8-string, array, + bytestring, data-binary-ieee754, binary-state, + control-monad-exception + + ghc-options: -fwarn-unused-imports + +