Commit f877a477 authored by Katharina Brandl's avatar Katharina Brandl
Browse files

Separate transformers for memory and global state

parent 51993d89
Pipeline #101576 passed with stages
in 74 minutes and 49 seconds
{-# LANGUAGE StandaloneDeriving #-}
module Concrete where
import Data.Vector (Vector, (!), (//))
import qualified Data.Vector as Vec
import Data.Word
import Language.Wasm.Interpreter (ModuleInstance)
import qualified Language.Wasm.Interpreter as Wasm
import Language.Wasm.Structure hiding (exports, Const)
newtype Value = Value Wasm.Value deriving (Show, Eq)
data Mut = Const | Mutable deriving (Show, Eq)
data GlobalState v = GlobalState {
funcInstances :: Vector FuncInst,
tableInstances :: Vector TableInst,
memInstances :: Vector MemInst,
globalInstances :: Vector (GlobInst v)
} deriving (Show, Eq)
emptyGlobalState :: GlobalState v
emptyGlobalState = GlobalState {
funcInstances = Vec.empty,
tableInstances = Vec.empty,
memInstances = Vec.empty,
globalInstances = Vec.empty
}
data FuncInst =
FuncInst {
funcType :: FuncType,
moduleInstance :: ModuleInstance,
code :: Function
}
| HostInst {
funcType :: FuncType
--hostCode :: HostFunction v c
} deriving (Show,Eq)
newtype TableInst = TableInst Wasm.TableInstance deriving (Show,Eq)
data MemInst = MemInst (Maybe Word32) (Vector Word8) deriving (Show,Eq)
data GlobInst v = GlobInst Mut v deriving (Show, Eq)
deriving instance Show Wasm.TableInstance
deriving instance Eq Wasm.TableInstance
{-# LANGUAGE Arrows #-}
--{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
......@@ -12,6 +11,7 @@
module ConcreteInterpreter where
import Concrete
import GenericInterpreter hiding (eval,evalNumericInst,evalParametricInst,invokeExported,store)
import qualified GenericInterpreter as Generic
......@@ -25,9 +25,9 @@ import Control.Arrow.Transformer.Reader
import Control.Arrow.Transformer.Value
import Control.Arrow.Transformer.Concrete.Failure
import Control.Arrow.Transformer.Concrete.Frame
import Control.Arrow.Transformer.Concrete.Except
import Control.Arrow.Transformer.Concrete.GlobalState
import Control.Arrow.Transformer.Concrete.WasmFrame
import Data.Concrete.Error
......
......@@ -106,6 +106,8 @@ instance (Monad f, Arrow c, Profunctor c, ArrowGlobalState v m c) => ArrowGlobal
readGlobal = lift' readGlobal
writeGlobal = lift' writeGlobal
readFunction a = lift (readFunction (unlift a))
fetchMemory = lift' fetchMemory
storeMemory = lift' storeMemory
instance (Arrow c, Profunctor c, ArrowGlobalState v m c) => ArrowGlobalState v m (ReaderT r c) where
readGlobal = lift' readGlobal
writeGlobal = lift' writeGlobal
......@@ -116,8 +118,12 @@ instance (Arrow c, Profunctor c, ArrowGlobalState v m c) => ArrowGlobalState v m
readFunction a = lift $ transform (unlift a)
where transform f = proc (r, (i,x)) ->
readFunction (proc (f,(r,x)) -> f -< (r, (f,x))) -< (i,(r,x))
fetchMemory = lift' fetchMemory
storeMemory = lift' storeMemory
instance (Arrow c, Profunctor c, Monoid w, ArrowGlobalState v m c) => ArrowGlobalState v m (WriterT w c) where
readGlobal = lift' readGlobal
writeGlobal = lift' writeGlobal
readFunction a = lift (readFunction (unlift a))
fetchMemory = lift' fetchMemory
storeMemory = lift' storeMemory
......@@ -12,7 +12,7 @@ import Control.Arrow
import Control.Arrow.Trans
import Control.Arrow.Transformer.Concrete.Except
import Control.Arrow.Transformer.Concrete.Frame
import Control.Arrow.Transformer.Concrete.WasmFrame
import Control.Arrow.Transformer.Kleisli
import Control.Arrow.Transformer.Reader
import Control.Arrow.Transformer.Stack
......
......@@ -8,6 +8,7 @@
module Control.Arrow.Memory where
import Control.Arrow
import Control.Arrow.Trans
import Control.Arrow.Transformer.Concrete.Except
import Control.Arrow.Transformer.Kleisli
......@@ -17,6 +18,8 @@ import Control.Arrow.Transformer.State
import Control.Arrow.Transformer.Value
import Control.Arrow.Transformer.Writer
import Data.Profunctor
class ArrowMemory m addr bytes c | c -> addr, c -> bytes, c -> m where
memread :: c (bytes, x) y -> c x y -> c (m, (addr, Int, x)) (m,y)
memstore :: c x y -> c x y -> c (m, (addr, bytes, x)) (m,y)
......@@ -32,12 +35,43 @@ class ArrowMemory m addr bytes c | c -> addr, c -> bytes, c -> m where
-- returnA -< (m,y)
deriving instance (ArrowMemory m addr bytes c) => ArrowMemory m addr bytes (ValueT val2 c)
deriving instance (ArrowMemory m addr bytes c) => ArrowMemory m addr bytes (ExceptT e c)
instance (ArrowMemory m addr bytes c) => ArrowMemory m addr bytes (KleisliT e c) where
-- TODO
deriving instance (ArrowMemory m addr bytes c) => ArrowMemory m addr bytes (StackT e c)
instance (ArrowMemory m addr bytes c) => ArrowMemory m addr bytes (StateT s c) where
-- TODO
deriving instance (Arrow c, Profunctor c, ArrowMemory m addr bytes c) => ArrowMemory m addr bytes (ExceptT e c)
instance (Arrow c, Profunctor c, Functor f, ArrowMemory m addr bytes c) => ArrowMemory m addr bytes (KleisliT f c) where
-- a1 :: KleisliT e c (bytes,x) y, a2 :: KleisliT e c x y
-- c1 :: c (bytes,x) (e y), c2 :: c x (e y)
-- memread :: c (bytes, x) y -> c x y -> c (m, (addr, Int, x)) (m,y)
-- we need c (m, (addr, Int, x)) (m, y)
memread a1 a2 = lift $
-- lift :: c x (e y) -> KleisliT e c x y
(memread (unlift a1) (unlift a2)) >>^ moveIn -- :: c (m, (addr, Int, x)) (e (m,y))
-- moveIn :: (m, (e y)) -> (e (m,y))
where moveIn (m, ey) = fmap ((,) m) ey
memstore a1 a2 = lift $
(memstore (unlift a1) (unlift a2)) >>^ moveIn
where moveIn (m, ey) = fmap ((,) m) ey
deriving instance (Arrow c, ArrowMemory m addr bytes c) => ArrowMemory m addr bytes (StackT e c)
instance (Arrow c, ArrowMemory m addr bytes c) => ArrowMemory m addr bytes (StateT s c) where
-- a1 :: StateT s c (bytes,x) y, a2 :: StateT s c x y
-- c1 :: c (s, (bytes,x)) (s,y), c2 :: c (s,x) (s,y)
-- memread :: c (bytes,x) y -> c x y -> c (m, (addr, Int, x)) (m,y)
-- memread on StateT :: StateT s c (bytes,x) y -> StateT s c x y -> StateT s c (m,(addr,Int,x)) (m,y)
-- StateT s c (m,(addr,bytes,x)) (m,y) has the form
-- StateT $ c (s,(m,(addr,Int,x))) (s,(m,y))
-- we need c (s, (m, (addr,Int,x))) (s, (m,y))
memread a1 a2 = lift $ proc (s, (m, (addr,i,x))) -> do
-- memread :: c (bytes,x) y -> c x y -> c (m, (addr, Int, x)) (m,y)
-- memread :: c (bytes,(s,x)) (s,y) -> c (s,x) (s,y) -> c (m, (addr, Int, (s,x))) (m, (s,y))
(newM, (newS,y)) <- memread (proc (bytes,(s,x)) -> unlift a1 -< (s, (bytes,x)))
(unlift a2)
-< (m, (addr,i,(s,x)))
returnA -< (newS, (newM, y))
memstore a1 a2 = lift $ proc (s, (m, (addr,bytes,x))) -> do
(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 (ArrowMemory m addr bytes c) => ArrowMemory m addr bytes (WriterT r c) where
......
......@@ -3,7 +3,6 @@
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Arrow.Transformer.Concrete.GlobalState where
......@@ -14,7 +13,6 @@ import Control.Arrow.Logger
import Control.Arrow.Except
import Control.Arrow.Fail
import Control.Arrow.Fix
import Control.Arrow.Frame
import Control.Arrow.MemAddress
import Control.Arrow.Memory
import Control.Arrow.MemSizable
......@@ -25,6 +23,7 @@ import Control.Arrow.State
import Control.Arrow.Store
import Control.Arrow.Trans
import Control.Arrow.GlobalState
import Control.Arrow.WasmFrame
import Control.Arrow.Transformer.Reader
import Control.Arrow.Transformer.State
......@@ -44,39 +43,7 @@ import Language.Wasm.Structure hiding (exports, Const)
import Numeric.Natural (Natural)
import GenericInterpreter (LoadType,StoreType)
newtype Value = Value Wasm.Value deriving (Show, Eq)
data Mut = Const | Mutable deriving (Show, Eq)
data GlobalState v = GlobalState {
funcInstances :: Vector FuncInst,
tableInstances :: Vector TableInst,
memInstances :: Vector MemInst,
globalInstances :: Vector (GlobInst v)
} deriving (Show, Eq)
emptyGlobalState :: GlobalState v
emptyGlobalState = GlobalState {
funcInstances = Vec.empty,
tableInstances = Vec.empty,
memInstances = Vec.empty,
globalInstances = Vec.empty
}
data FuncInst =
FuncInst {
funcType :: FuncType,
moduleInstance :: ModuleInstance,
code :: Function
}
| HostInst {
funcType :: FuncType
--hostCode :: HostFunction v c
} deriving (Show,Eq)
newtype TableInst = TableInst Wasm.TableInstance deriving (Show,Eq)
data MemInst = MemInst (Maybe Word32) (Vector Word8) deriving (Show,Eq)
data GlobInst v = GlobInst Mut v deriving (Show, Eq)
import Concrete
newtype GlobalStateT v c x y = GlobalStateT (StateT (GlobalState v) c x y)
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowLift,
......@@ -164,6 +131,3 @@ instance ArrowMemSizable v (GlobalStateT v c) where
instance ArrowFix (Underlying (GlobalStateT v c) x y) => ArrowFix (GlobalStateT v c x y) where
type Fix (GlobalStateT v c x y) = Fix (Underlying (GlobalStateT v c) x y)
deriving instance Show Wasm.TableInstance
deriving instance Eq Wasm.TableInstance
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Arrow.Transformer.Concrete.GlobalState2 where
import Control.Arrow
import Control.Arrow.Const
import Control.Arrow.Logger
import Control.Arrow.Except
import Control.Arrow.Fail
import Control.Arrow.Fix
import Control.Arrow.MemAddress
import Control.Arrow.Memory
import Control.Arrow.MemSizable
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.GlobalState
import Control.Arrow.WasmFrame
import Control.Arrow.Transformer.Reader
import Control.Arrow.Transformer.State
import Control.Category
import Data.Monoidal (shuffle1)
import Data.Profunctor
import Data.Vector (Vector, (!), (//))
import qualified Data.Vector as Vec
import Data.Word
import Language.Wasm.Interpreter (ModuleInstance)
import qualified Language.Wasm.Interpreter as Wasm
import Language.Wasm.Structure hiding (exports, Const)
import Numeric.Natural (Natural)
import GenericInterpreter (LoadType,StoreType)
import Concrete
newtype GlobalState2T v c x y = GlobalState2T (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, ArrowMemory m addr bytes)--, ArrowState (GlobalState v))
instance (ArrowReader r c) => ArrowReader r (GlobalState2T v c) where
ask = lift' ask
local a = lift $ lmap shuffle1 (local (unlift a))
instance (ArrowState s c) => ArrowState s (GlobalState2T v c) where
-- TODO
instance ArrowTrans (GlobalState2T v) where
-- lift' :: c x y -> GlobalStateT v c x y
lift' a = GlobalState2T (lift' a)
instance (ArrowChoice c, Profunctor c) => ArrowGlobalState v MemInst (GlobalState2T v c) where
readGlobal =
GlobalState2T $ proc i -> do
GlobalState{globalInstances=vec} <- get -< ()
let (GlobInst _ val) = vec ! i
returnA -< val
writeGlobal =
GlobalState2T $ proc (i,v) -> do
store@GlobalState{globalInstances=vec} <- get -< ()
let (GlobInst m _) = vec ! i
if m == Const
then returnA -< error $ "writing to constant global " ++ (show i)
else put -< store{globalInstances=vec // [(i, GlobInst m v)]}
-- funcCont :: ReaderT Int (StateT (GlobalState v) c) ((FuncType, ModuleInstance, Function),x) y
-- we need ReaderT Int (StateT (GlobalState v) c) (Int, x) y
readFunction (GlobalState2T funcCont) =
GlobalState2T $ proc (i,x) -> do
GlobalState{funcInstances = fs} <- get -< ()
case fs ! i of
FuncInst fTy modInst code -> funcCont -< ((fTy,modInst,code),x)
_ -> returnA -< error "not yet implemented" --hostCont -< ((fTy,code),x)
--withMemoryInstance (GlobalStateT f) = GlobalStateT $ local f
fetchMemory = GlobalState2T $ proc i -> do
GlobalState{memInstances=mems} <- get -< ()
returnA -< mems ! i
storeMemory = GlobalState2T $ proc (i,m) -> do
gs@GlobalState{memInstances=mems} <- get -< ()
put -< gs{memInstances=mems // [(i,m)]}
instance (Arrow c, Profunctor c) => ArrowMemAddress Value Natural Word32 (GlobalState2T v c) where
memaddr = proc (Value (Wasm.VI32 base), off) -> returnA -< (base+ (fromIntegral off))
instance ArrowSerialize v (Vector Word8) ValueType LoadType StoreType (GlobalState2T v c) where
instance ArrowMemSizable v (GlobalState2T v c) where
instance ArrowFix (Underlying (GlobalState2T v c) x y) => ArrowFix (GlobalState2T v c x y) where
type Fix (GlobalState2T v c x y) = Fix (Underlying (GlobalState2T v c) x y)
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Arrow.Transformer.Concrete.Memory 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.Stack
import Control.Arrow.State
import Control.Arrow.Store
import Control.Arrow.Trans
import Control.Arrow.WasmFrame
import Control.Category
import Data.Profunctor
import Data.Vector (Vector)
import qualified Data.Vector as Vec
import Data.Word
newtype MemoryT c x y = MemoryT (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, ArrowReader r, ArrowGlobalState val m)--, ArrowState (GlobalState v))
instance ArrowTrans MemoryT where
-- lift' :: c x y -> MemoryT v c x y
lift' a = MemoryT a
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
let addrI = fromIntegral addr
case (addrI+size <= length vec) of
True -> do
let content = Vec.slice addrI size vec
y <- sCont -< (content,x)
returnA -< (m,y)
False -> do
y <- eCont -< x
returnA -< (m,y)
memstore (MemoryT sCont) (MemoryT eCont) = MemoryT $ proc (m@(MemInst maxSize vec), (addr, content, x)) -> do
let addrI = fromIntegral addr
let size = length content
case (addrI+size <= length vec) of
True -> do
let ind = Vec.enumFromN addrI size
let newMem = MemInst maxSize (Vec.update_ vec ind content)
y <- sCont -< x
returnA -< (newMem,y)
False -> do
y <- eCont -< x
returnA -< (m,y)
instance (ArrowLift c, ArrowFix (Underlying (MemoryT c) x y)) => ArrowFix (MemoryT c x y) where
type Fix (MemoryT c x y) = Fix (Underlying (MemoryT c) x y)
......@@ -5,19 +5,19 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Arrow.Transformer.Concrete.Frame where
module Control.Arrow.Transformer.Concrete.WasmFrame where
import Control.Arrow
import Control.Arrow.Const
import Control.Arrow.Except
import Control.Arrow.Fail
import Control.Arrow.Fix
import Control.Arrow.Frame
import Control.Arrow.Reader
import Control.Arrow.Stack
import Control.Arrow.State
import Control.Arrow.Store
import Control.Arrow.Trans
import Control.Arrow.WasmFrame
import Control.Arrow.Transformer.Reader
import Control.Arrow.Transformer.State
......
......@@ -13,7 +13,6 @@ import Control.Arrow.DebuggableStack
import Control.Arrow.Except
import Control.Arrow.Fail
import Control.Arrow.Fix
import Control.Arrow.Frame
import Control.Arrow.Logger
import Control.Arrow.MemAddress
import Control.Arrow.Memory
......@@ -26,6 +25,7 @@ import Control.Arrow.Serialize
import Control.Arrow.Transformer.Stack
import Control.Arrow.GlobalState
import Control.Arrow.Writer
import Control.Arrow.WasmFrame
import Data.Profunctor
......
......@@ -14,7 +14,6 @@ import Control.Arrow.DebuggableStack
import Control.Arrow.Except
import Control.Arrow.Fail
import Control.Arrow.Fix
import Control.Arrow.Frame
import Control.Arrow.Logger
import Control.Arrow.MemAddress
import Control.Arrow.Memory
......@@ -26,6 +25,7 @@ import Control.Arrow.Serialize
import Control.Arrow.Transformer.Stack
import Control.Arrow.GlobalState
import Control.Arrow.Writer
import Control.Arrow.WasmFrame
import Data.Profunctor
......
......@@ -5,7 +5,7 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Arrow.Frame where
module Control.Arrow.WasmFrame where
import Prelude hiding ((.),read)
......
......@@ -21,7 +21,6 @@ import Control.Arrow.Except
import qualified Control.Arrow.Except as Exc
import Control.Arrow.Fail as Fail
import Control.Arrow.Fix
import Control.Arrow.Frame
import Control.Arrow.Logger
import Control.Arrow.MemAddress
import Control.Arrow.Memory
......@@ -31,6 +30,7 @@ import Control.Arrow.Serialize
import Control.Arrow.Stack
import qualified Control.Arrow.Utils as Arr
import Control.Arrow.GlobalState
import Control.Arrow.WasmFrame
import Data.Profunctor
import Data.Text.Lazy (Text)
......
module ConcreteSpec where
import Concrete
import ConcreteInterpreter
import GenericInterpreter(Exc(..))
......
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