From 05ad97a30e38e7324019a9f29b035e93debc46d1 Mon Sep 17 00:00:00 2001 From: Ilya Rezvov Date: Tue, 22 May 2018 18:47:10 -0700 Subject: [PATCH] fix binary generation --- src/Language/Wasm/Binary.hs | 10 +++++----- src/Language/Wasm/Builder.hs | 26 +++++++++++++++----------- src/Language/Wasm/Structure.hs | 6 +++--- src/Language/Wasm/Validate.hs | 24 ++++++++++++------------ 4 files changed, 35 insertions(+), 31 deletions(-) diff --git a/src/Language/Wasm/Binary.hs b/src/Language/Wasm/Binary.hs index 8565fab..39c3f05 100644 --- a/src/Language/Wasm/Binary.hs +++ b/src/Language/Wasm/Binary.hs @@ -295,7 +295,7 @@ instance Serialize Index where get = Index <$> getULEB128 32 instance Serialize MemArg where - put (MemArg align offset) = putULEB128 align >> putULEB128 offset + put MemArg { align, offset } = putULEB128 align >> putULEB128 offset get = MemArg <$> getULEB128 32 <*> getULEB128 32 instance Serialize (Instruction Natural) where @@ -309,13 +309,13 @@ instance Serialize (Instruction Natural) where putWord8 0x03 putResultType result putExpression body - put If {result, true, false = []} = do + put If {resultType, true, false = []} = do putWord8 0x04 - putResultType result + putResultType resultType putExpression true - put If {result, true, false} = do + put If {resultType, true, false} = do putWord8 0x04 - putResultType result + putResultType resultType mapM_ put true putWord8 0x05 -- ELSE putExpression false diff --git a/src/Language/Wasm/Builder.hs b/src/Language/Wasm/Builder.hs index 3f9c003..68a4678 100644 --- a/src/Language/Wasm/Builder.hs +++ b/src/Language/Wasm/Builder.hs @@ -23,8 +23,7 @@ module Language.Wasm.Builder ( nextFuncIndex, setGlobalInitializer, GenFun, Glob, Loc, - param, - local, + param, local, result, ret, arg, i32, i64, f32, f64, @@ -59,7 +58,7 @@ import Language.Wasm.Structure data FuncDef = FuncDef { args :: [ValueType], - results :: [ValueType], + returns :: [ValueType], locals :: [ValueType], instrs :: Expression } deriving (Show, Eq) @@ -83,6 +82,11 @@ local t = do put $ f { locals = locals ++ [getValueType t]} return $ Loc $ fromIntegral $ length args + length locals +result :: (ValueTypeable t) => Proxy t -> GenFun () +result t = do + f@FuncDef { returns } <- get + put $ f { returns = returns ++ [getValueType t] } + appendExpr :: Expression -> GenFun () appendExpr expr = do modify $ \def -> def { instrs = instrs def ++ expr } @@ -131,8 +135,8 @@ arg e = produce e >> return () getSize :: ValueType -> BitSize getSize I32 = BS32 -getSize I64 = BS32 -getSize F32 = BS64 +getSize I64 = BS64 +getSize F32 = BS32 getSize F64 = BS64 type family IsInt i :: Bool where @@ -322,8 +326,8 @@ store :: (Producer addr, OutType addr ~ Proxy I32, Producer val, Integral offset -> align -> GenFun () store addr val offset align = do - produce val produce addr + produce val case asValueType val of I32 -> appendExpr [I32Store $ MemArg (fromIntegral offset) (fromIntegral align)] I64 -> appendExpr [I64Store $ MemArg (fromIntegral offset) (fromIntegral align)] @@ -337,8 +341,8 @@ store8 :: (Producer addr, OutType addr ~ Proxy I32, Producer val, IsInt (OutType -> align -> GenFun () store8 addr val offset align = do - produce val produce addr + produce val case asValueType val of I32 -> appendExpr [I32Store8 $ MemArg (fromIntegral offset) (fromIntegral align)] I64 -> appendExpr [I64Store8 $ MemArg (fromIntegral offset) (fromIntegral align)] @@ -351,8 +355,8 @@ store16 :: (Producer addr, OutType addr ~ Proxy I32, Producer val, IsInt (OutTyp -> align -> GenFun () store16 addr val offset align = do - produce val produce addr + produce val case asValueType val of I32 -> appendExpr [I32Store16 $ MemArg (fromIntegral offset) (fromIntegral align)] I64 -> appendExpr [I64Store16 $ MemArg (fromIntegral offset) (fromIntegral align)] @@ -365,8 +369,8 @@ store32 :: (Producer addr, OutType addr ~ Proxy I32, Producer val, OutType val ~ -> align -> GenFun () store32 addr val offset align = do - produce val produce addr + produce val appendExpr [I64Store32 $ MemArg (fromIntegral offset) (fromIntegral align)] invoke :: Natural -> [GenFun a] -> GenFun () @@ -448,8 +452,8 @@ typedef t = do funRec :: (Natural -> GenFun a) -> GenMod Natural funRec generator = do st@GenModState { target = m@Module { types, functions }, funcIdx } <- get - let FuncDef { args, results, locals, instrs } = execState (runReaderT (generator funcIdx) 0) $ FuncDef [] [] [] [] - let t = FuncType args results + let FuncDef { args, returns, locals, instrs } = execState (runReaderT (generator funcIdx) 0) $ FuncDef [] [] [] [] + let t = FuncType args returns let (idx, inserted) = Maybe.fromMaybe (length types, types ++ [t]) $ (\i -> (i, types)) <$> List.findIndex (== t) types put $ st { target = m { functions = functions ++ [Function (fromIntegral idx) locals instrs], types = inserted }, diff --git a/src/Language/Wasm/Structure.hs b/src/Language/Wasm/Structure.hs index 1817e98..9d5877b 100644 --- a/src/Language/Wasm/Structure.hs +++ b/src/Language/Wasm/Structure.hs @@ -106,9 +106,9 @@ data Instruction index = -- Control instructions Unreachable | Nop - | Block { result :: ResultType, body :: Expression } - | Loop { result :: ResultType, body :: Expression } - | If { result :: ResultType, true :: Expression, false :: Expression } + | Block { resultType :: ResultType, body :: Expression } + | Loop { resultType :: ResultType, body :: Expression } + | If { resultType :: ResultType, true :: Expression, false :: Expression } | Br index | BrIf index | BrTable [index] index diff --git a/src/Language/Wasm/Validate.hs b/src/Language/Wasm/Validate.hs index 73736ae..a561493 100644 --- a/src/Language/Wasm/Validate.hs +++ b/src/Language/Wasm/Validate.hs @@ -180,24 +180,24 @@ checkMemoryInstr size memarg = do getInstrType :: Instruction Natural -> Checker Arrow getInstrType Unreachable = return $ Any ==> Any getInstrType Nop = return $ empty ==> empty -getInstrType Block { result, body } = do - let blockType = empty ==> result - t <- withLabel result $ getExpressionType body +getInstrType Block { resultType, body } = do + let blockType = empty ==> resultType + t <- withLabel resultType $ getExpressionType body if isArrowMatch t blockType - then return $ empty ==> result + then return $ empty ==> resultType else throwError $ TypeMismatch t blockType -getInstrType Loop { result, body } = do - let blockType = empty ==> result +getInstrType Loop { resultType, body } = do + let blockType = empty ==> resultType t <- withLabel [] $ getExpressionType body if isArrowMatch t blockType - then return $ empty ==> result + then return $ empty ==> resultType else throwError $ TypeMismatch t blockType -getInstrType If { result, true, false } = do - let blockType = empty ==> result - l <- withLabel result $ getExpressionType true - r <- withLabel result $ getExpressionType false +getInstrType If { resultType, true, false } = do + let blockType = empty ==> resultType + l <- withLabel resultType $ getExpressionType true + r <- withLabel resultType $ getExpressionType false if isArrowMatch l blockType - then (if isArrowMatch r blockType then (return $ I32 ==> result) else (throwError $ TypeMismatch r blockType)) + then (if isArrowMatch r blockType then (return $ I32 ==> resultType) else (throwError $ TypeMismatch r blockType)) else throwError $ TypeMismatch l blockType getInstrType (Br lbl) = do r <- map Val . maybeToList <$> getLabel lbl