start builder api

.gitignore

@@ -1,2 +1,3 @@
 .stack-work
 tests/runnable/*
+dist/

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

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))
+            )
+        )
+    )
+-}

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

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)) =

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

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
+    | Br index
-    | BrIf LabelIndex
+    | BrIf index
-    | BrTable [LabelIndex] LabelIndex
+    | BrTable [index] index
     | Return
-    | Call FuncIndex
+    | Call index
-    | CallIndirect TypeIndex
+    | CallIndirect index
     -- Parametric instructions
     | Drop
     | Select
     -- Variable instructions
-    | GetLocal LocalIndex
+    | GetLocal index
-    | SetLocal LocalIndex
+    | SetLocal index
-    | TeeLocal LocalIndex
+    | TeeLocal index
-    | GetGlobal GlobalIndex
+    | GetGlobal index
-    | SetGlobal GlobalIndex
+    | 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)
 

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

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