{-# LANGUAGE NamedFieldPuns #-} module Language.Wasm.Binary ( dumpModule, dumpModuleLazy ) where import Language.Wasm.Structure import Numeric.Natural (Natural) import Data.Bits import Data.Word (Word8) import Data.Int (Int8) 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 getULEB128 :: (Integral a, Bits a) => Get a getULEB128 = do val <- getWord8 if val < 2 ^ 7 then return $ fromIntegral val else do rest <- getULEB128 return $ (fromIntegral $ 0x7F .&. val) + 128 * rest 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) => Get a getSLEB128 = do let toInt8 :: Word8 -> Int8 toInt8 = fromIntegral a <- getWord8 if not (testBit a 7) then return . fromIntegral . toInt8 $ (a .&. 0x7f) .|. ((a .&. 0x40) `shiftL` 1) else do b <- getSLEB128 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 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 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 bytes <- getLazyByteString len return $ TLEncoding.decodeUtf8 bytes putResultType :: ResultType -> Put putResultType [] = putWord8 0x40 putResultType [valType] = put valType putResultType _ = fail "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" 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 AnyFunc = putWord8 0x70 get = byteGuard 0x70 >> return AnyFunc 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 return $ Limit min Nothing 0x01 -> do min <- getULEB128 max <- getULEB128 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 "Unexpected byte in place of Global type opcode" 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 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 instance Serialize MemArg where put (MemArg offset align) = putULEB128 align >> putULEB128 offset get = MemArg <$> getULEB128 <*> getULEB128 instance Serialize Instruction where put Unreachable = putWord8 0x00 put Nop = putWord8 0x01 put (Block result body) = do putWord8 0x02 putResultType result mapM_ put body putWord8 0x0B -- END put (Loop result body) = do putWord8 0x03 putResultType result mapM_ put body putWord8 0x0B -- END put If {result, true, false = []} = do putWord8 0x04 putResultType result mapM_ put true putWord8 0x0B -- END put If {result, true, false} = do putWord8 0x04 putResultType result mapM_ put true putWord8 0x05 -- ELSE mapM_ put false putWord8 0x0B -- END 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 typeIdx) = putWord8 0x11 >> putULEB128 typeIdx >> putWord8 0x00 -- 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 val put (I64Const val) = putWord8 0x42 >> putSLEB128 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 0xB4 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 get = undefined putExpression :: Expression -> Put putExpression expr = do mapM_ put expr putWord8 0x0B -- END getExpression :: Get Expression getExpression = go [] where go :: [Instruction] -> 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) 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 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 tableIndex offset funcIndexes) = do putULEB128 tableIndex putExpression offset putVec $ map Index funcIndexes get = ElemSegment <$> getULEB128 <*> getExpression <*> (map unIndex <$> getVec) data LocalTypeRange = LocalTypeRange Natural ValueType deriving (Show, Eq) instance Serialize LocalTypeRange where put (LocalTypeRange len valType) = do putULEB128 len put valType get = LocalTypeRange <$> getULEB128 <*> get instance Serialize Function where put (Function _ locals body) = do let bs = runPut $ do putVec $ map (LocalTypeRange 1) locals putExpression body putULEB128 $ BS.length bs putByteString bs get = do _size <- getULEB128 :: Get Natural locals <- concat . map (\(LocalTypeRange n val) -> replicate (fromIntegral n) val) <$> getVec 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 offset <- getExpression len <- getULEB128 init <- getLazyByteString len return $ DataSegment memIdx offset init instance Serialize Module where put mod = do -- magic putWord8 0x00 putWord8 0x61 putWord8 0x73 putWord8 0x6D -- version putWord8 0x01 putWord8 0x00 putWord8 0x00 putWord8 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 = undefined dumpModule :: Module -> BS.ByteString dumpModule = encode dumpModuleLazy :: Module -> LBS.ByteString dumpModuleLazy = encodeLazy