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

Tests for reading and writing into memory

parent f877a477
Pipeline #102519 passed with stages
in 74 minutes and 55 seconds
......@@ -46,3 +46,8 @@ data GlobInst v = GlobInst Mut v deriving (Show, Eq)
deriving instance Show Wasm.TableInstance
deriving instance Eq Wasm.TableInstance
data LoadType = L_I32 | L_I64 | L_F32 | L_F64 | L_I8S | L_I8U | L_I16S | L_I16U | L_I32S | L_I32U
deriving Show
data StoreType = S_I32 | S_I64 | S_F32 | S_F64 | S_I8 | S_I16
deriving Show
......@@ -27,6 +27,7 @@ import Control.Arrow.Transformer.Value
import Control.Arrow.Transformer.Concrete.Failure
import Control.Arrow.Transformer.Concrete.Except
import Control.Arrow.Transformer.Concrete.GlobalState
import Control.Arrow.Transformer.Concrete.Serialize
import Control.Arrow.Transformer.Concrete.WasmFrame
import Data.Concrete.Error
......@@ -207,10 +208,11 @@ invokeExported store modInst funcName args =
(DebuggableStackT Value
(ExceptT (Generic.Exc Value)
(GlobalStateT Value
(FrameT FrameData Value
(FailureT String
(LoggerT String
(->)))))))) (Text, [Value]) [Value]) ([],(Vec.empty,((0,modInst),(store,([],(Generic.LabelArities [],(funcName,args)))))))
(SerializeT
(FrameT FrameData Value
(FailureT String
(LoggerT String
(->))))))))) (Text, [Value]) [Value]) ([],(Vec.empty,((0,modInst),(store,([],(Generic.LabelArities [],(funcName,args)))))))
instantiate :: ValidModule -> IO (Either String (ModuleInstance, GlobalState Value))
......
......@@ -85,6 +85,8 @@ instance (Profunctor c, Arrow c, ArrowGlobalState v m c) => ArrowGlobalState v m
-- proc (s, (i,x)) -> do
-- y <- func ((proc (f,(s2,x)) -> arr -< (s2, (f,x))) >>^ snd) -< (s,(i,x))
-- returnA -< (s,y)
fetchMemory = lift' fetchMemory
storeMemory = lift' storeMemory
--foo2 :: (c (f,x) y -> c (Int,x) y) -> c (s, (f,x)) (s,y) -> c (s, (Int,x)) (s,y)
--foo2 func arr = proc (s, (i,x)) -> do
......
......@@ -5,6 +5,9 @@
module Control.Arrow.MemAddress where
import Control.Arrow
import Control.Arrow.Trans
import Control.Arrow.Transformer.Concrete.Except
import Control.Arrow.Transformer.Kleisli
import Control.Arrow.Transformer.Reader
......@@ -13,17 +16,19 @@ import Control.Arrow.Transformer.State
import Control.Arrow.Transformer.Value
import Control.Arrow.Transformer.Writer
import Data.Profunctor
class ArrowMemAddress base off addr c where
memaddr :: c (base, off) addr
deriving instance (ArrowMemAddress base off addr c) => ArrowMemAddress base off addr (ValueT val2 c)
deriving instance (ArrowMemAddress base off addr c) => ArrowMemAddress base off addr (ExceptT e c)
instance (ArrowMemAddress base off addr c) => ArrowMemAddress base off addr (KleisliT f c) where
-- TODO
deriving instance (ArrowMemAddress base off addr c) => ArrowMemAddress base off addr (StackT v c)
instance (ArrowMemAddress base off addr c) => ArrowMemAddress base off addr (StateT s c) where
-- TODO
instance (ArrowMemAddress base off addr c) => ArrowMemAddress base off addr (ReaderT r c) where
-- TODO
instance (ArrowMemAddress base off addr c) => ArrowMemAddress base off addr (WriterT w c) where
-- TODO
deriving instance (Arrow c, Profunctor c, ArrowMemAddress base off addr c) => ArrowMemAddress base off addr (ExceptT e c)
instance (Monad f, Arrow c, Profunctor c, ArrowMemAddress base off addr c) => ArrowMemAddress base off addr (KleisliT f c) where
memaddr = lift' memaddr
deriving instance (Arrow c, Profunctor c, ArrowMemAddress base off addr c) => ArrowMemAddress base off addr (StackT v c)
instance (Arrow c, Profunctor c, ArrowMemAddress base off addr c) => ArrowMemAddress base off addr (StateT s c) where
memaddr = lift' memaddr
instance (Arrow c, Profunctor c, ArrowMemAddress base off addr c) => ArrowMemAddress base off addr (ReaderT r c) where
memaddr = lift' memaddr
instance (Monoid w, Arrow c, Profunctor c, ArrowMemAddress base off addr c) => ArrowMemAddress base off addr (WriterT w c) where
memaddr = lift' memaddr
......@@ -72,7 +72,12 @@ instance (Arrow c, ArrowMemory m addr bytes c) => ArrowMemory m addr bytes (Stat
(newM, (newS,y)) <- memstore (unlift a1) (unlift a2) -< (m, (addr,bytes,(s,x)))
returnA -< (newS, (newM, y))
instance (ArrowMemory m addr bytes c) => ArrowMemory m addr bytes (ReaderT r c) where
-- TODO
instance (Arrow c, ArrowMemory m addr bytes c) => ArrowMemory m addr bytes (ReaderT r c) where
memread a1 a2 = lift $ proc (r, (m, (addr,i,x))) ->
memread (proc (bytes, (r,x)) -> unlift a1 -< (r, (bytes,x)))
(unlift a2)
-< (m, (addr,i,(r,x)))
memstore a1 a2 = lift $ proc (r, (m, (addr,bytes,x))) ->
memstore (unlift a1) (unlift a2) -< (m, (addr, bytes, (r,x)))
instance (ArrowMemory m addr bytes c) => ArrowMemory m addr bytes (WriterT r c) where
-- TODO
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
......@@ -6,6 +7,9 @@
module Control.Arrow.Serialize where
import Control.Arrow
import Control.Arrow.Trans
import Control.Arrow.Transformer.Concrete.Except
import Control.Arrow.Transformer.Kleisli
import Control.Arrow.Transformer.Reader
......@@ -15,17 +19,39 @@ import Control.Arrow.Transformer.Value
import Control.Arrow.Transformer.Writer
class ArrowSerialize val dat valTy datDecTy datEncTy c | c -> datDecTy, c -> datEncTy where
decode :: c (val, x) y -> c x y -> c (dat, datdecTy, valTy, x) y
decode :: c (val, x) y -> c x y -> c (dat, datDecTy, valTy, x) y
encode :: c (dat, x) y -> c x y -> c (val, valTy, datEncTy, x) y
deriving instance (ArrowSerialize val dat valTy datDecTy datEncTy c) => ArrowSerialize val dat valTy datDecTy datEncTy (ValueT val2 c)
deriving instance (ArrowSerialize val dat valTy datDecTy datEncTy c) => ArrowSerialize val dat valTy datDecTy datEncTy (ExceptT e c)
instance (ArrowSerialize val dat valTy datDecTy datEncTy c) => ArrowSerialize val dat valTy datDecTy datEncTy (KleisliT f c) where
-- TODO
deriving instance (ArrowSerialize val dat valTy datDecTy datEncTy c) => ArrowSerialize val dat valTy datDecTy datEncTy (StackT v c)
instance (ArrowSerialize val dat valTy datDecTy datEncTy c) => ArrowSerialize val dat valTy datDecTy datEncTy (StateT s c) where
-- TODO
instance (ArrowSerialize val dat valTy datDecTy datEncTy c) => ArrowSerialize val dat valTy datDecTy datEncTy (ReaderT r c) where
-- TODO
decode a1 a2 = lift $
(decode (unlift a1) (unlift a2))
encode a1 a2 = lift $
(encode (unlift a1) (unlift a2))
deriving instance (Arrow c, ArrowSerialize val dat valTy datDecTy datEncTy c) => ArrowSerialize val dat valTy datDecTy datEncTy (StackT v c)
instance (Arrow c, ArrowSerialize val dat valTy datDecTy datEncTy c) => ArrowSerialize val dat valTy datDecTy datEncTy (StateT s c) where
decode a1 a2 = lift $ proc (s, (dat, datdecTy, valTy, x)) ->
decode (proc (val, (s,x)) -> (unlift a1) -< (s, (val,x)))
(unlift a2)
-< (dat, datdecTy, valTy, (s,x))
encode a1 a2 = lift $ proc (s, (val, valTy, datEncTy, x)) ->
encode (proc (dat, (s,x)) -> (unlift a1) -< (s, (dat,x)))
(unlift a2)
-< (val, valTy, datEncTy, (s,x))
instance (Arrow c, ArrowSerialize val dat valTy datDecTy datEncTy c) => ArrowSerialize val dat valTy datDecTy datEncTy (ReaderT r c) where
-- c1 :: c (r, (val, x)) y
-- c2 :: c (r, x) y
decode a1 a2 = lift $ proc (r, (dat, datdecTy, valTy, x)) -> do
decode (proc (val, (r,x)) -> (unlift a1) -< (r, (val,x)))
(unlift a2)
-< (dat, datdecTy, valTy, (r,x))
encode a1 a2 = lift $ proc (r, (val, valTy, datEncTy, x)) ->
encode (proc (dat, (r,x)) -> (unlift a1) -< (r, (dat,x)))
(unlift a2)
-< (val, valTy, datEncTy, (r,x))
instance (ArrowSerialize val dat valTy datDecTy datEncTy c) => ArrowSerialize val dat valTy datDecTy datEncTy (WriterT w c) where
-- TODO
......@@ -2,6 +2,7 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
......@@ -30,6 +31,7 @@ import Control.Arrow.Transformer.State
import Control.Category
import Data.Bits (Bits, (.&.), shiftR, shiftL)
import Data.Monoidal (shuffle1)
import Data.Profunctor
import Data.Vector (Vector, (!), (//))
......@@ -42,13 +44,13 @@ import Language.Wasm.Structure hiding (exports, Const)
import Numeric.Natural (Natural)
import GenericInterpreter (LoadType,StoreType)
--import GenericInterpreter (LoadType,StoreType)
import Concrete
newtype GlobalStateT v c x y = GlobalStateT (StateT (GlobalState v) c x y)
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowLift,
ArrowFail e, ArrowExcept e, ArrowConst r, ArrowStore var' val', ArrowRun, ArrowFrame fd val,
ArrowStack st, ArrowLogger l)--, ArrowState (GlobalState v))
ArrowStack st, ArrowLogger l, ArrowSerialize val dat valTy datDecTy datEncTy)--, ArrowState (GlobalState v))
instance (ArrowReader r c) => ArrowReader r (GlobalStateT v c) where
ask = lift' ask
......@@ -122,8 +124,6 @@ instance (ArrowChoice c, Profunctor c) => ArrowMemory Int Word32 (Vector Word8)
instance (Arrow c, Profunctor c) => ArrowMemAddress Value Natural Word32 (GlobalStateT v c) where
memaddr = proc (Value (Wasm.VI32 base), off) -> returnA -< (base+ (fromIntegral off))
instance ArrowSerialize v (Vector Word8) ValueType LoadType StoreType (GlobalStateT v c) where
instance ArrowMemSizable v (GlobalStateT v c) where
......
......@@ -42,7 +42,7 @@ import Language.Wasm.Structure hiding (exports, Const)
import Numeric.Natural (Natural)
import GenericInterpreter (LoadType,StoreType)
--import GenericInterpreter (LoadType,StoreType)
import Concrete
newtype GlobalState2T v c x y = GlobalState2T (StateT (GlobalState v) c x y)
......
......@@ -39,7 +39,7 @@ newtype MemoryT c x y = MemoryT (c x y)
instance ArrowTrans MemoryT where
-- lift' :: c x y -> MemoryT v c x y
lift' a = MemoryT a
lift' = MemoryT
instance (ArrowChoice c, Profunctor c) => ArrowMemory MemInst Word32 (Vector Word8) (MemoryT c) where
memread (MemoryT sCont) (MemoryT eCont) = MemoryT $ proc (m@(MemInst _ vec), (addr, size, x)) -> do
......
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Arrow.Transformer.Concrete.Serialize where
import Concrete
import Control.Arrow
import Control.Arrow.Const
import Control.Arrow.Except
import Control.Arrow.Fail
import Control.Arrow.Fix
import Control.Arrow.GlobalState
import Control.Arrow.Logger
import Control.Arrow.Memory
import Control.Arrow.Reader
import Control.Arrow.Serialize
import Control.Arrow.Stack
import Control.Arrow.State
import Control.Arrow.Store
import Control.Arrow.Trans
import Control.Arrow.WasmFrame
import Control.Category
import Data.Bits (Bits, (.&.), shiftR, shiftL)
import Data.Profunctor
import Data.Vector (Vector)
import qualified Data.Vector as Vec
import Data.Word
import qualified Language.Wasm.Interpreter as Wasm
import Language.Wasm.Structure hiding (exports, Const)
newtype SerializeT c x y = SerializeT (c x y)
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowLift,
ArrowFail e, ArrowExcept e, ArrowConst r, ArrowStore var' val', ArrowRun, ArrowFrame fd val,
ArrowStack st, ArrowLogger l, ArrowState s, ArrowGlobalState v m, ArrowReader m)
instance (Profunctor c, ArrowChoice c) => ArrowSerialize Value (Vector Word8) ValueType LoadType StoreType (SerializeT c) where
decode sCont eCont = proc (dat, decTy, valTy, x) -> do
case (valTy,decTy) of
(I32,L_I32) -> do
let val = Vec.foldr (\w8 w32 -> (w32 `shiftL` 4) + (fromIntegral w8)) (fromIntegral $ Vec.last dat) dat
let result = Value $ Wasm.VI32 val
sCont -< (result, x)
encode sCont eCont = proc (Value val, valTy, datEncTy, x) -> do
case (val, valTy, datEncTy) of
(Wasm.VI32 v, I32, S_I32) -> do
let vec = Vec.generate 4 (byte v)
sCont -< (vec, x)
where byte :: (Integral i, Bits i) => i -> Int -> Word8
byte v i = fromIntegral $ (v `shiftR` (i*8)) .&. 0xFF
instance ArrowTrans SerializeT where
lift' = SerializeT
instance (ArrowLift c, ArrowFix (Underlying (SerializeT c) x y)) => ArrowFix (SerializeT c x y) where
type Fix (SerializeT c x y) = Fix (Underlying (SerializeT c) x y)
......@@ -15,6 +15,8 @@ module GenericInterpreter where
import Prelude hiding (Read, fail, log)
import Concrete
import Control.Arrow
import Control.Arrow.DebuggableStack
import Control.Arrow.Except
......@@ -82,11 +84,6 @@ withMemoryInstance f = proc (i,x) -> do
data LoadType = L_I32 | L_I64 | L_F32 | L_F64 | L_I8S | L_I8U | L_I16S | L_I16U | L_I32S | L_I32U
deriving Show
data StoreType = S_I32 | S_I64 | S_F32 | S_F64 | S_I8 | S_I16
deriving Show
class Show v => IsVal v c | c -> v where
i32const :: c Word32 v
i64const :: c Word64 v
......
......@@ -127,3 +127,12 @@ spec = do
-- isInfixOf "readFunction" x ||
-- isInfixOf "invoke" x)) ls)
-- putStrLn ""
it "run test-mem" $ 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 "test-mem") [Value $ Wasm.VI32 42]
result `shouldBe` [Value $ Wasm.VI32 43]
(module
(memory 1)
;; Recursive factorial
(func (export "const") (param i32) (result i32)
(get_local 0)
......@@ -6,7 +7,7 @@
(func (export "noop") (result i32)
(i32.const 0)
)
)
(func (export "half-fac") (param i32) (result i32)
(if (result i32) (i32.eq (get_local 0) (i32.const 0))
......@@ -17,4 +18,14 @@
(if (result i64) (i64.eq (get_local 0) (i64.const 0))
(then (i64.const 1))
(else (i64.const 0))))
)
(func (export "test-mem") (param i32) (result i32)
i32.const 0
get_local 0
i32.store
i32.const 0
i32.load
i32.const 1
i32.add
))
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