Commit 51993d89 authored by Katharina Brandl's avatar Katharina Brandl
Browse files

Redesign of Memory and GlobalState interface

parent 28e80883
Pipeline #100753 passed with stages
in 72 minutes and 49 seconds
...@@ -150,14 +150,14 @@ evalNumericInst inst stack = ...@@ -150,14 +150,14 @@ evalNumericInst inst stack =
--type TransStack = FrameT FrameData Value (StackT Value (->)) --type TransStack = FrameT FrameData Value (StackT Value (->))
-- --
evalVariableInst :: (Instruction Natural) -> [Value] -> FrameData -> Vector Value evalVariableInst :: (Instruction Natural) -> [Value] -> FrameData -> Vector Value
-> GlobalState Value -> Int -> ([Value], (Vector Value, (GlobalState Value, ()))) -> GlobalState Value -> ([Value], (Vector Value, (GlobalState Value, ())))
evalVariableInst inst stack fd locals store currentMem = evalVariableInst inst stack fd locals store =
Trans.run Trans.run
(Generic.evalVariableInst :: (Generic.evalVariableInst ::
GlobalStateT Value GlobalStateT Value
(FrameT FrameData Value (FrameT FrameData Value
(StackT Value (StackT Value
(->))) (Instruction Natural) ()) (stack, (locals, (fd,(store, (currentMem,inst))))) (->))) (Instruction Natural) ()) (stack, (locals, (fd,(store, inst))))
evalParametricInst :: (Instruction Natural) -> [Value] -> ([Value], ()) evalParametricInst :: (Instruction Natural) -> [Value] -> ([Value], ())
...@@ -210,7 +210,7 @@ invokeExported store modInst funcName args = ...@@ -210,7 +210,7 @@ invokeExported store modInst funcName args =
(FrameT FrameData Value (FrameT FrameData Value
(FailureT String (FailureT String
(LoggerT String (LoggerT String
(->)))))))) (Text, [Value]) [Value]) ([],(Vec.empty,((0,modInst),(store,(0,([],(Generic.LabelArities [],(funcName,args)))))))) (->)))))))) (Text, [Value]) [Value]) ([],(Vec.empty,((0,modInst),(store,([],(Generic.LabelArities [],(funcName,args)))))))
instantiate :: ValidModule -> IO (Either String (ModuleInstance, GlobalState Value)) instantiate :: ValidModule -> IO (Either String (ModuleInstance, GlobalState Value))
......
...@@ -26,7 +26,7 @@ import Language.Wasm.Interpreter (ModuleInstance(..)) ...@@ -26,7 +26,7 @@ import Language.Wasm.Interpreter (ModuleInstance(..))
class ArrowGlobalState v c | c -> v where class ArrowGlobalState v m c | c -> v, c -> m where
-- | Reads a global variable. Cannot fail due to validation. -- | Reads a global variable. Cannot fail due to validation.
readGlobal :: c Int v readGlobal :: c Int v
-- | Writes a global variable. Cannot fail due to validation. -- | Writes a global variable. Cannot fail due to validation.
...@@ -44,11 +44,14 @@ class ArrowGlobalState v c | c -> v where ...@@ -44,11 +44,14 @@ class ArrowGlobalState v c | c -> v where
-- | Invokes `h (ta,ix,x)` if `ix` cell is uninitialized. -- | Invokes `h (ta,ix,x)` if `ix` cell is uninitialized.
readTable :: c (Int,x) y -> c (Int,Int,x) y -> c (Int,Int,x) y -> c (Int,Int,x) y readTable :: c (Int,x) y -> c (Int,Int,x) y -> c (Int,Int,x) y -> c (Int,Int,x) y
fetchMemory :: c Int m
storeMemory :: c (Int, m) ()
-- | Executes a function relative to a memory instance. The memory instance exists due to validation. -- | Executes a function relative to a memory instance. The memory instance exists due to validation.
withMemoryInstance :: c x y -> c (Int,x) y -- withMemoryInstance :: c x y -> c (Int,x) y
deriving instance (ArrowGlobalState v c) => ArrowGlobalState v (ValueT v2 c) deriving instance (ArrowGlobalState v m c) => ArrowGlobalState v m (ValueT v2 c)
instance (Profunctor c, Arrow c, ArrowGlobalState v c) => ArrowGlobalState v (StateT s c) where instance (Profunctor c, Arrow c, ArrowGlobalState v m c) => ArrowGlobalState v m (StateT s c) where
readGlobal = lift' readGlobal readGlobal = lift' readGlobal
writeGlobal = lift' writeGlobal writeGlobal = lift' writeGlobal
-- readFunction :: (StateT s c) (f, x) y -> (StateT s c) (Int, x) y -- readFunction :: (StateT s c) (f, x) y -> (StateT s c) (Int, x) y
...@@ -97,13 +100,13 @@ instance (Profunctor c, Arrow c, ArrowGlobalState v c) => ArrowGlobalState v (St ...@@ -97,13 +100,13 @@ instance (Profunctor c, Arrow c, ArrowGlobalState v c) => ArrowGlobalState v (St
-- y <- func ((proc (f,(s2,x)) -> arr -< (s2, (f,x))) >>^ snd) -< (i,(s,x)) -- y <- func ((proc (f,(s2,x)) -> arr -< (s2, (f,x))) >>^ snd) -< (i,(s,x))
-- returnA -< (s,y) -- returnA -< (s,y)
deriving instance (Arrow c, Profunctor c, ArrowGlobalState v c) => ArrowGlobalState v (ExceptT e c) deriving instance (Arrow c, Profunctor c, ArrowGlobalState v m c) => ArrowGlobalState v m (ExceptT e c)
deriving instance (Arrow c, Profunctor c, ArrowGlobalState v c) => ArrowGlobalState v (StackT s c) deriving instance (Arrow c, Profunctor c, ArrowGlobalState v m c) => ArrowGlobalState v m (StackT s c)
instance (Monad f, Arrow c, Profunctor c, ArrowGlobalState v c) => ArrowGlobalState v (KleisliT f c) where instance (Monad f, Arrow c, Profunctor c, ArrowGlobalState v m c) => ArrowGlobalState v m (KleisliT f c) where
readGlobal = lift' readGlobal readGlobal = lift' readGlobal
writeGlobal = lift' writeGlobal writeGlobal = lift' writeGlobal
readFunction a = lift (readFunction (unlift a)) readFunction a = lift (readFunction (unlift a))
instance (Arrow c, Profunctor c, ArrowGlobalState v c) => ArrowGlobalState v (ReaderT r c) where instance (Arrow c, Profunctor c, ArrowGlobalState v m c) => ArrowGlobalState v m (ReaderT r c) where
readGlobal = lift' readGlobal readGlobal = lift' readGlobal
writeGlobal = lift' writeGlobal writeGlobal = lift' writeGlobal
-- unlift arr :: c (r, (f,x)) y -- unlift arr :: c (r, (f,x)) y
...@@ -114,7 +117,7 @@ instance (Arrow c, Profunctor c, ArrowGlobalState v c) => ArrowGlobalState v (Re ...@@ -114,7 +117,7 @@ instance (Arrow c, Profunctor c, ArrowGlobalState v c) => ArrowGlobalState v (Re
where transform f = proc (r, (i,x)) -> where transform f = proc (r, (i,x)) ->
readFunction (proc (f,(r,x)) -> f -< (r, (f,x))) -< (i,(r,x)) readFunction (proc (f,(r,x)) -> f -< (r, (f,x))) -< (i,(r,x))
instance (Arrow c, Profunctor c, Monoid w, ArrowGlobalState v c) => ArrowGlobalState v (WriterT w c) where instance (Arrow c, Profunctor c, Monoid w, ArrowGlobalState v m c) => ArrowGlobalState v m (WriterT w c) where
readGlobal = lift' readGlobal readGlobal = lift' readGlobal
writeGlobal = lift' writeGlobal writeGlobal = lift' writeGlobal
readFunction a = lift (readFunction (unlift a)) readFunction a = lift (readFunction (unlift a))
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
...@@ -6,6 +7,8 @@ ...@@ -6,6 +7,8 @@
module Control.Arrow.Memory where module Control.Arrow.Memory where
import Control.Arrow
import Control.Arrow.Transformer.Concrete.Except import Control.Arrow.Transformer.Concrete.Except
import Control.Arrow.Transformer.Kleisli import Control.Arrow.Transformer.Kleisli
import Control.Arrow.Transformer.Reader import Control.Arrow.Transformer.Reader
...@@ -14,18 +17,28 @@ import Control.Arrow.Transformer.State ...@@ -14,18 +17,28 @@ import Control.Arrow.Transformer.State
import Control.Arrow.Transformer.Value import Control.Arrow.Transformer.Value
import Control.Arrow.Transformer.Writer import Control.Arrow.Transformer.Writer
class ArrowMemory addr bytes c | c -> addr, c -> bytes where class ArrowMemory m addr bytes c | c -> addr, c -> bytes, c -> m where
memread :: c (bytes, x) y -> c x y -> c (addr, Int, x) y memread :: c (bytes, x) y -> c x y -> c (m, (addr, Int, x)) (m,y)
memstore :: c x y -> c x y -> c (addr, bytes, x) y memstore :: c x y -> c x y -> c (m, (addr, bytes, x)) (m,y)
-- getMemory :: c () m
-- putMemory :: c m ()
--
--withMemory :: (Arrow c, ArrowMemory m addr bytes c) => c x y -> c (m,x) (m,y)
--withMemory f = proc (m,x) -> do
-- putMemory -< m
-- y <- f -< x
-- newMem <- getMemory -< ()
-- returnA -< (m,y)
deriving instance (ArrowMemory addr bytes c) => ArrowMemory addr bytes (ValueT val2 c) deriving instance (ArrowMemory m addr bytes c) => ArrowMemory m addr bytes (ValueT val2 c)
deriving instance (ArrowMemory addr bytes c) => ArrowMemory addr bytes (ExceptT e c) deriving instance (ArrowMemory m addr bytes c) => ArrowMemory m addr bytes (ExceptT e c)
instance (ArrowMemory addr bytes c) => ArrowMemory addr bytes (KleisliT e c) where instance (ArrowMemory m addr bytes c) => ArrowMemory m addr bytes (KleisliT e c) where
-- TODO -- TODO
deriving instance (ArrowMemory addr bytes c) => ArrowMemory addr bytes (StackT e c) deriving instance (ArrowMemory m addr bytes c) => ArrowMemory m addr bytes (StackT e c)
instance (ArrowMemory addr bytes c) => ArrowMemory addr bytes (StateT s c) where instance (ArrowMemory m addr bytes c) => ArrowMemory m addr bytes (StateT s c) where
-- TODO -- TODO
instance (ArrowMemory addr bytes c) => ArrowMemory addr bytes (ReaderT r c) where instance (ArrowMemory m addr bytes c) => ArrowMemory m addr bytes (ReaderT r c) where
-- TODO -- TODO
instance (ArrowMemory addr bytes c) => ArrowMemory addr bytes (WriterT r c) where instance (ArrowMemory m addr bytes c) => ArrowMemory m addr bytes (WriterT r c) where
-- TODO -- TODO
...@@ -78,7 +78,7 @@ newtype TableInst = TableInst Wasm.TableInstance deriving (Show,Eq) ...@@ -78,7 +78,7 @@ newtype TableInst = TableInst Wasm.TableInstance deriving (Show,Eq)
data MemInst = MemInst (Maybe Word32) (Vector Word8) deriving (Show,Eq) data MemInst = MemInst (Maybe Word32) (Vector Word8) deriving (Show,Eq)
data GlobInst v = GlobInst Mut v deriving (Show, Eq) data GlobInst v = GlobInst Mut v deriving (Show, Eq)
newtype GlobalStateT v c x y = GlobalStateT (ReaderT Int (StateT (GlobalState v) c) x y) newtype GlobalStateT v c x y = GlobalStateT (StateT (GlobalState v) c x y)
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowLift, deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowLift,
ArrowFail e, ArrowExcept e, ArrowConst r, ArrowStore var' val', ArrowRun, ArrowFrame fd val, ArrowFail e, ArrowExcept e, ArrowConst r, ArrowStore var' val', ArrowRun, ArrowFrame fd val,
ArrowStack st, ArrowLogger l)--, ArrowState (GlobalState v)) ArrowStack st, ArrowLogger l)--, ArrowState (GlobalState v))
...@@ -88,12 +88,13 @@ instance (ArrowReader r c) => ArrowReader r (GlobalStateT v c) where ...@@ -88,12 +88,13 @@ instance (ArrowReader r c) => ArrowReader r (GlobalStateT v c) where
local a = lift $ lmap shuffle1 (local (unlift a)) local a = lift $ lmap shuffle1 (local (unlift a))
instance (ArrowState s c) => ArrowState s (GlobalStateT v c) where instance (ArrowState s c) => ArrowState s (GlobalStateT v c) where
-- TODO
instance ArrowTrans (GlobalStateT v) where instance ArrowTrans (GlobalStateT v) where
-- lift' :: c x y -> GlobalStateT v c x y -- lift' :: c x y -> GlobalStateT v c x y
lift' a = GlobalStateT (lift' (lift' a)) lift' a = GlobalStateT (lift' a)
instance (ArrowChoice c, Profunctor c) => ArrowGlobalState v (GlobalStateT v c) where instance (ArrowChoice c, Profunctor c) => ArrowGlobalState v Int (GlobalStateT v c) where
readGlobal = readGlobal =
GlobalStateT $ proc i -> do GlobalStateT $ proc i -> do
GlobalState{globalInstances=vec} <- get -< () GlobalState{globalInstances=vec} <- get -< ()
...@@ -116,31 +117,40 @@ instance (ArrowChoice c, Profunctor c) => ArrowGlobalState v (GlobalStateT v c) ...@@ -116,31 +117,40 @@ instance (ArrowChoice c, Profunctor c) => ArrowGlobalState v (GlobalStateT v c)
FuncInst fTy modInst code -> funcCont -< ((fTy,modInst,code),x) FuncInst fTy modInst code -> funcCont -< ((fTy,modInst,code),x)
_ -> returnA -< error "not yet implemented" --hostCont -< ((fTy,code),x) _ -> returnA -< error "not yet implemented" --hostCont -< ((fTy,code),x)
withMemoryInstance (GlobalStateT f) = GlobalStateT $ local f --withMemoryInstance (GlobalStateT f) = GlobalStateT $ local f
instance (ArrowChoice c, Profunctor c) => ArrowMemory Word32 (Vector Word8) (GlobalStateT v c) where fetchMemory = arr Prelude.id
memread (GlobalStateT sCont) (GlobalStateT eCont) = GlobalStateT $ proc (addr, size, x) -> do storeMemory = arr $ const ()
instance (ArrowChoice c, Profunctor c) => ArrowMemory Int Word32 (Vector Word8) (GlobalStateT v c) where
memread (GlobalStateT sCont) (GlobalStateT eCont) = GlobalStateT $ proc (i, (addr, size, x)) -> do
GlobalState{memInstances=mems} <- get -< () GlobalState{memInstances=mems} <- get -< ()
currMem <- ask -< () --currMem <- ask -< ()
let MemInst _ vec = mems ! currMem let MemInst _ vec = mems ! i
let addrI = fromIntegral addr let addrI = fromIntegral addr
case (addrI+size <= length vec) of case (addrI+size <= length vec) of
True -> do True -> do
let content = Vec.slice addrI size vec let content = Vec.slice addrI size vec
sCont -< (content,x) y <- sCont -< (content,x)
False -> eCont -< x returnA -< (i,y)
memstore (GlobalStateT sCont) (GlobalStateT eCont) = GlobalStateT $ proc (addr, content, x) -> do False -> do
y <- eCont -< x
returnA -< (i,y)
memstore (GlobalStateT sCont) (GlobalStateT eCont) = GlobalStateT $ proc (i, (addr, content, x)) -> do
store@GlobalState{memInstances=mems} <- get -< () store@GlobalState{memInstances=mems} <- get -< ()
currMem <- ask -< () --currMem <- ask -< ()
let MemInst s vec = mems ! currMem let MemInst s vec = mems ! i
let addrI = fromIntegral addr let addrI = fromIntegral addr
let size = length content let size = length content
case (addrI+size <= length vec) of case (addrI+size <= length vec) of
True -> do True -> do
let ind = Vec.enumFromN addrI size let ind = Vec.enumFromN addrI size
put -< (store{memInstances=mems // [(currMem,MemInst s $ Vec.update_ vec ind content)]}) put -< (store{memInstances=mems // [(i,MemInst s $ Vec.update_ vec ind content)]})
sCont -< x y <- sCont -< x
False -> eCont -< x returnA -< (i,y)
False -> do
y <- eCont -< x
returnA -< (i,y)
instance (Arrow c, Profunctor c) => ArrowMemAddress Value Natural Word32 (GlobalStateT v c) where instance (Arrow c, Profunctor c) => ArrowMemAddress Value Natural Word32 (GlobalStateT v c) where
memaddr = proc (Value (Wasm.VI32 base), off) -> returnA -< (base+ (fromIntegral off)) memaddr = proc (Value (Wasm.VI32 base), off) -> returnA -< (base+ (fromIntegral off))
......
...@@ -33,7 +33,7 @@ import Data.Profunctor ...@@ -33,7 +33,7 @@ import Data.Profunctor
newtype DebuggableStackT v c x y = DebuggableStackT (StackT v c x y) newtype DebuggableStackT v c x y = DebuggableStackT (StackT v c x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowTrans,ArrowLift,ArrowRun, deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowTrans,ArrowLift,ArrowRun,
ArrowConst r, ArrowReader r, ArrowFail e, ArrowExcept e, ArrowStack v, ArrowConst r, ArrowReader r, ArrowFail e, ArrowExcept e, ArrowStack v,
ArrowGlobalState v1 , ArrowFrame fd v1, ArrowMemory addr bytes, ArrowGlobalState v1 m, ArrowFrame fd v1, ArrowMemory m addr bytes,
ArrowMemAddress v1 n addr, ArrowSerialize v1 bytes valTy loadTy storeTy, ArrowMemAddress v1 n addr, ArrowSerialize v1 bytes valTy loadTy storeTy,
ArrowMemSizable v1, ArrowWriter w, ArrowLogger l) ArrowMemSizable v1, ArrowWriter w, ArrowLogger l)
......
...@@ -32,7 +32,7 @@ import Data.Profunctor ...@@ -32,7 +32,7 @@ import Data.Profunctor
newtype LoggerT v c x y = LoggerT (StackT v c x y) newtype LoggerT v c x y = LoggerT (StackT v c x y)
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowTrans, ArrowLift, ArrowRun, deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowTrans, ArrowLift, ArrowRun,
ArrowConst r, ArrowReader r, ArrowFail e, ArrowExcept e, ArrowConst r, ArrowReader r, ArrowFail e, ArrowExcept e,
ArrowGlobalState v1, ArrowFrame fd v1, ArrowMemory addr bytes, ArrowGlobalState v1 m, ArrowFrame fd v1, ArrowMemory m addr bytes,
ArrowMemAddress v1 n addr, ArrowSerialize v1 bytes valTy loadTy storeTy, ArrowMemAddress v1 n addr, ArrowSerialize v1 bytes valTy loadTy storeTy,
ArrowMemSizable v1, ArrowWriter w) ArrowMemSizable v1, ArrowWriter w)
......
...@@ -53,7 +53,7 @@ newtype LabelArities = LabelArities {labels :: [Natural]} ...@@ -53,7 +53,7 @@ newtype LabelArities = LabelArities {labels :: [Natural]}
type FrameData = (Natural, ModuleInstance) type FrameData = (Natural, ModuleInstance)
---- constraints to support (and call) host functions ---- constraints to support (and call) host functions
--type HostFunctionSupport addr bytes v c = (ArrowApply c, ArrowGlobalState v c, ArrowWasmMemory addr bytes v c) --type HostFunctionSupport addr bytes v c = (ArrowApply c, ArrowGlobalState v m c, ArrowWasmMemory m addr bytes v c)
---- a host function is a function from a list of values (parameters) to a list of values (return values) ---- a host function is a function from a list of values (parameters) to a list of values (return values)
--newtype HostFunction v c = HostFunction ( --newtype HostFunction v c = HostFunction (
-- forall addr bytes. HostFunctionSupport addr bytes v c => (c [v] [v]) ) -- forall addr bytes. HostFunctionSupport addr bytes v c => (c [v] [v]) )
...@@ -65,16 +65,20 @@ type FrameData = (Natural, ModuleInstance) ...@@ -65,16 +65,20 @@ type FrameData = (Natural, ModuleInstance)
type ArrowWasmMemory addr bytes v c = type ArrowWasmMemory m addr bytes v c =
( ArrowMemory addr bytes c, ( ArrowMemory m addr bytes c,
ArrowMemAddress v Natural addr c, ArrowMemAddress v Natural addr c,
ArrowSerialize v bytes ValueType LoadType StoreType c, ArrowSerialize v bytes ValueType LoadType StoreType c,
ArrowMemSizable v c, ArrowMemSizable v c,
Show addr, Show bytes) Show addr, Show bytes)
withMemoryInstance :: (Arrow c, ArrowGlobalState v m c) => c (m,x) (m,y) -> c (Int,x) y
withMemoryInstance f = proc (i,x) -> do
mem <- fetchMemory -< i
(newMem,y) <- f -< (mem,x)
storeMemory -< (i, newMem)
returnA -< y
...@@ -121,11 +125,11 @@ class Show v => IsVal v c | c -> v where ...@@ -121,11 +125,11 @@ class Show v => IsVal v c | c -> v where
-- argument Text: name of the function to execute -- argument Text: name of the function to execute
-- argument [v]: arguments going to be passed to the function -- argument [v]: arguments going to be passed to the function
invokeExported :: invokeExported ::
( ArrowChoice c, ArrowFrame FrameData v c, ArrowGlobalState v c, ( ArrowChoice c, ArrowFrame FrameData v c, ArrowGlobalState v m c,
ArrowStack v c, ArrowStack v c,
ArrowDebuggableStack v c, ArrowDebuggableStack v c,
ArrowExcept (Exc v) c, ArrowReader LabelArities c, ArrowExcept (Exc v) c, ArrowReader LabelArities c,
ArrowWasmMemory addr bytes v c, --HostFunctionSupport addr bytes v c, ArrowWasmMemory m addr bytes v c, --HostFunctionSupport addr bytes v c,
IsVal v c, Show v, IsVal v c, Show v,
Exc.Join () c, Exc.Join () c,
Fail.Join [v] c, Fail.Join [v] c,
...@@ -145,11 +149,11 @@ invokeExported = proc (funcName, args) -> do ...@@ -145,11 +149,11 @@ invokeExported = proc (funcName, args) -> do
_ -> fail -< printf "Function with name %s was not found in module's exports" (show funcName) _ -> fail -< printf "Function with name %s was not found in module's exports" (show funcName)
invokeExternal :: invokeExternal ::
( ArrowChoice c, ArrowFrame FrameData v c, ArrowGlobalState v c, ( ArrowChoice c, ArrowFrame FrameData v c, ArrowGlobalState v m c,
ArrowStack v c, ArrowStack v c,
ArrowDebuggableStack v c, ArrowDebuggableStack v c,
ArrowExcept (Exc v) c, ArrowReader LabelArities c, ArrowExcept (Exc v) c, ArrowReader LabelArities c,
ArrowWasmMemory addr bytes v c, --HostFunctionSupport addr bytes v c, ArrowWasmMemory m addr bytes v c, --HostFunctionSupport addr bytes v c,
IsVal v c, Show v, IsVal v c, Show v,
Exc.Join () c, Exc.Join () c,
Fail.Join () c, Fail.Join () c,
...@@ -195,11 +199,11 @@ invokeExternal = proc (funcAddr, args) -> ...@@ -195,11 +199,11 @@ invokeExternal = proc (funcAddr, args) ->
eval :: eval ::
( ArrowChoice c, ArrowFrame FrameData v c, ArrowGlobalState v c, ( ArrowChoice c, ArrowFrame FrameData v c, ArrowGlobalState v m c,
ArrowStack v c, ArrowStack v c,
ArrowDebuggableStack v c, ArrowDebuggableStack v c,
ArrowExcept (Exc v) c, ArrowReader LabelArities c, ArrowExcept (Exc v) c, ArrowReader LabelArities c,
ArrowWasmMemory addr bytes v c, --HostFunctionSupport addr bytes v c, ArrowWasmMemory m addr bytes v c, --HostFunctionSupport addr bytes v c,
IsVal v c, Show v, IsVal v c, Show v,
Exc.Join () c, Exc.Join () c,
ArrowFix (c [Instruction Natural] ()), ArrowFix (c [Instruction Natural] ()),
...@@ -250,7 +254,7 @@ evalControlInst :: ...@@ -250,7 +254,7 @@ evalControlInst ::
ArrowExcept (Exc v) c, ArrowExcept (Exc v) c,
ArrowReader LabelArities c, -- return arity of nested labels ArrowReader LabelArities c, -- return arity of nested labels
ArrowFrame FrameData v c, -- frame data and local variables ArrowFrame FrameData v c, -- frame data and local variables
ArrowGlobalState v c, ArrowGlobalState v m c,
ArrowLogger String c, ArrowLogger String c,
--HostFunctionSupport addr bytes v c, --HostFunctionSupport addr bytes v c,
Exc.Join () c) Exc.Join () c)
...@@ -305,7 +309,7 @@ evalControlInst eval' = proc i -> case i of ...@@ -305,7 +309,7 @@ evalControlInst eval' = proc i -> case i of
-< (tableAddr, fromIntegral ix, ftExpect) -< (tableAddr, fromIntegral ix, ftExpect)
invokeChecked :: invokeChecked ::
( ArrowChoice c, ArrowGlobalState v c, ArrowStack v c, ArrowReader LabelArities c, ( ArrowChoice c, ArrowGlobalState v m c, ArrowStack v c, ArrowReader LabelArities c,
IsVal v c, ArrowFrame FrameData v c, ArrowExcept (Exc v) c, Exc.Join () c, IsVal v c, ArrowFrame FrameData v c, ArrowExcept (Exc v) c, Exc.Join () c,
ArrowDebuggableStack v c, ArrowLogger String c) ArrowDebuggableStack v c, ArrowLogger String c)
--HostFunctionSupport addr bytes v c) --HostFunctionSupport addr bytes v c)
...@@ -434,10 +438,10 @@ evalParametricInst = proc i -> case i of ...@@ -434,10 +438,10 @@ evalParametricInst = proc i -> case i of
evalMemoryInst :: evalMemoryInst ::
( ArrowChoice c, ( ArrowChoice c,
ArrowWasmMemory addr bytes v c, ArrowWasmMemory m addr bytes v c,
ArrowGlobalState v c, ArrowFrame FrameData v c, ArrowStack v c, IsVal v c, ArrowExcept (Exc v) c) ArrowGlobalState v m c, ArrowFrame FrameData v c, ArrowStack v c, IsVal v c, ArrowExcept (Exc v) c)
=> c (Instruction Natural) () => c (Instruction Natural) ()
evalMemoryInst = withCurrentMemory $ proc i -> case i of evalMemoryInst = proc i -> case i of --withCurrentMemory $ proc (m,i) -> case i of
I32Load (MemArg off _) -> load 4 L_I32 I32 -< off I32Load (MemArg off _) -> load 4 L_I32 I32 -< off
I64Load (MemArg off _) -> load 8 L_I64 I64 -< off I64Load (MemArg off _) -> load 8 L_I64 I64 -< off
F32Load (MemArg off _) -> load 4 L_F32 F32 -< off F32Load (MemArg off _) -> load 4 L_F32 F32 -< off
...@@ -461,15 +465,15 @@ evalMemoryInst = withCurrentMemory $ proc i -> case i of ...@@ -461,15 +465,15 @@ evalMemoryInst = withCurrentMemory $ proc i -> case i of
I64Store8 (MemArg off _) -> store S_I8 I64 -< off I64Store8 (MemArg off _) -> store S_I8 I64 -< off
I64Store16 (MemArg off _) -> store S_I16 I64 -< off I64Store16 (MemArg off _) -> store S_I16 I64 -< off
I64Store32 (MemArg off _) -> store S_I32 I64 -< off I64Store32 (MemArg off _) -> store S_I32 I64 -< off
CurrentMemory -> push <<< memsize -< () -- CurrentMemory -> push <<< memsize -< ()
GrowMemory -> do -- GrowMemory -> do
n <- pop -< () -- n <- pop -< ()
memgrow -- memgrow
(push <<^ fst) -- (push <<^ fst)
(proc _ -> push <<< i32const -< 0xFFFFFFFF) -- 0xFFFFFFFF ~= -1 -- (proc _ -> push <<< i32const -< 0xFFFFFFFF) -- 0xFFFFFFFF ~= -1
-< (n, ()) -- -< (n, ())
withCurrentMemory :: (ArrowChoice c, ArrowGlobalState v c, ArrowFrame FrameData v c) => c x y -> c x y withCurrentMemory :: (ArrowChoice c, ArrowGlobalState v m c, ArrowMemory m addr bytes c, ArrowFrame FrameData v c) => c (m,x) (m,y) -> c x y
withCurrentMemory f = proc x -> do withCurrentMemory f = proc x -> do
(_,modInst) <- frameData -< () (_,modInst) <- frameData -< ()
let memAddr = memaddrs modInst ! 0 let memAddr = memaddrs modInst ! 0
...@@ -477,25 +481,25 @@ withCurrentMemory f = proc x -> do ...@@ -477,25 +481,25 @@ withCurrentMemory f = proc x -> do
load :: load ::
( ArrowChoice c, ( ArrowChoice c,
ArrowWasmMemory addr bytes v c, ArrowWasmMemory m addr bytes v c,
ArrowGlobalState v c, ArrowFrame FrameData v c, ArrowStack v c, IsVal v c, ArrowExcept (Exc v) c) ArrowGlobalState v m c, ArrowFrame FrameData v c, ArrowStack v c, IsVal v c, ArrowExcept (Exc v) c)
=> Int -> LoadType -> ValueType -> c Natural () => Int -> LoadType -> ValueType -> c Natural ()
load byteSize loadType valType = proc off -> do load byteSize loadType valType = proc off -> do
base <- pop -< () base <- pop -< ()
addr <- memaddr -< (base, off) addr <- memaddr -< (base, off)
memread withCurrentMemory (memread
(proc (bytes,_) -> (proc (bytes,_) ->
decode decode
(push <<^ fst) (push <<^ fst)
(error "decode failure") (error "decode failure")
-< (bytes, loadType, valType, ())) -< (bytes, loadType, valType, ()))
(proc addr -> throw -< Trap $ printf "Memory access out of bounds: Cannot read %d bytes at address %s in current memory" byteSize (show addr)) (proc addr -> throw -< Trap $ printf "Memory access out of bounds: Cannot read %d bytes at address %s in current memory" byteSize (show addr)))
-< (addr, byteSize, addr) -< (addr, byteSize, addr)
store :: store ::
( ArrowChoice c, ( ArrowChoice c,
ArrowWasmMemory addr bytes v c, ArrowWasmMemory m addr bytes v c,
ArrowGlobalState v c, ArrowFrame FrameData v c, ArrowStack v c, IsVal v c, ArrowExcept (Exc v) c) ArrowGlobalState v m c, ArrowFrame FrameData v c, ArrowStack v c, IsVal v c, ArrowExcept (Exc v) c)
=> StoreType -> ValueType -> c Natural () => StoreType -> ValueType -> c Natural ()
store storeType valType = proc off -> do store storeType valType = proc off -> do
v <- pop -< () v <- pop -< ()
...@@ -503,15 +507,15 @@ store storeType valType = proc off -> do ...@@ -503,15 +507,15 @@ store storeType valType = proc off -> do
(proc (bytes,off) -> do (proc (bytes,off) -> do
base <- pop -< () base <- pop -< ()
addr <- memaddr -< (base, off) addr <- memaddr -< (base, off)
memstore withCurrentMemory (memstore
(arr $ const ()) (arr $ const ())
(proc (addr,bytes) -> throw -< Trap $ printf "Memory access out of bounds: Cannot write %s at address %s in current memory" (show bytes) (show addr)) (proc (addr,bytes) -> throw -< Trap $ printf "Memory access out of bounds: Cannot write %s at address %s in current memory" (show bytes) (show addr)))
-< (addr, bytes, (addr, bytes))) -< (addr, bytes, (addr, bytes)))
(error "encode failure") (error "encode failure")
-< (v, valType, storeType, off) -< (v, valType, storeType, off)
evalVariableInst :: evalVariableInst ::
( ArrowChoice c, ArrowFrame FrameData v c, ArrowGlobalState v c, ( ArrowChoice c, ArrowFrame FrameData v c, ArrowGlobalState v m c,
ArrowStack v c) ArrowStack v c)
=> c (Instruction Natural) () => c (Instruction Natural) ()