Commit 90b124ea authored by Katharina Brandl's avatar Katharina Brandl
Browse files

Refactoring separating static from dynamic components

parent 103c5d15
Pipeline #117390 passed with stages
in 72 minutes and 23 seconds
......@@ -6,7 +6,7 @@
module Abstract where
import Data
import Concrete (TableInst, GlobInst)
--import Concrete (TableInst, GlobInst)
import GenericInterpreter hiding (Top)
import Control.Arrow
......@@ -23,23 +23,24 @@ import qualified Data.Vector as Vec
import GHC.Generics
import qualified Language.Wasm.Interpreter as Wasm
import Language.Wasm.Structure hiding (exports, Const)
data IsZero = Zero | NotZero | Top deriving (Eq, Show, Generic)
instance Hashable IsZero
instance PreOrd IsZero where
_ Top = True
_ _ = False
instance Complete IsZero where
x y | x == y = x
| otherwise = Top
instance UpperBounded IsZero where
top = Top
--data IsZero = Zero | NotZero | Top deriving (Eq, Show, Generic)
--
--instance Hashable IsZero
--
--instance PreOrd IsZero where
-- _ ⊑ Top = True
-- _ ⊑ _ = False
--
--instance Complete IsZero where
-- x ⊔ y | x == y = x
-- | otherwise = Top
--
--instance UpperBounded IsZero where
-- top = Top
--
data BaseValue ai32 ai64 af32 af64 = VI32 ai32 | VI64 ai64 | VF32 af32 | VF64 af64 deriving (Show, Eq, Generic)
instance (Hashable ai32, Hashable ai64, Hashable af32, Hashable af64) => Hashable (BaseValue ai32 ai64 af32 af64)
instance (Show ai32, Show ai64, Show af32, Show af64) => Pretty (BaseValue ai32 ai64 af32 af64) where
......@@ -52,31 +53,42 @@ instance (PreOrd ai32, PreOrd ai64, PreOrd af32, PreOrd af64) => PreOrd (BaseVal
(VF64 v1) (VF64 v2) = v1 v2
_ _ = False
instance (Complete ai32, Complete ai64, Complete af32, Complete af64) => Complete (FreeCompletion (BaseValue ai32 ai64 af32 af64)) where
(Lower (VI32 v1)) (Lower (VI32 v2)) = Lower $ VI32 $ v1 v2
(Lower (VI64 v1)) (Lower (VI64 v2)) = Lower $ VI64 $ v1 v2
(Lower (VF32 v1)) (Lower (VF32 v2)) = Lower $ VF32 $ v1 v2
(Lower (VF64 v1)) (Lower (VF64 v2)) = Lower $ VF64 $ v1 v2
_ _ = FC.Top
data GlobalState v = GlobalState {
funcInstances :: Vector FuncInst,
tableInstances :: Vector TableInst,
globalInstances:: Vector (FreeCompletion (GlobInst v))
} deriving (Show,Eq,Generic)
instance (Show v) => Pretty (GlobalState v) where pretty = viaShow
instance (Hashable v) => Hashable (GlobalState v)
instance (PreOrd v) => PreOrd (GlobalState v) where
s1 s2 = let gs1 = globalInstances s1 in
let gs2 = globalInstances s2 in
Vec.all id $ Vec.zipWith () gs1 gs2
instance (Complete v) => Complete (FreeCompletion (GlobalState v)) where
-- assert f1 = f2 and t1 = t2, TODO: do we need to check this?
(Lower (GlobalState f1 t1 g1)) (Lower (GlobalState f2 t2 g2))
| f1 == f2 && t1 == t2 = Lower $ GlobalState f1 t1 (Vec.zipWith () g1 g2)
| otherwise = FC.Top
_ _ = FC.Top
instance (Complete ai32, Complete ai64, Complete af32, Complete af64) => Complete (BaseValue ai32 ai64 af32 af64) where
(VI32 v1) (VI32 v2) = VI32 $ v1 v2
(VI64 v1) (VI64 v2) = VI64 $ v1 v2
(VF32 v1) (VF32 v2) = VF32 $ v1 v2
(VF64 v1) (VF64 v2) = VF64 $ v1 v2
type Tables = JoinVector TableInst
newtype TableInst = TableInst Wasm.TableInstance deriving (Show,Eq,Generic)
instance PreOrd (TableInst) where
-- TODO
instance Complete TableInst where
-- TODO
instance Hashable TableInst
--data GlobalState v = GlobalState {
-- funcInstances :: Vector FuncInst,
-- tableInstances :: Vector TableInst,
-- globalInstances:: Vector (FreeCompletion (GlobInst v))
--} deriving (Show,Eq,Generic)
--
--instance (Show v) => Pretty (GlobalState v) where pretty = viaShow
--
--instance (Hashable v) => Hashable (GlobalState v)
--instance (PreOrd v) => PreOrd (GlobalState v) where
-- s1 ⊑ s2 = let gs1 = globalInstances s1 in
-- let gs2 = globalInstances s2 in
-- Vec.all id $ Vec.zipWith (⊑) gs1 gs2
--
--instance (Complete v) => Complete (FreeCompletion (GlobalState v)) where
-- -- assert f1 = f2 and t1 = t2, TODO: do we need to check this?
-- (Lower (GlobalState f1 t1 g1)) ⊔ (Lower (GlobalState f2 t2 g2))
-- | f1 == f2 && t1 == t2 = Lower $ GlobalState f1 t1 (Vec.zipWith (⊔) g1 g2)
-- | otherwise = FC.Top
-- _ ⊔ _ = FC.Top
......@@ -21,45 +21,49 @@ import GHC.Generics
newtype Value = Value Wasm.Value deriving (Show, Eq)
instance Hashable Mut
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
}
instance (Hashable v) => Hashable (Vector v) where
hashWithSalt salt v = hashWithSalt salt (Vec.toList v)
instance Hashable MemArg
instance Hashable BitSize
instance Hashable IUnOp
instance Hashable IBinOp
instance Hashable IRelOp
instance Hashable FUnOp
instance Hashable FBinOp
instance Hashable FRelOp
instance Hashable Wasm.ExportInstance
deriving instance Generic Wasm.ExportInstance
instance Hashable Wasm.ExternalValue
deriving instance Generic Wasm.ExternalValue
instance (Hashable v) => Hashable (Instruction v)
instance Hashable ValueType
instance Hashable Function
instance Hashable FuncInst
instance Hashable FuncType
instance Hashable ModuleInstance
deriving instance Generic ModuleInstance
type Memories = Vector MemInst
type Tables = Vector TableInst
--data DynamicGlobalState = DynamicGlobalState {
-- tableInstances :: Vector TableInst,
-- memInstances :: Vector MemInst
--} 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
--}
--
--instance Hashable MemArg
--instance Hashable BitSize
--instance Hashable IUnOp
--instance Hashable IBinOp
--instance Hashable IRelOp
--instance Hashable FUnOp
--instance Hashable FBinOp
--instance Hashable FRelOp
--instance Hashable Wasm.ExportInstance
--deriving instance Generic Wasm.ExportInstance
--instance Hashable Wasm.ExternalValue
--deriving instance Generic Wasm.ExternalValue
--instance (Hashable v) => Hashable (Instruction v)
--instance Hashable ValueType
--instance Hashable Function
--instance Hashable FuncInst
--instance Hashable FuncType
--instance Hashable ModuleInstance
--deriving instance Generic ModuleInstance
instance Pretty ModuleInstance where pretty = viaShow
instance Hashable TableInst
instance Hashable Wasm.TableInstance
......@@ -68,23 +72,7 @@ instance Hashable Limit
newtype TableInst = TableInst Wasm.TableInstance deriving (Show,Eq,Generic)
data MemInst = MemInst (Maybe Word32) (Vector Word8) deriving (Show,Eq)
data GlobInst v = GlobInst Mut v deriving (Show, Eq, Generic)
instance (Hashable v) => Hashable (GlobInst v)
instance (PreOrd v) => PreOrd (GlobInst v) where
(GlobInst m1 v1) (GlobInst m2 v2) = m1 == m2 && v1 v2
instance (Complete v) => Complete (FreeCompletion (GlobInst v)) where
(Lower (GlobInst m1 v1)) (Lower (GlobInst m2 v2))
| m1 == m2 = Lower $ GlobInst m1 (v1 v2)
| otherwise = Top
_ _ = Top
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
......@@ -4,6 +4,7 @@
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
......@@ -19,17 +20,17 @@ import qualified GenericInterpreter as Generic
import Control.Arrow
import qualified Control.Arrow.Trans as Trans
import Control.Arrow.Transformer.DebuggableStack
import Control.Arrow.Transformer.Logger
import Control.Arrow.Transformer.Stack
import Control.Arrow.Transformer.StaticGlobalState
import Control.Arrow.Transformer.Reader
import Control.Arrow.Transformer.Value
import Control.Arrow.Transformer.WasmFrame
import Control.Arrow.Transformer.Concrete.Failure
import Control.Arrow.Transformer.Concrete.Except
import Control.Arrow.Transformer.Concrete.GlobalState
import Control.Arrow.Transformer.Concrete.Memory
import Control.Arrow.Transformer.Concrete.Serialize
import Control.Arrow.Transformer.Concrete.WasmFrame
import Control.Arrow.Transformer.Concrete.Table
import Control.Monad.State
......@@ -46,7 +47,7 @@ import Data.Word
import Language.Wasm.Interpreter (ModuleInstance,emptyStore,emptyImports)
import qualified Language.Wasm.Interpreter as Wasm
import Language.Wasm.Structure hiding (exports, Const, Instruction, Function,Expression)
import Language.Wasm.Structure hiding (exports, Const, Instruction, Function,Expression,Memory,Table)
import qualified Language.Wasm.Structure as Wasm
import Language.Wasm.Validate (ValidModule)
......@@ -104,37 +105,39 @@ addVal :: Wasm.Value -> Wasm.Value -> Wasm.Value
addVal (Wasm.VI32 v1) (Wasm.VI32 v2) = Wasm.VI32 $ v1 + v2
evalNumericInst :: (Instruction Natural) -> [Value] -> Error (Exc Value) Value
evalNumericInst inst stack =
snd $ Trans.run
(Generic.evalNumericInst ::
ValueT Value
(ExceptT (Exc Value)
(StackT Value
(->))) (Instruction Natural) Value) (stack,inst)
--type TransStack = FrameT FrameData Value (StackT Value (->))
--evalNumericInst :: (Instruction Natural) -> [Value] -> Error (Exc Value) Value
--evalNumericInst inst stack =
-- snd $ Trans.run
-- (Generic.evalNumericInst ::
-- ValueT Value
-- (ExceptT (Exc Value)
-- (StackT Value
-- (->))) (Instruction Natural) Value) (AbsList stack,inst)
--
--
----type TransStack = FrameT FrameData Value (StackT Value (->))
----
--evalVariableInst :: (Instruction Natural) -> [Value] -> FrameData -> Vector Value
-- -> GlobalState Value -> ([Value], (Vector Value, (GlobalState Value, ())))
--evalVariableInst inst stack fd locals store =
-- unabs $ Trans.run
-- (Generic.evalVariableInst ::
-- GlobalStateT Value
-- (FrameT FrameData Value
-- (StackT Value
-- (->))) (Instruction Natural) ()) (AbsList stack, (locals, (fd,(store, inst))))
-- where unabs (AbsList x,y) = (x,y)
--
--
--evalParametricInst :: (Instruction Natural) -> [Value] -> ([Value], ())
--evalParametricInst inst stack =
-- unabs $ Trans.run
-- (Generic.evalParametricInst ::
-- ValueT Value
-- (StackT Value
-- (->)) (Instruction Natural) ()) (AbsList stack,inst)
-- where unabs (AbsList x,y) = (x,y)
--
evalVariableInst :: (Instruction Natural) -> [Value] -> FrameData -> Vector Value
-> GlobalState Value -> ([Value], (Vector Value, (GlobalState Value, ())))
evalVariableInst inst stack fd locals store =
Trans.run
(Generic.evalVariableInst ::
GlobalStateT Value
(FrameT FrameData Value
(StackT Value
(->))) (Instruction Natural) ()) (stack, (locals, (fd,(store, inst))))
evalParametricInst :: (Instruction Natural) -> [Value] -> ([Value], ())
evalParametricInst inst stack =
Trans.run
(Generic.evalParametricInst ::
ValueT Value
(StackT Value
(->)) (Instruction Natural) ()) (stack,inst)
--eval :: [Instruction Natural] -> [Value] -> Generic.LabelArities -> Vector Value -> FrameData ->
-- GlobalState Value -> Int ->
......@@ -155,59 +158,72 @@ evalParametricInst inst stack =
-- (StackT Value
-- (->)))))) [Instruction Natural] ()) (stack,(r,(locals,(fd,(wasmStore,(currentMem,inst))))))
type Result = (Error
[Char]
(JoinVector Value,
(Tables,
(Memories,
(StaticGlobalState Value, Error (Exc Value) (JoinList Value, [Value]))))))
invokeExported :: GlobalState Value
invokeExported :: StaticGlobalState Value
-> Memories
-> Tables
-> ModuleInstance
-> Text
-> [Value]
-> ([String], Error
-> (Error
[Char]
(Vector Value,
(GlobalState Value, Error (Exc Value) ([Value], [Value]))))
invokeExported store modInst funcName args =
(JoinVector Value,
(Tables,
(Memories,
(StaticGlobalState Value, Error (Exc Value) (JoinList Value, [Value]))))))
invokeExported staticS mem tab modInst funcName args =
let ?fixpointAlgorithm = Function.fix in
Trans.run
(Generic.invokeExported ::
ValueT Value
(ReaderT Generic.LabelArities
(DebuggableStackT Value
(StackT Value
(ExceptT (Generic.Exc Value)
(GlobalStateT Value
(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))
instantiate valMod = do
res <- Wasm.instantiate emptyStore emptyImports valMod
case res of
Right (modInst, store) -> do
wasmStore <- storeToGlobalState store
return $ Right $ (modInst, wasmStore)
Left e -> return $ Left e
(StaticGlobalStateT Value
(MemoryT
(SerializeT
(TableT
(FrameT FrameData Value
(FailureT String
(->)))))))))) (Text, [Value]) [Value]) (JoinVector Vec.empty,((0,modInst),(tab,(mem,(staticS,([],(Generic.LabelArities [],(funcName,args))))))))
instantiateConcrete :: ValidModule -> IO (Either String (ModuleInstance, StaticGlobalState Value, Memories, Tables))
instantiateConcrete valMod = instantiate valMod Value toMem TableInst
where
storeToGlobalState (Wasm.Store funcI tableI memI globalI) = do
let funcs = generate $ Vec.mapM convertFuncInst funcI
mems <- Vec.mapM convertMem memI
globs <- Vec.mapM convertGlobals globalI
return $ GlobalState funcs --(Vec.map convertFuncs funcI)
(Vec.map TableInst tableI)
mems
globs
convertMem (Wasm.MemoryInstance (Limit _ n) mem) = do
memStore <- readIORef mem
size <- ByteArray.getSizeofMutableByteArray memStore
list <- sequence $ map (\x -> ByteArray.readByteArray memStore x) [0 .. (size-1)]
let sizeConverted = fmap fromIntegral n
return $ MemInst sizeConverted $ Vec.fromList list
convertGlobals (Wasm.GIConst _ v) = return $ GlobInst Const (Value v)
convertGlobals (Wasm.GIMut _ v) = do
val <- readIORef v
return $ GlobInst Mutable (Value val)
toMem size lst = MemInst size (Vec.fromList lst)
-- res <- Wasm.instantiate emptyStore emptyImports valMod
-- case res of
-- Right (modInst, store) -> do
-- wasmStore <- storeToGlobalState store
-- return $ Right $ (modInst, wasmStore)
-- Left e -> return $ Left e
--
-- where
-- storeToGlobalState (Wasm.Store funcI tableI memI globalI) = do
-- let funcs = generate $ Vec.mapM convertFuncInst funcI
-- mems <- Vec.mapM convertMem memI
-- globs <- Vec.mapM convertGlobals globalI
-- return $ GlobalState funcs --(Vec.map convertFuncs funcI)
-- (Vec.map TableInst tableI)
-- mems
-- globs
--
-- convertMem (Wasm.MemoryInstance (Limit _ n) mem) = do
-- memStore <- readIORef mem
-- size <- ByteArray.getSizeofMutableByteArray memStore
-- list <- sequence $ map (\x -> ByteArray.readByteArray memStore x) [0 .. (size-1)]
-- let sizeConverted = fmap fromIntegral n
-- return $ MemInst sizeConverted $ Vec.fromList list
--
-- convertGlobals (Wasm.GIConst _ v) = return $ GlobInst Const (Value v)
-- convertGlobals (Wasm.GIMut _ v) = do
-- val <- readIORef v
-- return $ GlobInst Mutable (Value val)
......@@ -46,7 +46,7 @@ class ArrowGlobalState v m c | c -> v, c -> m where
-- | Invokes `f (fa, x)` if all goes well.
-- | Invokes `g (ta,ix,x)` if `ix` is out of bounds.
-- | 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,v,x) y -> c (Int,v,x) y -> c (Int,v,x) y
fetchMemory :: c Int m
storeMemory :: c (Int, m) ()
......
......@@ -12,7 +12,7 @@ import Control.Arrow.Transformer.Concrete.Except as CE
import Control.Arrow.Transformer.Abstract.Except as AE
import Control.Arrow.Transformer.Kleisli
import Control.Arrow.Transformer.Reader
import Control.Arrow.Transformer.Stack
--import Control.Arrow.Transformer.Stack
import Control.Arrow.Transformer.State
import Control.Arrow.Transformer.Value
import Control.Arrow.Transformer.Writer
......@@ -28,7 +28,7 @@ deriving instance (Arrow c, Profunctor c, ArrowMemAddress base off addr c) => Ar
deriving instance (O.Complete e, Arrow c, Profunctor c, ArrowMemAddress base off addr c) => ArrowMemAddress base off addr (AE.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)
--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
......
......@@ -12,7 +12,7 @@ import Control.Arrow.Transformer.Concrete.Except as CE
import Control.Arrow.Transformer.Abstract.Except as AE
import Control.Arrow.Transformer.Kleisli
import Control.Arrow.Transformer.Reader
import Control.Arrow.Transformer.Stack
--import Control.Arrow.Transformer.Stack
import Control.Arrow.Transformer.State
import Control.Arrow.Transformer.Value
import Control.Arrow.Transformer.Writer
......@@ -21,8 +21,8 @@ import qualified Data.Order as O
import Data.Profunctor
class ArrowMemSizable sz c where
memsize :: c () sz
memgrow :: c (sz,x) y -> c x y -> c (sz,x) y
memsize :: c Int sz
memgrow :: c (sz,x) y -> c x y -> c (Int,sz,x) y
deriving instance (ArrowMemSizable sz c) => ArrowMemSizable sz (ValueT val2 c)
deriving instance (Arrow c, Profunctor c, ArrowMemSizable sz c) => ArrowMemSizable sz (CE.ExceptT e c)
......@@ -30,7 +30,7 @@ deriving instance (O.Complete e, Arrow c, Profunctor c, ArrowMemSizable sz c) =>
instance (Monad f, Arrow c, Profunctor c, ArrowMemSizable sz c) => ArrowMemSizable sz (KleisliT f c) where
memsize = lift' memsize
-- TODO
deriving instance (ArrowMemSizable sz c) => ArrowMemSizable sz (StackT v c)
--deriving instance (ArrowMemSizable sz c) => ArrowMemSizable sz (StackT v c)
instance (ArrowMemSizable sz c) => ArrowMemSizable sz (StateT s c) where
-- TODO
instance (ArrowMemSizable sz c) => ArrowMemSizable sz (ReaderT r c) where
......
......@@ -15,7 +15,7 @@ import Control.Arrow.Transformer.Abstract.Except as AE
import Control.Arrow.Transformer.Concrete.Except as CE
import Control.Arrow.Transformer.Kleisli
import Control.Arrow.Transformer.Reader
import Control.Arrow.Transformer.Stack
--import Control.Arrow.Transformer.Stack
import Control.Arrow.Transformer.State
import Control.Arrow.Transformer.Value
import Control.Arrow.Transformer.Writer
......@@ -24,26 +24,21 @@ import Data.Profunctor
import GHC.Exts (Constraint)
class ArrowMemory m addr bytes c | c -> addr, c -> bytes, c -> m where
class ArrowMemory addr bytes c | c -> addr, c -> bytes where
type family Join y c :: Constraint
memread :: Join y c => c (bytes, x) y -> c x y -> c (m, (addr, Int, x)) (m,y)
memstore :: Join y c => c x y -> c x y -> c (m, (addr, bytes, x)) (m,y)
-- | memread f g (ma,addr,size,x)
-- | Reads `size` bytes from memory `ma` at address `addr` to retrieve `bytes`.
-- | Invokes `f (bytes,x)` if all goes well.
-- | Invokes `g x` if memory access is out of bounds.
memread :: Join y c => c (bytes, x) y -> c x y -> c (Int, addr, Int, x) y
memstore :: Join y c => c x y -> c x y -> c (Int, addr, bytes, x) 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 m addr bytes c) => ArrowMemory m addr bytes (ValueT val2 c)
deriving instance (Arrow c, Profunctor c, ArrowMemory m addr bytes c) => ArrowMemory m addr bytes (CE.ExceptT e c)
deriving instance (Arrow c, Profunctor c, ArrowMemory m addr bytes c) => ArrowMemory m addr bytes (AE.ExceptT e c)
instance (Arrow c, Profunctor c, Functor f, ArrowMemory m addr bytes c) => ArrowMemory m addr bytes (KleisliT f c) where
deriving instance (ArrowMemory addr bytes c) => ArrowMemory addr bytes (ValueT val2 c)
deriving instance (Arrow c, Profunctor c, ArrowMemory addr bytes c) => ArrowMemory addr bytes (CE.ExceptT e c)
deriving instance (Arrow c, Profunctor c, ArrowMemory addr bytes c) => ArrowMemory addr bytes (AE.ExceptT e c)
instance (Arrow c, Profunctor c, Functor f, ArrowMemory addr bytes c) => ArrowMemory addr bytes (KleisliT f c) where
type Join y (KleisliT f c) = Join (f y) c
-- a1 :: KleisliT e c (bytes,x) y, a2 :: KleisliT e c x y
-- c1 :: c (bytes,x) (e y), c2 :: c x (e y)
......@@ -51,16 +46,16 @@ instance (Arrow c, Profunctor c, Functor f, ArrowMemory m addr bytes c) => Arrow
-- 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))
(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
(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
--deriving instance (Arrow c, ArrowMemory addr bytes c) => ArrowMemory addr bytes (StackT e c)
instance (Arrow c, ArrowMemory addr bytes c) => ArrowMemory addr bytes (StateT s c) where
type Join y (StateT s c) = Join (s,y) c
-- 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)
......@@ -69,25 +64,25 @@ instance (Arrow c, ArrowMemory m addr bytes c) => ArrowMemory m addr bytes (Stat
-- 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)))</