Commit 9f4b0e2b authored by Katharina Brandl's avatar Katharina Brandl
Browse files

running fact example

parent baacf36a
......@@ -19,5 +19,5 @@ extra-deps:
- git: https://github.com/svenkeidel/husk-scheme/
commit: ca59598b11065eb29a45af7ffca27fc42a49abe5
- git: https://gitlab.rlp.net/plmz/external/haskell-wasm.git
commit: 0c1cf172abda013099b46549ede9ea2c1aa84b7e
commit: 9e764fb16d7a1f44ce031f491b176096b9a799f4
- knob-0.1.1
......@@ -42,18 +42,21 @@ import Control.Category
import Data.Concrete.Error
import qualified Data.Function as Function
import Data.Monoidal (shuffle1)
import Data.Profunctor
import Data.Text.Lazy (Text)
import Data.Vector (Vector, (!), (//))
import qualified Data.Vector as Vec
import Data.Word
import Language.Wasm.Interpreter hiding (Value)
import Language.Wasm.Interpreter (ModuleInstance,emptyStore,emptyImports)
import qualified Language.Wasm.Interpreter as Wasm
import Language.Wasm.Structure hiding (exports)
import Language.Wasm.Validate (ValidModule)
import Numeric.Natural (Natural)
import System.IO.Unsafe (unsafePerformIO)
-- memory instance: vec(byte) + optional max size
-- bytes are modeled as Word8
......@@ -89,7 +92,7 @@ import Numeric.Natural (Natural)
-- False -> eCont -< x
--
--instance (Arrow c, Profunctor c) => ArrowMemAddress Value Natural Word32 (WasmMemoryT c) where
-- memaddr = proc (Value (VI32 base), off) -> returnA -< (base+ (fromIntegral off))
-- memaddr = proc (Value (Wasm.VI32 base), off) -> returnA -< (base+ (fromIntegral off))
--
--instance ArrowSerialize Value (Vector Word8) ValueType LoadType StoreType (WasmMemoryT c) where
--
......@@ -100,11 +103,11 @@ import Numeric.Natural (Natural)
--
--
data WasmStore v = WasmStore {
funcInstances :: Vector (FuncInst v),
funcInstances :: Vector FuncInst,
tableInstances :: Vector TableInst,
memInstances :: Vector MemInst,
globalInstances :: Vector v
} deriving (Show)
} deriving (Show, Eq)
emptyWasmStore :: WasmStore v
emptyWasmStore = WasmStore {
......@@ -114,7 +117,7 @@ emptyWasmStore = WasmStore {
globalInstances = Vec.empty
}
data FuncInst v =
data FuncInst =
FuncInst {
funcType :: FuncType,
moduleInstance :: ModuleInstance,
......@@ -123,10 +126,10 @@ data FuncInst v =
| HostInst {
funcType :: FuncType
--hostCode :: HostFunction v c
} deriving (Show)
} deriving (Show,Eq)
data TableInst = TableInst deriving (Show)
newtype MemInst = MemInst (Vector Word8) deriving (Show)
newtype TableInst = TableInst Wasm.TableInstance deriving (Show,Eq)
newtype MemInst = MemInst (Vector Word8) deriving (Show,Eq)
newtype WasmStoreT v c x y = WasmStoreT (ReaderT Int (StateT (WasmStore v) c) x y)
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowLift,
......@@ -134,6 +137,8 @@ newtype WasmStoreT v c x y = WasmStoreT (ReaderT Int (StateT (WasmStore v) c) x
ArrowStack st)--, ArrowState (WasmStore v))
instance (ArrowReader r c) => ArrowReader r (WasmStoreT v c) where
ask = lift' ask
local a = lift $ lmap shuffle1 (local (unlift a))
instance (ArrowState s c) => ArrowState s (WasmStoreT v c) where
......@@ -187,7 +192,7 @@ instance (ArrowChoice c, Profunctor c) => ArrowMemory Word32 (Vector Word8) (Was
False -> eCont -< x
instance (Arrow c, Profunctor c) => ArrowMemAddress Value Natural Word32 (WasmStoreT v c) where
memaddr = proc (Value (VI32 base), off) -> returnA -< (base+ (fromIntegral off))
memaddr = proc (Value (Wasm.VI32 base), off) -> returnA -< (base+ (fromIntegral off))
instance ArrowSerialize Value (Vector Word8) ValueType LoadType StoreType (WasmStoreT v c) where
......@@ -203,21 +208,39 @@ newtype Value = Value Wasm.Value deriving (Show, Eq)
instance (ArrowChoice c) => IsVal Value (ValueT Value c) where
i32const = proc w32 -> returnA -< Value $ VI32 w32
i64const = proc w64 -> returnA -< Value $ VI64 w64
i32const = proc w32 -> returnA -< Value $ Wasm.VI32 w32
i64const = proc w64 -> returnA -< Value $ Wasm.VI64 w64
iBinOp = proc (bs,op,Value v1,Value v2) ->
case bs of
BS32 -> do
case op of
IAdd -> returnA -< Just $ Value $ addVal v1 v2
iRelOp = proc (bs,op,Value v1, Value v2) ->
case bs of
BS32 -> do
case op of
IEq -> returnA -< Value $ if v1 == v2 then (Wasm.VI32 1) else (Wasm.VI32 0)
BS64 -> do
case op of
IEq -> returnA -< Value $ if v1 == v2 then (Wasm.VI32 1) else (Wasm.VI32 0)
i32ifNeqz f g = proc (v, x) -> do
case v of
Value (VI32 0) -> g -< x
Value (VI32 _) -> f -< x
Value (Wasm.VI32 0) -> g -< x
Value (Wasm.VI32 _) -> f -< x
_ -> returnA -< error "validation failure"
ifHasType f g = proc (v,t,x) -> do
case (v,t) of
(Value (Wasm.VI32 _), I32) -> f -< x
(Value (Wasm.VI64 _), I64) -> f -< x
(Value (Wasm.VF32 _), F32) -> f -< x
(Value (Wasm.VF64 _), F64) -> f -< x
_ -> g -< x
addVal :: Wasm.Value -> Wasm.Value -> Wasm.Value
addVal (VI32 v1) (VI32 v2) = VI32 $ v1 + v2
addVal (Wasm.VI32 v1) (Wasm.VI32 v2) = Wasm.VI32 $ v1 + v2
evalNumericInst :: (Instruction Natural) -> [Value] -> Error (Exc Value) Value
......@@ -279,8 +302,7 @@ invokeExported :: WasmStore Value
-> [Value]
-> Error
[Char]
([Value],
Error (Exc Value) (Vector Value, (WasmStore Value, [Value])))
(Error (Exc Value) ([Value],(Vector Value, (WasmStore Value, [Value]))))
invokeExported store modInst funcName args =
let ?fixpointAlgorithm = Function.fix in
Trans.run
......@@ -289,7 +311,30 @@ invokeExported store modInst funcName args =
(WasmStoreT Value
(FrameT FrameData Value
(ReaderT Generic.Read
(ExceptT (Generic.Exc Value)
(StackT Value
(StackT Value
(ExceptT (Generic.Exc Value)
(FailureT String
(->))))))) (Text, [Value]) [Value]) ([],(Generic.Read [],(Vec.empty,((0,modInst),(store,(0,(funcName,args)))))))
instantiate :: ValidModule -> IO (Either String (ModuleInstance, WasmStore Value))
instantiate valMod = do
res <- Wasm.instantiate emptyStore emptyImports valMod
case res of
Right (modInst, store) -> return $ Right $ (modInst, storeToWasmStore store)
Left e -> return $ Left e
where
storeToWasmStore (Wasm.Store funcI tableI memI globalI) =
WasmStore (Vec.map convertFuncs funcI)
(Vec.map TableInst tableI)
(Vec.map convertMem memI)
(convertGlobals globalI)
convertFuncs (Wasm.FunctionInstance t m c) = FuncInst t m c
convertFuncs (Wasm.HostInstance t _) = HostInst t
convertMem (Wasm.MemoryInstance _ _) = MemInst Vec.empty -- TODO
convertGlobals _ = Vec.empty -- TODO
deriving instance Show Wasm.TableInstance
deriving instance Eq Wasm.TableInstance
......@@ -26,6 +26,7 @@ import Control.Arrow.Transformer.State
import Control.Arrow.Transformer.Reader
import Control.Arrow.Transformer.Value
import Data.Monoidal (shuffle1)
import Data.Profunctor
import Data.Coerce
import Data.Vector
......@@ -58,6 +59,9 @@ instance (Profunctor c, Arrow c, ArrowFrame fd v c) => ArrowFrame fd v (StateT v
frameUpdate = lift' frameUpdate
instance (Profunctor c, Arrow c, ArrowFrame fd v c) => ArrowFrame fd v (ReaderT r c) where
inNewFrame (ReaderT a) = ReaderT $ shuffle (inNewFrame a)
where shuffle arr = proc (r, (fd, v, x)) -> arr -< (fd, v, (r,x))
frameData = lift' frameData
frameLookup = lift' frameLookup
frameUpdate = lift' frameUpdate
......@@ -71,6 +75,7 @@ newtype FrameT fd v c x y = FrameT (ReaderT fd (StateT (Vector v) c) x y)
instance (ArrowReader r c) => ArrowReader r (FrameT fd v c) where
-- ask :: (FrameT fd v c) () r
ask = FrameT (ReaderT $ proc (fd, ()) -> ask -< ())
local a = lift $ lmap shuffle1 (local (unlift a))
instance (ArrowChoice c, Profunctor c) => ArrowFrame fd v (FrameT fd v c) where
inNewFrame (FrameT (ReaderT f)) =
......
......@@ -315,6 +315,7 @@ invokeChecked eval' = proc (addr, ftExpect) ->
then f -< x
else throw -< Trap $ printf "Mismatched function type in indirect call. Expected %s, actual %s." (show ftExpect) (show ftActual)
-- TODO: we need to catch CallReturn
invoke ::
( ArrowChoice c, ArrowStack v c, ArrowReader Read c,
IsVal v c, ArrowFrame FrameData v c, ArrowExcept (Exc v) c, Exc.Join y c)
......@@ -323,7 +324,8 @@ invoke eval' = proc (FuncType paramTys resultTys, funcModInst, Function _ localT
vs <- popn -< fromIntegral $ length paramTys
zeros <- Arr.map initLocal -< localTys
let rtLength = fromIntegral $ length resultTys
inNewFrame (localNoLabels $ localFreshStack $ label eval' eval') -< ((rtLength, funcModInst), vs ++ zeros, (resultTys, code, []))
-- TODO: removed localFreshStack, not sure if that is what we want
inNewFrame (localNoLabels $ label eval' eval') -< ((rtLength, funcModInst), vs ++ zeros, (resultTys, code, []))
where
initLocal :: (ArrowChoice c, IsVal v c) => c ValueType v
initLocal = proc ty -> case ty of
......@@ -576,11 +578,13 @@ isControlInst i = case i of
Return -> True
Call _ -> True
CallIndirect _ -> True
_ -> False
isParametricInst :: Instruction index -> Bool
isParametricInst i = case i of
Drop -> True
Select -> True
_ -> False
isMemoryInst :: Instruction index -> Bool
isMemoryInst i = case i of
......
......@@ -5,6 +5,7 @@ import GenericInterpreter(Exc(..))
import qualified Data.ByteString.Lazy as LBS
import Data.Concrete.Error
import Data.Text.Lazy (pack)
import Data.Vector(fromList,empty)
import Language.Wasm
......@@ -54,6 +55,24 @@ spec = do
let stack = map (Value . Wasm.VI32) [0,1,2]
(fst $ evalParametricInst inst stack) `shouldBe` [Value $ Wasm.VI32 1]
it "run noop" $ do
let path = "test/samples/simple.wast"
content <- LBS.readFile path
let Right m = parse content
let Right validMod = validate m
Right (modInst, store) <- instantiate validMod
let (Success (Success (_,(_,(_,result))))) = invokeExported store modInst (pack "noop") []
result `shouldBe` [Value $ Wasm.VI32 0]
it "run fact" $ do
let path = "test/samples/fact.wast"
content <- LBS.readFile path
let Right m = parse content
let Right validMod = validate m
Right (modInst, store) <- instantiate validMod
let (Success (Success (_,(_,(_,result))))) = invokeExported store modInst (pack "fac-rec") [Value $ Wasm.VI64 0]
result `shouldBe` [Value $ Wasm.VI64 1]
--(length inst) `shouldBe` 0
-- let path = "test/samples/fact.wast"
-- it "parsing of webassembly module" $ do
......
(module
;; Recursive factorial
(func (export "const") (param i32) (result i32)
(get_local 0)
)
(func (export "noop") (result i32)
(i32.const 0)
)
)
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment