Ilya Rezvov
960 lines
36 KiB
Haskell
960 lines
36 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE DuplicateRecordFields #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
|
|
module Language.Wasm.Binary (
|
|
dumpModule,
|
|
dumpModuleLazy,
|
|
decodeModule,
|
|
decodeModuleLazy
|
|
) where
|
|
|
|
import Language.Wasm.Structure
|
|
|
|
import Numeric.Natural (Natural)
|
|
import Data.Bits
|
|
import Data.Word (Word8, Word32, Word64)
|
|
import Data.Int (Int8, Int32, Int64)
|
|
import Data.Serialize
|
|
import qualified Data.ByteString as BS
|
|
import qualified Data.ByteString.Lazy as LBS
|
|
import qualified Data.Text.Lazy as TL
|
|
import qualified Data.Text.Lazy.Encoding as TLEncoding
|
|
|
|
asInt32 :: Word32 -> Int32
|
|
asInt32 w =
|
|
if w < 0x80000000
|
|
then fromIntegral w
|
|
else -1 * fromIntegral (0xFFFFFFFF - w + 1)
|
|
|
|
asInt64 :: Word64 -> Int64
|
|
asInt64 w =
|
|
if w < 0x8000000000000000
|
|
then fromIntegral w
|
|
else -1 * fromIntegral (0xFFFFFFFFFFFFFFFF - w + 1)
|
|
|
|
getULEB128 :: (Integral a, Bits a) => Int -> Get a
|
|
getULEB128 bitsBudget = do
|
|
if bitsBudget > 0 then return () else fail "integer representation too long"
|
|
val <- getWord8
|
|
if bitsBudget >= 7 || val .&. 0x7F < 1 `shiftL` bitsBudget then return () else fail "integer too large"
|
|
if not (testBit val 7)
|
|
then return $ fromIntegral val
|
|
else do
|
|
rest <- getULEB128 (bitsBudget - 7)
|
|
return $ (fromIntegral $ val .&. 0x7F) .|. (rest `shiftL` 7)
|
|
|
|
putULEB128 :: (Integral a, Bits a) => a -> Put
|
|
putULEB128 val =
|
|
if val < 128
|
|
then putWord8 $ fromIntegral val
|
|
else do
|
|
putWord8 $ 0x80 + (0x7F .&. fromIntegral val)
|
|
putULEB128 $ val `shiftR` 7
|
|
|
|
getSLEB128 :: (Integral a, Bits a) => Int -> Get a
|
|
getSLEB128 bitsBudget = do
|
|
if bitsBudget > 0 then return () else fail "integer representation too long"
|
|
let toInt8 :: Word8 -> Int8
|
|
toInt8 = fromIntegral
|
|
a <- getWord8
|
|
let mask = (0xFF `shiftL` (bitsBudget - 1)) .&. 0x7F
|
|
if bitsBudget >= 7 || a .&. mask == 0 || a .&. mask == mask then return () else fail "integer too large"
|
|
if not (testBit a 7)
|
|
then return . fromIntegral . toInt8 $ (a .&. 0x7f) .|. ((a .&. 0x40) `shiftL` 1)
|
|
else do
|
|
b <- getSLEB128 (bitsBudget - 7)
|
|
return $ (b `shiftL` 7) .|. (fromIntegral (a .&. 0x7f))
|
|
|
|
putSLEB128 :: (Integral a, Bits a) => a -> Put
|
|
putSLEB128 a = go a
|
|
where
|
|
ext = if a >= 0 then 0 else complement 0
|
|
go x = do
|
|
let
|
|
r = x `shiftR` 7
|
|
w = x .&. 0x7f
|
|
if r /= ext
|
|
then do
|
|
putWord8 (fromIntegral w .|. 0x80)
|
|
go r
|
|
else
|
|
if (testBit w 6 && a < 0) || (not (testBit w 6) && a >= 0)
|
|
then putWord8 (fromIntegral w)
|
|
else do
|
|
putWord8 (fromIntegral w .|. 0x80)
|
|
putWord8 (fromIntegral ext .&. 0x7F)
|
|
|
|
putVec :: Serialize a => [a] -> Put
|
|
putVec list = do
|
|
putULEB128 $ length list
|
|
mapM put list
|
|
return ()
|
|
|
|
getVec :: Serialize a => Get [a]
|
|
getVec = do
|
|
len <- getULEB128 32
|
|
sequence $ replicate len get
|
|
|
|
byteGuard :: Word8 -> Get ()
|
|
byteGuard expected = do
|
|
byte <- getWord8
|
|
if byte == expected
|
|
then return ()
|
|
else fail $ "Expected " ++ show expected ++ ", but encountered " ++ show byte
|
|
|
|
putSection :: SectionType -> Put -> Put
|
|
putSection section content = do
|
|
put section
|
|
let payload = runPut content
|
|
putULEB128 $ BS.length payload
|
|
putByteString payload
|
|
|
|
skipCustomSection :: Get ()
|
|
skipCustomSection = do
|
|
byteGuard 0x00
|
|
size <- getULEB128 32
|
|
content <- getByteString size
|
|
case runGet getName content of
|
|
Right _name -> return ()
|
|
Left _ -> fail "invalid UTF-8 encoding"
|
|
|
|
getSection :: SectionType -> Get a -> a -> Get a
|
|
getSection sectionType parser def = do
|
|
empty <- isEmpty
|
|
if empty
|
|
then return def
|
|
else do
|
|
nextByte <- lookAhead getWord8
|
|
parseSection $ fromIntegral nextByte
|
|
where
|
|
parseSection op
|
|
| op == 0 = skipCustomSection >> getSection sectionType parser def
|
|
| op == fromEnum sectionType = do
|
|
getWord8
|
|
len <- getULEB128 32
|
|
isolate len parser
|
|
| op > fromEnum DataSection = fail "invalid section id"
|
|
| op > fromEnum sectionType = return def
|
|
| otherwise =
|
|
fail $ "Incorrect order of sections. Expected " ++ show sectionType
|
|
++ ", but found " ++ show (toEnum op :: SectionType)
|
|
|
|
putName :: TL.Text -> Put
|
|
putName txt = do
|
|
let bs = TLEncoding.encodeUtf8 txt
|
|
putULEB128 $ LBS.length bs
|
|
putLazyByteString bs
|
|
|
|
getName :: Get TL.Text
|
|
getName = do
|
|
len <- getULEB128 32
|
|
bytes <- getLazyByteString len
|
|
case TLEncoding.decodeUtf8' bytes of
|
|
Right name -> return name
|
|
Left _ -> fail "invalid UTF-8 encoding"
|
|
|
|
putResultType :: ResultType -> Put
|
|
putResultType [] = putWord8 0x40
|
|
putResultType [valType] = put valType
|
|
putResultType _ = error "Current WebAssembly spec does not support returning more then one value"
|
|
|
|
getResultType :: Get ResultType
|
|
getResultType = do
|
|
op <- getWord8
|
|
case op of
|
|
0x40 -> return []
|
|
0x7F -> return [I32]
|
|
0x7E -> return [I64]
|
|
0x7D -> return [F32]
|
|
0x7C -> return [F64]
|
|
_ -> fail "unexpected byte in result type position"
|
|
|
|
putBlockType :: BlockType -> Put
|
|
putBlockType (Inline Nothing) = putWord8 0x40
|
|
putBlockType (Inline (Just valType)) = put valType
|
|
putBlockType (TypeIndex idx) = putSLEB128 idx
|
|
|
|
getInlineBlockType :: Get (Maybe (Maybe ValueType))
|
|
getInlineBlockType = do
|
|
op <- getWord8
|
|
case op of
|
|
0x40 -> return $ Just Nothing
|
|
0x7F -> return $ Just (Just I32)
|
|
0x7E -> return $ Just (Just I64)
|
|
0x7D -> return $ Just (Just F32)
|
|
0x7C -> return $ Just (Just F64)
|
|
_ -> return Nothing
|
|
|
|
getBlockType :: Get BlockType
|
|
getBlockType = do
|
|
inlineType <- lookAheadM getInlineBlockType
|
|
case inlineType of
|
|
Just inline -> return $ Inline inline
|
|
Nothing -> TypeIndex <$> getSLEB128 33
|
|
|
|
data SectionType =
|
|
CustomSection
|
|
| TypeSection
|
|
| ImportSection
|
|
| FunctionSection
|
|
| TableSection
|
|
| MemorySection
|
|
| GlobalSection
|
|
| ExportSection
|
|
| StartSection
|
|
| ElementSection
|
|
| CodeSection
|
|
| DataSection
|
|
deriving (Eq, Show, Enum)
|
|
|
|
instance Serialize SectionType where
|
|
put section = putWord8 $ fromIntegral $ fromEnum section
|
|
get = do
|
|
op <- fromIntegral `fmap` getWord8
|
|
if op <= fromEnum DataSection
|
|
then return $ toEnum op
|
|
else fail "Unexpected byte in section type position"
|
|
|
|
instance Serialize ValueType where
|
|
put I32 = putWord8 0x7F
|
|
put I64 = putWord8 0x7E
|
|
put F32 = putWord8 0x7D
|
|
put F64 = putWord8 0x7C
|
|
|
|
get = do
|
|
op <- getWord8
|
|
case op of
|
|
0x7F -> return I32
|
|
0x7E -> return I64
|
|
0x7D -> return F32
|
|
0x7C -> return F64
|
|
_ -> fail "unexpected byte in value type position"
|
|
|
|
instance Serialize FuncType where
|
|
put FuncType {params, results} = do
|
|
putWord8 0x60
|
|
putVec params
|
|
putVec results
|
|
get = do
|
|
byteGuard 0x60
|
|
params <- getVec
|
|
results <- getVec
|
|
return $ FuncType { params, results }
|
|
|
|
instance Serialize ElemType where
|
|
put FuncRef = putWord8 0x70
|
|
put ExternRef = putWord8 0x6F
|
|
get = do
|
|
op <- getWord8
|
|
case op of
|
|
0x70 -> return FuncRef
|
|
0x69 -> return ExternRef
|
|
_ -> fail "unknown reference type"
|
|
|
|
instance Serialize Limit where
|
|
put (Limit min Nothing) = putWord8 0x00 >> putULEB128 min
|
|
put (Limit min (Just max)) = putWord8 0x01 >> putULEB128 min >> putULEB128 max
|
|
get = do
|
|
op <- getWord8
|
|
case op of
|
|
0x00 -> do
|
|
min <- getULEB128 32
|
|
return $ Limit min Nothing
|
|
0x01 -> do
|
|
min <- getULEB128 32
|
|
max <- getULEB128 32
|
|
return $ Limit min (Just max)
|
|
_ -> fail "Unexpected byte in place of Limit opcode"
|
|
|
|
instance Serialize TableType where
|
|
put (TableType limit elemType) = do
|
|
put elemType
|
|
put limit
|
|
get = do
|
|
elemType <- get
|
|
limit <- get
|
|
return $ TableType limit elemType
|
|
|
|
instance Serialize GlobalType where
|
|
put (Const valType) = put valType >> putWord8 0x00
|
|
put (Mut valType) = put valType >> putWord8 0x01
|
|
get = do
|
|
valType <- get
|
|
op <- getWord8
|
|
case op of
|
|
0x00 -> return $ Const valType
|
|
0x01 -> return $ Mut valType
|
|
_ -> fail "invalid mutability"
|
|
|
|
instance Serialize ImportDesc where
|
|
put (ImportFunc typeIdx) = putWord8 0x00 >> putULEB128 typeIdx
|
|
put (ImportTable tableType) = putWord8 0x01 >> put tableType
|
|
put (ImportMemory memType) = putWord8 0x02 >> put memType
|
|
put (ImportGlobal globalType) = putWord8 0x03 >> put globalType
|
|
get = do
|
|
op <- getWord8
|
|
case op of
|
|
0x00 -> ImportFunc <$> getULEB128 32
|
|
0x01 -> ImportTable <$> get
|
|
0x02 -> ImportMemory <$> get
|
|
0x03 -> ImportGlobal <$> get
|
|
_ -> fail "Unexpected byte in place of Import Declaration opcode"
|
|
|
|
instance Serialize Import where
|
|
put (Import sourceModule name desc) = do
|
|
putName sourceModule
|
|
putName name
|
|
put desc
|
|
get = do
|
|
sourceModule <- getName
|
|
name <- getName
|
|
desc <- get
|
|
return $ Import sourceModule name desc
|
|
|
|
instance Serialize Table where
|
|
put (Table tableType) = put tableType
|
|
get = Table <$> get
|
|
|
|
instance Serialize Memory where
|
|
put (Memory limit) = put limit
|
|
get = Memory <$> get
|
|
|
|
newtype Index = Index { unIndex :: Natural } deriving (Show, Eq)
|
|
|
|
instance Serialize Index where
|
|
put (Index idx) = putULEB128 idx
|
|
get = Index <$> getULEB128 32
|
|
|
|
newtype Expr = Expr { unExpr :: Expression } deriving (Show, Eq)
|
|
|
|
instance Serialize Expr where
|
|
put (Expr expr) = putExpression expr
|
|
get = Expr <$> getExpression
|
|
|
|
instance Serialize MemArg where
|
|
put MemArg { align, offset } = putULEB128 align >> putULEB128 offset
|
|
get = do
|
|
align <- getULEB128 32
|
|
offset <- getULEB128 32
|
|
return $ MemArg { align, offset }
|
|
|
|
instance Serialize (Instruction Natural) where
|
|
put Unreachable = putWord8 0x00
|
|
put Nop = putWord8 0x01
|
|
put (Block blockType body) = do
|
|
putWord8 0x02
|
|
putBlockType blockType
|
|
putExpression body
|
|
put (Loop blockType body) = do
|
|
putWord8 0x03
|
|
putBlockType blockType
|
|
putExpression body
|
|
put If {blockType, true, false = []} = do
|
|
putWord8 0x04
|
|
putBlockType blockType
|
|
putExpression true
|
|
put If {blockType, true, false} = do
|
|
putWord8 0x04
|
|
putBlockType blockType
|
|
mapM_ put true
|
|
putWord8 0x05 -- ELSE
|
|
putExpression false
|
|
put (Br labelIdx) = putWord8 0x0C >> putULEB128 labelIdx
|
|
put (BrIf labelIdx) = putWord8 0x0D >> putULEB128 labelIdx
|
|
put (BrTable labels label) = putWord8 0x0E >> putVec (map Index labels) >> putULEB128 label
|
|
put Return = putWord8 0x0F
|
|
put (Call funcIdx) = putWord8 0x10 >> putULEB128 funcIdx
|
|
put (CallIndirect tableIdx typeIdx) = putWord8 0x11 >> putULEB128 typeIdx >> putULEB128 tableIdx
|
|
-- Parametric instructions
|
|
put Drop = putWord8 0x1A
|
|
put Select = putWord8 0x1B
|
|
-- Variable instructions
|
|
put (GetLocal idx) = putWord8 0x20 >> putULEB128 idx
|
|
put (SetLocal idx) = putWord8 0x21 >> putULEB128 idx
|
|
put (TeeLocal idx) = putWord8 0x22 >> putULEB128 idx
|
|
put (GetGlobal idx) = putWord8 0x23 >> putULEB128 idx
|
|
put (SetGlobal idx) = putWord8 0x24 >> putULEB128 idx
|
|
-- Memory instructions
|
|
put (I32Load memArg) = putWord8 0x28 >> put memArg
|
|
put (I64Load memArg) = putWord8 0x29 >> put memArg
|
|
put (F32Load memArg) = putWord8 0x2A >> put memArg
|
|
put (F64Load memArg) = putWord8 0x2B >> put memArg
|
|
put (I32Load8S memArg) = putWord8 0x2C >> put memArg
|
|
put (I32Load8U memArg) = putWord8 0x2D >> put memArg
|
|
put (I32Load16S memArg) = putWord8 0x2E >> put memArg
|
|
put (I32Load16U memArg) = putWord8 0x2F >> put memArg
|
|
put (I64Load8S memArg) = putWord8 0x30 >> put memArg
|
|
put (I64Load8U memArg) = putWord8 0x31 >> put memArg
|
|
put (I64Load16S memArg) = putWord8 0x32 >> put memArg
|
|
put (I64Load16U memArg) = putWord8 0x33 >> put memArg
|
|
put (I64Load32S memArg) = putWord8 0x34 >> put memArg
|
|
put (I64Load32U memArg) = putWord8 0x35 >> put memArg
|
|
put (I32Store memArg) = putWord8 0x36 >> put memArg
|
|
put (I64Store memArg) = putWord8 0x37 >> put memArg
|
|
put (F32Store memArg) = putWord8 0x38 >> put memArg
|
|
put (F64Store memArg) = putWord8 0x39 >> put memArg
|
|
put (I32Store8 memArg) = putWord8 0x3A >> put memArg
|
|
put (I32Store16 memArg) = putWord8 0x3B >> put memArg
|
|
put (I64Store8 memArg) = putWord8 0x3C >> put memArg
|
|
put (I64Store16 memArg) = putWord8 0x3D >> put memArg
|
|
put (I64Store32 memArg) = putWord8 0x3E >> put memArg
|
|
put CurrentMemory = putWord8 0x3F >> putWord8 0x00
|
|
put GrowMemory = putWord8 0x40 >> putWord8 0x00
|
|
-- Numeric instructions
|
|
put (I32Const val) = putWord8 0x41 >> putSLEB128 (asInt32 val)
|
|
put (I64Const val) = putWord8 0x42 >> putSLEB128 (asInt64 val)
|
|
put (F32Const val) = putWord8 0x43 >> putFloat32le val
|
|
put (F64Const val) = putWord8 0x44 >> putFloat64le val
|
|
put I32Eqz = putWord8 0x45
|
|
put (IRelOp BS32 IEq) = putWord8 0x46
|
|
put (IRelOp BS32 INe) = putWord8 0x47
|
|
put (IRelOp BS32 ILtS) = putWord8 0x48
|
|
put (IRelOp BS32 ILtU) = putWord8 0x49
|
|
put (IRelOp BS32 IGtS) = putWord8 0x4A
|
|
put (IRelOp BS32 IGtU) = putWord8 0x4B
|
|
put (IRelOp BS32 ILeS) = putWord8 0x4C
|
|
put (IRelOp BS32 ILeU) = putWord8 0x4D
|
|
put (IRelOp BS32 IGeS) = putWord8 0x4E
|
|
put (IRelOp BS32 IGeU) = putWord8 0x4F
|
|
put I64Eqz = putWord8 0x50
|
|
put (IRelOp BS64 IEq) = putWord8 0x51
|
|
put (IRelOp BS64 INe) = putWord8 0x52
|
|
put (IRelOp BS64 ILtS) = putWord8 0x53
|
|
put (IRelOp BS64 ILtU) = putWord8 0x54
|
|
put (IRelOp BS64 IGtS) = putWord8 0x55
|
|
put (IRelOp BS64 IGtU) = putWord8 0x56
|
|
put (IRelOp BS64 ILeS) = putWord8 0x57
|
|
put (IRelOp BS64 ILeU) = putWord8 0x58
|
|
put (IRelOp BS64 IGeS) = putWord8 0x59
|
|
put (IRelOp BS64 IGeU) = putWord8 0x5A
|
|
put (FRelOp BS32 FEq) = putWord8 0x5B
|
|
put (FRelOp BS32 FNe) = putWord8 0x5C
|
|
put (FRelOp BS32 FLt) = putWord8 0x5D
|
|
put (FRelOp BS32 FGt) = putWord8 0x5E
|
|
put (FRelOp BS32 FLe) = putWord8 0x5F
|
|
put (FRelOp BS32 FGe) = putWord8 0x60
|
|
put (FRelOp BS64 FEq) = putWord8 0x61
|
|
put (FRelOp BS64 FNe) = putWord8 0x62
|
|
put (FRelOp BS64 FLt) = putWord8 0x63
|
|
put (FRelOp BS64 FGt) = putWord8 0x64
|
|
put (FRelOp BS64 FLe) = putWord8 0x65
|
|
put (FRelOp BS64 FGe) = putWord8 0x66
|
|
put (IUnOp BS32 IClz) = putWord8 0x67
|
|
put (IUnOp BS32 ICtz) = putWord8 0x68
|
|
put (IUnOp BS32 IPopcnt) = putWord8 0x69
|
|
put (IBinOp BS32 IAdd) = putWord8 0x6A
|
|
put (IBinOp BS32 ISub) = putWord8 0x6B
|
|
put (IBinOp BS32 IMul) = putWord8 0x6C
|
|
put (IBinOp BS32 IDivS) = putWord8 0x6D
|
|
put (IBinOp BS32 IDivU) = putWord8 0x6E
|
|
put (IBinOp BS32 IRemS) = putWord8 0x6F
|
|
put (IBinOp BS32 IRemU) = putWord8 0x70
|
|
put (IBinOp BS32 IAnd) = putWord8 0x71
|
|
put (IBinOp BS32 IOr) = putWord8 0x72
|
|
put (IBinOp BS32 IXor) = putWord8 0x73
|
|
put (IBinOp BS32 IShl) = putWord8 0x74
|
|
put (IBinOp BS32 IShrS) = putWord8 0x75
|
|
put (IBinOp BS32 IShrU) = putWord8 0x76
|
|
put (IBinOp BS32 IRotl) = putWord8 0x77
|
|
put (IBinOp BS32 IRotr) = putWord8 0x78
|
|
put (IUnOp BS64 IClz) = putWord8 0x79
|
|
put (IUnOp BS64 ICtz) = putWord8 0x7A
|
|
put (IUnOp BS64 IPopcnt) = putWord8 0x7B
|
|
put (IBinOp BS64 IAdd) = putWord8 0x7C
|
|
put (IBinOp BS64 ISub) = putWord8 0x7D
|
|
put (IBinOp BS64 IMul) = putWord8 0x7E
|
|
put (IBinOp BS64 IDivS) = putWord8 0x7F
|
|
put (IBinOp BS64 IDivU) = putWord8 0x80
|
|
put (IBinOp BS64 IRemS) = putWord8 0x81
|
|
put (IBinOp BS64 IRemU) = putWord8 0x82
|
|
put (IBinOp BS64 IAnd) = putWord8 0x83
|
|
put (IBinOp BS64 IOr) = putWord8 0x84
|
|
put (IBinOp BS64 IXor) = putWord8 0x85
|
|
put (IBinOp BS64 IShl) = putWord8 0x86
|
|
put (IBinOp BS64 IShrS) = putWord8 0x87
|
|
put (IBinOp BS64 IShrU) = putWord8 0x88
|
|
put (IBinOp BS64 IRotl) = putWord8 0x89
|
|
put (IBinOp BS64 IRotr) = putWord8 0x8A
|
|
put (FUnOp BS32 FAbs) = putWord8 0x8B
|
|
put (FUnOp BS32 FNeg) = putWord8 0x8C
|
|
put (FUnOp BS32 FCeil) = putWord8 0x8D
|
|
put (FUnOp BS32 FFloor) = putWord8 0x8E
|
|
put (FUnOp BS32 FTrunc) = putWord8 0x8F
|
|
put (FUnOp BS32 FNearest) = putWord8 0x90
|
|
put (FUnOp BS32 FSqrt) = putWord8 0x91
|
|
put (FBinOp BS32 FAdd) = putWord8 0x92
|
|
put (FBinOp BS32 FSub) = putWord8 0x93
|
|
put (FBinOp BS32 FMul) = putWord8 0x94
|
|
put (FBinOp BS32 FDiv) = putWord8 0x95
|
|
put (FBinOp BS32 FMin) = putWord8 0x96
|
|
put (FBinOp BS32 FMax) = putWord8 0x97
|
|
put (FBinOp BS32 FCopySign) = putWord8 0x98
|
|
put (FUnOp BS64 FAbs) = putWord8 0x99
|
|
put (FUnOp BS64 FNeg) = putWord8 0x9A
|
|
put (FUnOp BS64 FCeil) = putWord8 0x9B
|
|
put (FUnOp BS64 FFloor) = putWord8 0x9C
|
|
put (FUnOp BS64 FTrunc) = putWord8 0x9D
|
|
put (FUnOp BS64 FNearest) = putWord8 0x9E
|
|
put (FUnOp BS64 FSqrt) = putWord8 0x9F
|
|
put (FBinOp BS64 FAdd) = putWord8 0xA0
|
|
put (FBinOp BS64 FSub) = putWord8 0xA1
|
|
put (FBinOp BS64 FMul) = putWord8 0xA2
|
|
put (FBinOp BS64 FDiv) = putWord8 0xA3
|
|
put (FBinOp BS64 FMin) = putWord8 0xA4
|
|
put (FBinOp BS64 FMax) = putWord8 0xA5
|
|
put (FBinOp BS64 FCopySign) = putWord8 0xA6
|
|
put I32WrapI64 = putWord8 0xA7
|
|
put (ITruncFS BS32 BS32) = putWord8 0xA8
|
|
put (ITruncFU BS32 BS32) = putWord8 0xA9
|
|
put (ITruncFS BS32 BS64) = putWord8 0xAA
|
|
put (ITruncFU BS32 BS64) = putWord8 0xAB
|
|
put I64ExtendSI32 = putWord8 0xAC
|
|
put I64ExtendUI32 = putWord8 0xAD
|
|
put (ITruncFS BS64 BS32) = putWord8 0xAE
|
|
put (ITruncFU BS64 BS32) = putWord8 0xAF
|
|
put (ITruncFS BS64 BS64) = putWord8 0xB0
|
|
put (ITruncFU BS64 BS64) = putWord8 0xB1
|
|
put (FConvertIS BS32 BS32) = putWord8 0xB2
|
|
put (FConvertIU BS32 BS32) = putWord8 0xB3
|
|
put (FConvertIS BS32 BS64) = putWord8 0xB4
|
|
put (FConvertIU BS32 BS64) = putWord8 0xB5
|
|
put F32DemoteF64 = putWord8 0xB6
|
|
put (FConvertIS BS64 BS32) = putWord8 0xB7
|
|
put (FConvertIU BS64 BS32) = putWord8 0xB8
|
|
put (FConvertIS BS64 BS64) = putWord8 0xB9
|
|
put (FConvertIU BS64 BS64) = putWord8 0xBA
|
|
put F64PromoteF32 = putWord8 0xBB
|
|
put (IReinterpretF BS32) = putWord8 0xBC
|
|
put (IReinterpretF BS64) = putWord8 0xBD
|
|
put (FReinterpretI BS32) = putWord8 0xBE
|
|
put (FReinterpretI BS64) = putWord8 0xBF
|
|
|
|
put (IUnOp BS32 IExtend8S) = putWord8 0xC0
|
|
put (IUnOp BS32 IExtend16S) = putWord8 0xC1
|
|
put (IUnOp BS32 IExtend32S) = error "Opcode for i32.extend32_s doesn't exist"
|
|
put (IUnOp BS64 IExtend8S) = putWord8 0xC2
|
|
put (IUnOp BS64 IExtend16S) = putWord8 0xC3
|
|
put (IUnOp BS64 IExtend32S) = putWord8 0xC4
|
|
|
|
put (ITruncSatFS BS32 BS32) = putWord8 0xFC >> putULEB128 (0x00 :: Word32)
|
|
put (ITruncSatFU BS32 BS32) = putWord8 0xFC >> putULEB128 (0x01 :: Word32)
|
|
put (ITruncSatFS BS32 BS64) = putWord8 0xFC >> putULEB128 (0x02 :: Word32)
|
|
put (ITruncSatFU BS32 BS64) = putWord8 0xFC >> putULEB128 (0x03 :: Word32)
|
|
put (ITruncSatFS BS64 BS32) = putWord8 0xFC >> putULEB128 (0x04 :: Word32)
|
|
put (ITruncSatFU BS64 BS32) = putWord8 0xFC >> putULEB128 (0x05 :: Word32)
|
|
put (ITruncSatFS BS64 BS64) = putWord8 0xFC >> putULEB128 (0x06 :: Word32)
|
|
put (ITruncSatFU BS64 BS64) = putWord8 0xFC >> putULEB128 (0x07 :: Word32)
|
|
|
|
get = do
|
|
op <- getWord8
|
|
case op of
|
|
0x00 -> return Unreachable
|
|
0x01 -> return Nop
|
|
0x02 -> Block <$> getBlockType <*> getExpression
|
|
0x03 -> Loop <$> getBlockType <*> getExpression
|
|
0x04 -> do
|
|
blockType <- getBlockType
|
|
(true, hasElse) <- getTrueBranch
|
|
false <- if hasElse then getExpression else return []
|
|
return $ If blockType true false
|
|
0x0C -> Br <$> getULEB128 32
|
|
0x0D -> BrIf <$> getULEB128 32
|
|
0x0E -> BrTable <$> (map unIndex <$> getVec) <*> getULEB128 32
|
|
0x0F -> return $ Return
|
|
0x10 -> Call <$> getULEB128 32
|
|
0x11 -> do
|
|
typeIdx <- getULEB128 32
|
|
tableIdx <- getULEB128 32
|
|
return $ CallIndirect tableIdx typeIdx
|
|
-- Parametric instructions
|
|
0x1A -> return $ Drop
|
|
0x1B -> return $ Select
|
|
-- Variable instructions
|
|
0x20 -> GetLocal <$> getULEB128 32
|
|
0x21 -> SetLocal <$> getULEB128 32
|
|
0x22 -> TeeLocal <$> getULEB128 32
|
|
0x23 -> GetGlobal <$> getULEB128 32
|
|
0x24 -> SetGlobal <$> getULEB128 32
|
|
-- Memory instructions
|
|
0x28 -> I32Load <$> get
|
|
0x29 -> I64Load <$> get
|
|
0x2A -> F32Load <$> get
|
|
0x2B -> F64Load <$> get
|
|
0x2C -> I32Load8S <$> get
|
|
0x2D -> I32Load8U <$> get
|
|
0x2E -> I32Load16S <$> get
|
|
0x2F -> I32Load16U <$> get
|
|
0x30 -> I64Load8S <$> get
|
|
0x31 -> I64Load8U <$> get
|
|
0x32 -> I64Load16S <$> get
|
|
0x33 -> I64Load16U <$> get
|
|
0x34 -> I64Load32S <$> get
|
|
0x35 -> I64Load32U <$> get
|
|
0x36 -> I32Store <$> get
|
|
0x37 -> I64Store <$> get
|
|
0x38 -> F32Store <$> get
|
|
0x39 -> F64Store <$> get
|
|
0x3A -> I32Store8 <$> get
|
|
0x3B -> I32Store16 <$> get
|
|
0x3C -> I64Store8 <$> get
|
|
0x3D -> I64Store16 <$> get
|
|
0x3E -> I64Store32 <$> get
|
|
0x3F -> byteGuard 0x00 >> (return $ CurrentMemory)
|
|
0x40 -> byteGuard 0x00 >> (return $ GrowMemory)
|
|
-- Numeric instructions
|
|
0x41 -> I32Const <$> getSLEB128 32
|
|
0x42 -> I64Const <$> getSLEB128 64
|
|
0x43 -> F32Const <$> getFloat32le
|
|
0x44 -> F64Const <$> getFloat64le
|
|
0x45 -> return $ I32Eqz
|
|
0x46 -> return $ IRelOp BS32 IEq
|
|
0x47 -> return $ IRelOp BS32 INe
|
|
0x48 -> return $ IRelOp BS32 ILtS
|
|
0x49 -> return $ IRelOp BS32 ILtU
|
|
0x4A -> return $ IRelOp BS32 IGtS
|
|
0x4B -> return $ IRelOp BS32 IGtU
|
|
0x4C -> return $ IRelOp BS32 ILeS
|
|
0x4D -> return $ IRelOp BS32 ILeU
|
|
0x4E -> return $ IRelOp BS32 IGeS
|
|
0x4F -> return $ IRelOp BS32 IGeU
|
|
0x50 -> return $ I64Eqz
|
|
0x51 -> return $ IRelOp BS64 IEq
|
|
0x52 -> return $ IRelOp BS64 INe
|
|
0x53 -> return $ IRelOp BS64 ILtS
|
|
0x54 -> return $ IRelOp BS64 ILtU
|
|
0x55 -> return $ IRelOp BS64 IGtS
|
|
0x56 -> return $ IRelOp BS64 IGtU
|
|
0x57 -> return $ IRelOp BS64 ILeS
|
|
0x58 -> return $ IRelOp BS64 ILeU
|
|
0x59 -> return $ IRelOp BS64 IGeS
|
|
0x5A -> return $ IRelOp BS64 IGeU
|
|
0x5B -> return $ FRelOp BS32 FEq
|
|
0x5C -> return $ FRelOp BS32 FNe
|
|
0x5D -> return $ FRelOp BS32 FLt
|
|
0x5E -> return $ FRelOp BS32 FGt
|
|
0x5F -> return $ FRelOp BS32 FLe
|
|
0x60 -> return $ FRelOp BS32 FGe
|
|
0x61 -> return $ FRelOp BS64 FEq
|
|
0x62 -> return $ FRelOp BS64 FNe
|
|
0x63 -> return $ FRelOp BS64 FLt
|
|
0x64 -> return $ FRelOp BS64 FGt
|
|
0x65 -> return $ FRelOp BS64 FLe
|
|
0x66 -> return $ FRelOp BS64 FGe
|
|
0x67 -> return $ IUnOp BS32 IClz
|
|
0x68 -> return $ IUnOp BS32 ICtz
|
|
0x69 -> return $ IUnOp BS32 IPopcnt
|
|
0x6A -> return $ IBinOp BS32 IAdd
|
|
0x6B -> return $ IBinOp BS32 ISub
|
|
0x6C -> return $ IBinOp BS32 IMul
|
|
0x6D -> return $ IBinOp BS32 IDivS
|
|
0x6E -> return $ IBinOp BS32 IDivU
|
|
0x6F -> return $ IBinOp BS32 IRemS
|
|
0x70 -> return $ IBinOp BS32 IRemU
|
|
0x71 -> return $ IBinOp BS32 IAnd
|
|
0x72 -> return $ IBinOp BS32 IOr
|
|
0x73 -> return $ IBinOp BS32 IXor
|
|
0x74 -> return $ IBinOp BS32 IShl
|
|
0x75 -> return $ IBinOp BS32 IShrS
|
|
0x76 -> return $ IBinOp BS32 IShrU
|
|
0x77 -> return $ IBinOp BS32 IRotl
|
|
0x78 -> return $ IBinOp BS32 IRotr
|
|
0x79 -> return $ IUnOp BS64 IClz
|
|
0x7A -> return $ IUnOp BS64 ICtz
|
|
0x7B -> return $ IUnOp BS64 IPopcnt
|
|
0x7C -> return $ IBinOp BS64 IAdd
|
|
0x7D -> return $ IBinOp BS64 ISub
|
|
0x7E -> return $ IBinOp BS64 IMul
|
|
0x7F -> return $ IBinOp BS64 IDivS
|
|
0x80 -> return $ IBinOp BS64 IDivU
|
|
0x81 -> return $ IBinOp BS64 IRemS
|
|
0x82 -> return $ IBinOp BS64 IRemU
|
|
0x83 -> return $ IBinOp BS64 IAnd
|
|
0x84 -> return $ IBinOp BS64 IOr
|
|
0x85 -> return $ IBinOp BS64 IXor
|
|
0x86 -> return $ IBinOp BS64 IShl
|
|
0x87 -> return $ IBinOp BS64 IShrS
|
|
0x88 -> return $ IBinOp BS64 IShrU
|
|
0x89 -> return $ IBinOp BS64 IRotl
|
|
0x8A -> return $ IBinOp BS64 IRotr
|
|
0x8B -> return $ FUnOp BS32 FAbs
|
|
0x8C -> return $ FUnOp BS32 FNeg
|
|
0x8D -> return $ FUnOp BS32 FCeil
|
|
0x8E -> return $ FUnOp BS32 FFloor
|
|
0x8F -> return $ FUnOp BS32 FTrunc
|
|
0x90 -> return $ FUnOp BS32 FNearest
|
|
0x91 -> return $ FUnOp BS32 FSqrt
|
|
0x92 -> return $ FBinOp BS32 FAdd
|
|
0x93 -> return $ FBinOp BS32 FSub
|
|
0x94 -> return $ FBinOp BS32 FMul
|
|
0x95 -> return $ FBinOp BS32 FDiv
|
|
0x96 -> return $ FBinOp BS32 FMin
|
|
0x97 -> return $ FBinOp BS32 FMax
|
|
0x98 -> return $ FBinOp BS32 FCopySign
|
|
0x99 -> return $ FUnOp BS64 FAbs
|
|
0x9A -> return $ FUnOp BS64 FNeg
|
|
0x9B -> return $ FUnOp BS64 FCeil
|
|
0x9C -> return $ FUnOp BS64 FFloor
|
|
0x9D -> return $ FUnOp BS64 FTrunc
|
|
0x9E -> return $ FUnOp BS64 FNearest
|
|
0x9F -> return $ FUnOp BS64 FSqrt
|
|
0xA0 -> return $ FBinOp BS64 FAdd
|
|
0xA1 -> return $ FBinOp BS64 FSub
|
|
0xA2 -> return $ FBinOp BS64 FMul
|
|
0xA3 -> return $ FBinOp BS64 FDiv
|
|
0xA4 -> return $ FBinOp BS64 FMin
|
|
0xA5 -> return $ FBinOp BS64 FMax
|
|
0xA6 -> return $ FBinOp BS64 FCopySign
|
|
0xA7 -> return $ I32WrapI64
|
|
0xA8 -> return $ ITruncFS BS32 BS32
|
|
0xA9 -> return $ ITruncFU BS32 BS32
|
|
0xAA -> return $ ITruncFS BS32 BS64
|
|
0xAB -> return $ ITruncFU BS32 BS64
|
|
0xAC -> return $ I64ExtendSI32
|
|
0xAD -> return $ I64ExtendUI32
|
|
0xAE -> return $ ITruncFS BS64 BS32
|
|
0xAF -> return $ ITruncFU BS64 BS32
|
|
0xB0 -> return $ ITruncFS BS64 BS64
|
|
0xB1 -> return $ ITruncFU BS64 BS64
|
|
0xB2 -> return $ FConvertIS BS32 BS32
|
|
0xB3 -> return $ FConvertIU BS32 BS32
|
|
0xB4 -> return $ FConvertIS BS32 BS64
|
|
0xB5 -> return $ FConvertIU BS32 BS64
|
|
0xB6 -> return $ F32DemoteF64
|
|
0xB7 -> return $ FConvertIS BS64 BS32
|
|
0xB8 -> return $ FConvertIU BS64 BS32
|
|
0xB9 -> return $ FConvertIS BS64 BS64
|
|
0xBA -> return $ FConvertIU BS64 BS64
|
|
0xBB -> return $ F64PromoteF32
|
|
0xBC -> return $ IReinterpretF BS32
|
|
0xBD -> return $ IReinterpretF BS64
|
|
0xBE -> return $ FReinterpretI BS32
|
|
0xBF -> return $ FReinterpretI BS64
|
|
0xC0 -> return $ IUnOp BS32 IExtend8S
|
|
0xC1 -> return $ IUnOp BS32 IExtend16S
|
|
0xC2 -> return $ IUnOp BS64 IExtend8S
|
|
0xC3 -> return $ IUnOp BS64 IExtend16S
|
|
0xC4 -> return $ IUnOp BS64 IExtend32S
|
|
0xFC -> do -- misc
|
|
ext <- getULEB128 32
|
|
case (ext :: Word32) of
|
|
0x00 -> return $ ITruncSatFS BS32 BS32
|
|
0x01 -> return $ ITruncSatFU BS32 BS32
|
|
0x02 -> return $ ITruncSatFS BS32 BS64
|
|
0x03 -> return $ ITruncSatFU BS32 BS64
|
|
0x04 -> return $ ITruncSatFS BS64 BS32
|
|
0x05 -> return $ ITruncSatFU BS64 BS32
|
|
0x06 -> return $ ITruncSatFS BS64 BS64
|
|
0x07 -> return $ ITruncSatFU BS64 BS64
|
|
_ -> fail "Unknown byte value after misc instruction byte"
|
|
_ -> fail "Unknown byte value in place of instruction opcode"
|
|
|
|
putExpression :: Expression -> Put
|
|
putExpression expr = do
|
|
mapM_ put expr
|
|
putWord8 0x0B -- END
|
|
|
|
getExpression :: Get Expression
|
|
getExpression = go []
|
|
where
|
|
go :: Expression -> Get Expression
|
|
go acc = do
|
|
nextByte <- lookAhead getWord8
|
|
if nextByte == 0x0B -- END OF EXPR
|
|
then getWord8 >> (return $ reverse acc)
|
|
else get >>= \instr -> go (instr : acc)
|
|
|
|
getTrueBranch :: Get (Expression, Bool)
|
|
getTrueBranch = go []
|
|
where
|
|
go :: Expression -> Get (Expression, Bool)
|
|
go acc = do
|
|
nextByte <- lookAhead getWord8
|
|
case nextByte of
|
|
-- END OF EXPR
|
|
0x0B -> getWord8 >> (return $ (reverse acc, False))
|
|
-- ELSE
|
|
0x05 -> getWord8 >> (return $ (reverse acc, True))
|
|
_ -> get >>= \instr -> go (instr : acc)
|
|
|
|
instance Serialize Global where
|
|
put (Global globalType expr) = do
|
|
put globalType
|
|
putExpression expr
|
|
get = Global <$> get <*> getExpression
|
|
|
|
instance Serialize ExportDesc where
|
|
put (ExportFunc idx) = putWord8 0x00 >> putULEB128 idx
|
|
put (ExportTable idx) = putWord8 0x01 >> putULEB128 idx
|
|
put (ExportMemory idx) = putWord8 0x02 >> putULEB128 idx
|
|
put (ExportGlobal idx) = putWord8 0x03 >> putULEB128 idx
|
|
get = do
|
|
op <- getWord8
|
|
idx <- getULEB128 32
|
|
case op of
|
|
0x00 -> return $ ExportFunc idx
|
|
0x01 -> return $ ExportTable idx
|
|
0x02 -> return $ ExportMemory idx
|
|
0x03 -> return $ ExportGlobal idx
|
|
_ -> fail "Unexpected byte value in position of Export Description opcode"
|
|
|
|
instance Serialize Export where
|
|
put (Export name desc) = do
|
|
putName name
|
|
put desc
|
|
get = Export <$> getName <*> get
|
|
|
|
instance Serialize ElemSegment where
|
|
put (ElemSegment elemType Passive elements) = do
|
|
putWord8 0x05
|
|
put elemType
|
|
putVec $ map Expr elements
|
|
put (ElemSegment elemType (Active tableIndex offset) elements) = do
|
|
putWord8 0x06
|
|
putULEB128 tableIndex
|
|
putExpression offset
|
|
put elemType
|
|
putVec $ map Expr elements
|
|
put (ElemSegment elemType Declarative elements) = do
|
|
putWord8 0x07
|
|
put elemType
|
|
putVec $ map Expr elements
|
|
|
|
get = do
|
|
op <- getWord8
|
|
let funcIndexes = map ((:[]) . RefFunc . unIndex) <$> getVec
|
|
let elemKind = byteGuard 0x00 >> return FuncRef
|
|
case op of
|
|
0x00 -> do
|
|
offset <- getExpression
|
|
ElemSegment FuncRef (Active 0 offset) <$> funcIndexes
|
|
0x01 -> do
|
|
elemType <- elemKind
|
|
ElemSegment elemType Passive <$> funcIndexes
|
|
0x02 -> do
|
|
tableIndex <- getULEB128 32
|
|
offset <- getExpression
|
|
elemType <- elemKind
|
|
ElemSegment elemType (Active tableIndex offset) <$> funcIndexes
|
|
0x03 -> do
|
|
elemType <- elemKind
|
|
ElemSegment elemType Declarative <$> funcIndexes
|
|
0x04 -> do
|
|
offset <- getExpression
|
|
ElemSegment FuncRef (Active 0 offset) <$> funcIndexes
|
|
0x05 -> do
|
|
elemType <- get
|
|
ElemSegment elemType Passive <$> getVec
|
|
0x06 -> do
|
|
tableIndex <- getULEB128 32
|
|
offset <- getExpression
|
|
elemType <- get
|
|
ElemSegment elemType (Active tableIndex offset) <$> getVec
|
|
0x07 -> do
|
|
elemType <- get
|
|
ElemSegment elemType Declarative <$> getVec
|
|
_ ->
|
|
fail "unknown element segment type"
|
|
|
|
data LocalTypeRange = LocalTypeRange Natural ValueType deriving (Show, Eq)
|
|
|
|
instance Serialize LocalTypeRange where
|
|
put (LocalTypeRange len valType) = do
|
|
putULEB128 len
|
|
put valType
|
|
get = LocalTypeRange <$> getULEB128 32 <*> get
|
|
|
|
instance Serialize Function where
|
|
put Function {localTypes = locals, body} = do
|
|
let bs = runPut $ do
|
|
putVec $ map (LocalTypeRange 1) locals
|
|
putExpression body
|
|
putULEB128 $ BS.length bs
|
|
putByteString bs
|
|
get = do
|
|
_size <- getULEB128 32 :: Get Natural
|
|
localRanges <- getVec
|
|
let localLen = sum $ map (\(LocalTypeRange n _) -> n) localRanges
|
|
if localLen < 2^32 then return () else fail "too many locals"
|
|
let locals = concat $ map (\(LocalTypeRange n val) -> replicate (fromIntegral n) val) localRanges
|
|
body <- getExpression
|
|
return $ Function 0 locals body
|
|
|
|
instance Serialize DataSegment where
|
|
put (DataSegment memIdx offset init) = do
|
|
putULEB128 memIdx
|
|
putExpression offset
|
|
putULEB128 $ LBS.length init
|
|
putLazyByteString init
|
|
get = do
|
|
memIdx <- getULEB128 32
|
|
offset <- getExpression
|
|
len <- getULEB128 32
|
|
init <- getLazyByteString len
|
|
return $ DataSegment memIdx offset init
|
|
|
|
instance Serialize Module where
|
|
put mod = do
|
|
-- magic
|
|
mapM_ putWord8 [0x00, 0x61, 0x73, 0x6D]
|
|
-- version
|
|
mapM_ putWord8 [0x01, 0x00, 0x00, 0x00]
|
|
|
|
putSection TypeSection $ putVec $ types mod
|
|
putSection ImportSection $ putVec $ imports mod
|
|
putSection FunctionSection $ putVec $ map (Index . funcType) $ functions mod
|
|
putSection TableSection $ putVec $ tables mod
|
|
putSection MemorySection $ putVec $ mems mod
|
|
putSection GlobalSection $ putVec $ globals mod
|
|
putSection ExportSection $ putVec $ exports mod
|
|
case start mod of
|
|
Just (StartFunction idx) -> putSection StartSection $ putULEB128 idx
|
|
Nothing -> return ()
|
|
putSection ElementSection $ putVec $ elems mod
|
|
putSection CodeSection $ putVec $ functions mod
|
|
putSection DataSection $ putVec $ datas mod
|
|
|
|
get = do
|
|
magic <- getWord32be
|
|
if magic == 0x0061736D then return () else fail "magic header not detected"
|
|
version <- getWord32be
|
|
if version == 0x01000000 then return () else fail "unknown binary version"
|
|
types <- getSection TypeSection getVec []
|
|
imports <- getSection ImportSection getVec []
|
|
funcTypes <- getSection FunctionSection getVec []
|
|
tables <- getSection TableSection getVec []
|
|
mems <- getSection MemorySection getVec []
|
|
globals <- getSection GlobalSection getVec []
|
|
exports <- getSection ExportSection getVec []
|
|
start <- getSection StartSection (Just . StartFunction <$> getULEB128 32) Nothing
|
|
elems <- getSection ElementSection getVec []
|
|
functions <- getSection CodeSection getVec []
|
|
datas <- getSection DataSection getVec []
|
|
if length funcTypes /= length functions
|
|
then fail "function and code section have inconsistent lengths"
|
|
else return ()
|
|
return $ emptyModule {
|
|
types,
|
|
imports,
|
|
tables,
|
|
mems,
|
|
globals,
|
|
exports,
|
|
start,
|
|
elems,
|
|
functions = zipWith (\(Index funcType) fun -> fun { funcType }) funcTypes functions,
|
|
datas
|
|
}
|
|
|
|
|
|
dumpModule :: Module -> BS.ByteString
|
|
dumpModule = encode
|
|
|
|
dumpModuleLazy :: Module -> LBS.ByteString
|
|
dumpModuleLazy = encodeLazy
|
|
|
|
decodeModule :: BS.ByteString -> Either String Module
|
|
decodeModule = decode
|
|
|
|
decodeModuleLazy :: LBS.ByteString -> Either String Module
|
|
decodeModuleLazy = decodeLazy |