start builder api
This commit is contained in:
Ilya Rezvov
+2
-1
@@ -1,2 +1,3 @@
|
||||
.stack-work
|
||||
tests/runnable/*
|
||||
tests/runnable/*
|
||||
dist/
|
||||
@@ -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
|
||||
|
||||
@@ -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))
|
||||
)
|
||||
)
|
||||
)
|
||||
-}
|
||||
@@ -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
|
||||
|
||||
@@ -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)) =
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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)
|
||||
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -45,6 +45,7 @@ library
|
||||
Language.Wasm.Interpreter
|
||||
Language.Wasm.Script
|
||||
Language.Wasm.FloatUtils
|
||||
Language.Wasm.Builder
|
||||
Language.Wasm
|
||||
other-modules:
|
||||
Paths_wasm
|
||||
|
||||
Reference in New Issue
Block a user