From 1330eb41f66138425489c37b5d33485be595059f Mon Sep 17 00:00:00 2001 From: Ilya Rezvov Date: Sat, 12 May 2018 22:37:50 -0700 Subject: [PATCH] start builder api --- .gitignore | 3 +- src/Language/Wasm/Binary.hs | 7 +- src/Language/Wasm/Builder.hs | 271 +++++++++++++++++++++++++++++++ src/Language/Wasm/Interpreter.hs | 8 +- src/Language/Wasm/Parser.y | 10 +- src/Language/Wasm/Script.hs | 2 +- src/Language/Wasm/Structure.hs | 26 +-- src/Language/Wasm/Validate.hs | 8 +- wasm.cabal | 1 + 9 files changed, 304 insertions(+), 32 deletions(-) create mode 100644 src/Language/Wasm/Builder.hs diff --git a/.gitignore b/.gitignore index ede7fdb..1454f89 100644 --- a/.gitignore +++ b/.gitignore @@ -1,2 +1,3 @@ .stack-work -tests/runnable/* \ No newline at end of file +tests/runnable/* +dist/ \ No newline at end of file diff --git a/src/Language/Wasm/Binary.hs b/src/Language/Wasm/Binary.hs index fe443e7..8565fab 100644 --- a/src/Language/Wasm/Binary.hs +++ b/src/Language/Wasm/Binary.hs @@ -1,5 +1,6 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} module Language.Wasm.Binary ( dumpModule, @@ -297,7 +298,7 @@ instance Serialize MemArg where put (MemArg align offset) = putULEB128 align >> putULEB128 offset get = MemArg <$> getULEB128 32 <*> getULEB128 32 -instance Serialize Instruction where +instance Serialize (Instruction Natural) where put Unreachable = putWord8 0x00 put Nop = putWord8 0x01 put (Block result body) = do @@ -682,7 +683,7 @@ putExpression expr = do getExpression :: Get Expression getExpression = go [] where - go :: [Instruction] -> Get Expression + go :: Expression -> Get Expression go acc = do nextByte <- lookAhead getWord8 if nextByte == 0x0B -- END OF EXPR @@ -692,7 +693,7 @@ getExpression = go [] getTrueBranch :: Get (Expression, Bool) getTrueBranch = go [] where - go :: [Instruction] -> Get (Expression, Bool) + go :: Expression -> Get (Expression, Bool) go acc = do nextByte <- lookAhead getWord8 case nextByte of diff --git a/src/Language/Wasm/Builder.hs b/src/Language/Wasm/Builder.hs new file mode 100644 index 0000000..73ac986 --- /dev/null +++ b/src/Language/Wasm/Builder.hs @@ -0,0 +1,271 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} + +module Language.Wasm.Builder ( +) where + +import Prelude hiding (and) +import qualified Data.List as List +import qualified Data.Maybe as Maybe +import Control.Monad.State (State, execState, get, put, modify) +import Numeric.Natural +import Data.Word (Word32, Word64) +import Data.Int (Int32, Int64) +import Data.Proxy + +import qualified Data.Text.Lazy as TL + +import Language.Wasm.Structure + +data FuncDef = FuncDef { + args :: [ValueType], + results :: [ValueType], + locals :: [ValueType], + instrs :: Expression +} deriving (Show, Eq) + +type GenFun = State FuncDef + +newtype Loc t = Loc Natural deriving (Show, Eq) + +param :: (ValueTypeable t) => Proxy t -> GenFun (Loc t) +param t = do + f@FuncDef { args } <- get + put $ f { args = args ++ [getValueType t] } + return $ Loc $ fromIntegral $ length args + +local :: (ValueTypeable t) => Proxy t -> GenFun (Loc t) +local t = do + f@FuncDef { args, locals } <- get + put $ f { locals = locals ++ [getValueType t]} + return $ Loc $ fromIntegral $ length args + length locals + +appendExpr :: Expression -> GenFun () +appendExpr expr = do + modify $ \def -> def { instrs = instrs def ++ expr } + return () + +after :: Expression -> GenFun a -> GenFun a +after instr expr = do + res <- expr + modify $ \def -> def { instrs = instrs def ++ instr } + return res + +class Producer expr where + type OutType expr + asValueType :: expr -> ValueType + produce :: expr -> GenFun (OutType expr) + +instance (ValueTypeable t) => Producer (Loc t) where + type OutType (Loc t) = Proxy t + asValueType e = getValueType (t e) + where + t :: Loc t -> Proxy t + t _ = Proxy + produce (Loc i) = appendExpr [GetLocal i] >> return Proxy + +instance (ValueTypeable t) => Producer (Glob t) where + type OutType (Glob t) = Proxy t + asValueType e = getValueType (t e) + where + t :: Glob t -> Proxy t + t _ = Proxy + produce (Glob i) = appendExpr [GetGlobal i] >> return Proxy + +instance (ValueTypeable t) => Producer (GenFun (Proxy t)) where + type OutType (GenFun (Proxy t)) = Proxy t + asValueType e = getValueType (t e) + where + t :: GenFun (Proxy t) -> Proxy t + t _ = Proxy + produce = id + +ret :: (Producer expr) => expr -> GenFun () +ret e = produce e >> return () + +arg :: (Producer expr) => expr -> GenFun () +arg e = produce e >> return () + +getSize :: ValueType -> BitSize +getSize I32 = BS32 +getSize I64 = BS32 +getSize F32 = BS64 +getSize F64 = BS64 + +binOp :: (Producer a, Producer b, OutType a ~ OutType b) => IBinOp -> a -> b -> GenFun (OutType a) +binOp op a b = produce a >> after [IBinOp (getSize $ asValueType a) op] (produce b) + +add :: (Producer a, Producer b, OutType a ~ OutType b) => a -> b -> GenFun (OutType a) +add = binOp IAdd + +and :: (Producer a, Producer b, OutType a ~ OutType b) => a -> b -> GenFun (OutType a) +and = binOp IAnd + +i32const :: (Integral i) => i -> GenFun (Proxy I32) +i32const i = appendExpr [I32Const $ asWord32 $ fromIntegral i] >> return Proxy + +call :: Proxy t -> Natural -> [GenFun a] -> GenFun (Proxy t) +call t idx args = sequence_ args >> appendExpr [Call idx] >> return t + +-- if' :: (Producer pred, OutType pred ~ I32, OutType true ~ OutType false) => pred -> true -> false -> GenFun (OutType true) +-- if' pred true false = do +-- appendExpr [If idx] + +class Consumer loc where + (.=) :: (Producer expr) => loc -> expr -> GenFun () + +instance Consumer (Loc t) where + (.=) (Loc i) expr = produce expr >> appendExpr [SetLocal i] + +instance Consumer (Glob t) where + (.=) (Glob i) expr = produce expr >> appendExpr [SetGlobal i] + +fun :: (Natural -> GenFun a) -> GenMod Natural +fun generator = do + st@GenModState { target = m@Module { types, functions }, funcIdx } <- get + let FuncDef { args, results, locals, instrs } = execState (generator funcIdx) $ FuncDef [] [] [] [] + let t = FuncType args results + 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 }, + funcIdx = funcIdx + 1 + } + return funcIdx + +data GenModState = GenModState { + funcIdx :: Natural, + globIdx :: Natural, + target :: Module +} deriving (Show, Eq) + +type GenMod = State GenModState + +genMod :: GenMod a -> Module +genMod = target . flip execState (GenModState 0 0 emptyModule) + +importFunc :: TL.Text -> TL.Text -> FuncType -> GenMod Natural +importFunc mod name t = do + st@GenModState { target = m@Module { types, imports }, funcIdx } <- get + let (idx, inserted) = Maybe.fromMaybe (length types, types ++ [t]) $ (\i -> (i, types)) <$> List.findIndex (== t) types + put $ st { + target = m { imports = imports ++ [Import mod name $ ImportFunc $ fromIntegral idx], types = inserted }, + funcIdx = funcIdx + 1 + } + return funcIdx + +class ValueTypeable a where + type ValType a + getValueType :: (Proxy a) -> ValueType + initWith :: (Proxy a) -> (ValType a) -> Expression + +instance ValueTypeable I32 where + type ValType I32 = Word32 + getValueType _ = I32 + initWith _ w = [I32Const w] + +instance ValueTypeable I64 where + type ValType I64 = Word64 + getValueType _ = I64 + initWith _ w = [I64Const w] + +instance ValueTypeable F32 where + type ValType F32 = Float + getValueType _ = F32 + initWith _ f = [F32Const f] + +instance ValueTypeable F64 where + type ValType F64 = Double + getValueType _ = F64 + initWith _ d = [F64Const d] + +i32 = Proxy @I32 +i64 = Proxy @I64 +f32 = Proxy @F32 +f64 = Proxy @F64 + +newtype Glob t = Glob Natural deriving (Show, Eq) + +global :: (ValueTypeable t) => (ValueType -> GlobalType) -> Proxy t -> (ValType t) -> GenMod (Glob t) +global mkType t val = do + st@GenModState { target = m@Module { globals }, globIdx } <- get + put $ st { + target = m { globals = globals ++ [Global (mkType $ getValueType t) (initWith t val)] }, + globIdx = globIdx + 1 + } + return $ Glob globIdx + +asWord32 :: Int32 -> Word32 +asWord32 i + | i >= 0 = fromIntegral i + | otherwise = 0xFFFFFFFF - (fromIntegral (abs i)) + 1 + +asWord64 :: Int64 -> Word64 +asWord64 i + | i >= 0 = fromIntegral i + | otherwise = 0xFFFFFFFFFFFFFFFF - (fromIntegral (abs i)) + 1 + +rts :: Module +rts = genMod $ do + gc <- importFunc "rts" "gc" (FuncType [I32] []) + + stackStart <- global Const i32 0 + stackEnd <- global Const i32 0 + stackBase <- global Mut i32 0 + stackTop <- global Mut i32 0 + + retReg <- global Mut i32 0 + tmpReg <- global Mut i32 0 + + heapStart <- global Mut i32 0 + heapNext <- global Mut i32 0 + heapEnd <- global Mut i32 0 + aligned <- fun $ \_ -> do + size <- param i32 + (size `add` i32const 3) `and` i32const 0xFFFFFFFC + alloc <- fun $ \self -> do + size <- param i32 + alignedSize <- local i32 + addr <- local i32 + alignedSize .= call i32 aligned [arg size] + -- if' ((heapNext `plus` alignedSize) `lt_u` heapEnd) + -- (do + -- addr .= nextHeap + -- nextHeap .= nextHeap `plus` alignedSize + -- ret addr + -- ) + -- (do + -- call gc [] + -- call alloc [ref size] + -- ) + ret addr + return () + +{- + (func $alloc (param $size i32) (result i32) + (local $aligned-size i32) + (local $addr i32) + (set_local $aligned-size (call $alligned (get_local $size))) + (if (i32.lt_u (i32.add (get_global $heap-next) (get_local $aligned-size)) (get_global $heap-end)) + (then + (set_local $addr (get_global $heap-next)) + (set_global $heap-next (i32.add (get_global $heap-next) (get_local $aligned-size))) + (get_local $addr) + ) + (else + (call $run-gc) + (call $alloc (get_local $size)) + ) + ) + ) +-} \ No newline at end of file diff --git a/src/Language/Wasm/Interpreter.hs b/src/Language/Wasm/Interpreter.hs index b12a022..99202a6 100644 --- a/src/Language/Wasm/Interpreter.hs +++ b/src/Language/Wasm/Interpreter.hs @@ -431,7 +431,7 @@ getGlobalValue inst store idx = GIMut _ ref -> readIORef ref -- due the validation there can be only these instructions -evalConstExpr :: ModuleInstance -> Store -> [Instruction] -> IO Value +evalConstExpr :: ModuleInstance -> Store -> Expression -> IO Value evalConstExpr _ _ [I32Const v] = return $ VI32 v evalConstExpr _ _ [I64Const v] = return $ VI64 v evalConstExpr _ _ [F32Const v] = return $ VF32 v @@ -442,7 +442,7 @@ evalConstExpr _ _ instrs = error $ "Global initializer contains unsupported inst allocAndInitGlobals :: ModuleInstance -> Store -> [Global] -> IO (Vector GlobalInstance) allocAndInitGlobals inst store globs = Vector.fromList <$> mapM allocGlob globs where - runIniter :: [Instruction] -> IO Value + runIniter :: Expression -> IO Value -- the spec says get global can ref only imported globals -- only they are in store for this moment runIniter = evalConstExpr inst store @@ -594,7 +594,7 @@ eval budget store FunctionInstance { funcType, moduleInstance, code = Function { initLocal F32 = VF32 0 initLocal F64 = VF64 0 - go :: EvalCtx -> [Instruction] -> IO EvalResult + go :: EvalCtx -> Expression -> IO EvalResult go ctx [] = return $ Done ctx go ctx (instr:rest) = do res <- step ctx instr @@ -630,7 +630,7 @@ eval budget store FunctionInstance { funcType, moduleInstance, code = Function { return $ Done ctx { stack = rest } makeStoreInstr _ _ _ _ = error "Incorrect value on top of stack for memory instruction" - step :: EvalCtx -> Instruction -> IO EvalResult + step :: EvalCtx -> Instruction Natural -> IO EvalResult step _ Unreachable = return Trap step ctx Nop = return $ Done ctx step ctx (Block resType expr) = do diff --git a/src/Language/Wasm/Parser.y b/src/Language/Wasm/Parser.y index 25a60cf..236f561 100644 --- a/src/Language/Wasm/Parser.y +++ b/src/Language/Wasm/Parser.y @@ -1440,8 +1440,6 @@ data Module = Module { type Script = [Command] -type Expression = [Instruction] - data ModuleDef = RawModDef (Maybe Ident) S.Module | TextModDef (Maybe Ident) TL.Text @@ -1457,14 +1455,14 @@ data Command deriving (Show, Eq) data Action - = Invoke (Maybe Ident) TL.Text [[S.Instruction]] + = Invoke (Maybe Ident) TL.Text [S.Expression] | Get (Maybe Ident) TL.Text deriving (Show, Eq) type FailureString = TL.Text data Assertion - = AssertReturn Action [[S.Instruction]] + = AssertReturn Action [S.Expression] | AssertReturnCanonicalNaN Action | AssertReturnArithmeticNaN Action | AssertTrap (Either Action ModuleDef) FailureString @@ -1489,7 +1487,7 @@ data FunCtx = FunCtx { ctxParams :: [ParamType] } deriving (Eq, Show) -constInstructionToValue :: Instruction -> S.Instruction +constInstructionToValue :: Instruction -> S.Instruction Natural constInstructionToValue (PlainInstr (I32Const v)) = S.I32Const $ integerToWord32 v constInstructionToValue (PlainInstr (F32Const v)) = S.F32Const v constInstructionToValue (PlainInstr (I64Const v)) = S.I64Const $ integerToWord64 v @@ -1639,7 +1637,7 @@ desugarize fields = do Nothing -> Left "unknown label" -- functions - synInstrToStruct :: FunCtx -> Instruction -> Either String S.Instruction + synInstrToStruct :: FunCtx -> Instruction -> Either String (S.Instruction Natural) synInstrToStruct _ (PlainInstr Unreachable) = return S.Unreachable synInstrToStruct _ (PlainInstr Nop) = return S.Nop synInstrToStruct ctx (PlainInstr (Br labelIdx)) = diff --git a/src/Language/Wasm/Script.hs b/src/Language/Wasm/Script.hs index 0f49494..49ce7d7 100644 --- a/src/Language/Wasm/Script.hs +++ b/src/Language/Wasm/Script.hs @@ -106,7 +106,7 @@ runScript onAssertFail script = do getModule st (Just (Ident i)) = Map.lookup i (modules st) getModule st Nothing = lastModule st - asArg :: [Struct.Instruction] -> Interpreter.Value + asArg :: Struct.Expression -> Interpreter.Value asArg [Struct.I32Const v] = Interpreter.VI32 v asArg [Struct.F32Const v] = Interpreter.VF32 v asArg [Struct.I64Const v] = Interpreter.VI64 v diff --git a/src/Language/Wasm/Structure.hs b/src/Language/Wasm/Structure.hs index 1e884a1..1817e98 100644 --- a/src/Language/Wasm/Structure.hs +++ b/src/Language/Wasm/Structure.hs @@ -102,28 +102,28 @@ type LocalsType = [ValueType] data FuncType = FuncType { params :: ParamsType, results :: ResultType } deriving (Show, Eq, Generic, NFData) -data Instruction = +data Instruction index = -- Control instructions Unreachable | Nop | Block { result :: ResultType, body :: Expression } | Loop { result :: ResultType, body :: Expression } | If { result :: ResultType, true :: Expression, false :: Expression } - | Br LabelIndex - | BrIf LabelIndex - | BrTable [LabelIndex] LabelIndex + | Br index + | BrIf index + | BrTable [index] index | Return - | Call FuncIndex - | CallIndirect TypeIndex + | Call index + | CallIndirect index -- Parametric instructions | Drop | Select -- Variable instructions - | GetLocal LocalIndex - | SetLocal LocalIndex - | TeeLocal LocalIndex - | GetGlobal GlobalIndex - | SetGlobal GlobalIndex + | GetLocal index + | SetLocal index + | TeeLocal index + | GetGlobal index + | SetGlobal index -- Memory instructions | I32Load MemArg | I64Load MemArg @@ -176,7 +176,7 @@ data Instruction = | FReinterpretI BitSize deriving (Show, Eq, Generic, NFData) -type Expression = [Instruction] +type Expression = [Instruction Natural] data Function = Function { funcType :: TypeIndex, @@ -203,7 +203,7 @@ data Global = Global { data ElemSegment = ElemSegment { tableIndex :: TableIndex, - offset :: [Instruction], + offset :: Expression, funcIndexes :: [FuncIndex] } deriving (Show, Eq, Generic, NFData) diff --git a/src/Language/Wasm/Validate.hs b/src/Language/Wasm/Validate.hs index 3edeb0f..73736ae 100644 --- a/src/Language/Wasm/Validate.hs +++ b/src/Language/Wasm/Validate.hs @@ -177,7 +177,7 @@ checkMemoryInstr size memarg = do Ctx { mems } <- ask if length mems < 1 then throwError MemoryIndexOutOfRange else return () -getInstrType :: Instruction -> Checker Arrow +getInstrType :: Instruction Natural -> Checker Arrow getInstrType Unreachable = return $ Any ==> Any getInstrType Nop = return $ empty ==> empty getInstrType Block { result, body } = do @@ -375,10 +375,10 @@ replace :: (Eq a) => a -> a -> [a] -> [a] replace _ _ [] = [] replace x y (v:r) = (if x == v then y else v) : replace x y r -getExpressionType :: [Instruction] -> Checker Arrow +getExpressionType :: Expression -> Checker Arrow getExpressionType = fmap ([] `Arrow`) . foldM go [] where - go :: [VType] -> Instruction -> Checker [VType] + go :: [VType] -> Instruction Natural -> Checker [VType] go stack instr = do (f `Arrow` t) <- getInstrType instr matchStack stack (reverse f) t @@ -397,7 +397,7 @@ getExpressionType = fmap ([] `Arrow`) . foldM go [] matchStack [] args res = throwError $ TypeMismatch ((reverse args) `Arrow` res) ([] `Arrow` []) matchStack _ _ _ = error "inconsistent checker state" -isConstExpression :: [Instruction] -> Checker () +isConstExpression :: Expression -> Checker () isConstExpression [] = return () isConstExpression ((I32Const _):rest) = isConstExpression rest isConstExpression ((I64Const _):rest) = isConstExpression rest diff --git a/wasm.cabal b/wasm.cabal index 104efc3..133c348 100644 --- a/wasm.cabal +++ b/wasm.cabal @@ -45,6 +45,7 @@ library Language.Wasm.Interpreter Language.Wasm.Script Language.Wasm.FloatUtils + Language.Wasm.Builder Language.Wasm other-modules: Paths_wasm