Unverified Commit 5a5d77cd authored by Sven Keidel's avatar Sven Keidel
Browse files

wasm: fix all warnings

parent 22fc028f
Pipeline #127049 failed with stages
in 11 seconds
flags: {}
extra-package-dbs: []
resolver: lts-16.5
resolver: lts-17.2
packages:
- 'arrows'
- 'lib'
......
......@@ -7,24 +7,15 @@ module Abstract where
import Data
--import Concrete (TableInst, GlobInst)
import GenericInterpreter hiding (Top)
import GenericInterpreter()
import Control.Arrow
import Control.Arrow.Transformer.Value
import Data.Abstract.FreeCompletion hiding (Top)
import qualified Data.Abstract.FreeCompletion as FC
import Data.Hashable
import Data.Order
import Data.Text.Prettyprint.Doc
import Data.Vector (Vector)
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)
--
......@@ -58,16 +49,17 @@ instance (Complete ai32, Complete ai64, Complete af32, Complete af64) => Complet
(VI64 v1) (VI64 v2) = VI64 $ v1 v2
(VF32 v1) (VF32 v2) = VF32 $ v1 v2
(VF64 v1) (VF64 v2) = VF64 $ v1 v2
_ _ = error "least upper bound of base values with different types is unsupported"
type Tables = JoinVector TableInst
newtype TableInst = TableInst Wasm.TableInstance deriving (Show,Eq,Generic)
instance PreOrd (TableInst) where
-- TODO
instance PreOrd TableInst where
() = error "TODO: implement TableInst.⊑"
instance Complete TableInst where
-- TODO
() = error "TODO: implement TableInst.⊔"
instance Hashable TableInst
......
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Concrete where
import Data
import Data.Abstract.FreeCompletion
import Data()
import Data.Hashable
import Data.Order
import Data.Text.Prettyprint.Doc
import Data.Vector (Vector, (!), (//))
import qualified Data.Vector as Vec
import Data.Vector (Vector)
import Data.Word
import Language.Wasm.Interpreter (ModuleInstance)
......
......@@ -9,7 +9,7 @@
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module ConcreteInterpreter where
import Data
......@@ -32,61 +32,53 @@ import Control.Arrow.Transformer.Concrete.Memory
import Control.Arrow.Transformer.Concrete.Serialize
import Control.Arrow.Transformer.Concrete.Table
import Control.Monad.State
import Data.Concrete.Error
import qualified Data.Function as Function
import Data.IORef
import Data.Label
import qualified Data.Primitive.ByteArray as ByteArray
import Data.Text.Lazy (Text)
import Data.Vector (Vector)
import qualified Data.Vector as Vec
import Data.Word
import Language.Wasm.Interpreter (ModuleInstance,emptyStore,emptyImports)
import Language.Wasm.Interpreter (ModuleInstance)
import qualified Language.Wasm.Interpreter as Wasm
import Language.Wasm.Structure hiding (exports, Const, Instruction, Function,Expression,Memory,Table)
import qualified Language.Wasm.Structure as Wasm
import Language.Wasm.Validate (ValidModule)
import Numeric.Natural (Natural)
toVal32 :: Word32 -> Value
toVal32 = Value . Wasm.VI32
toVal64 :: Word64 -> Value
toVal64 = Value . Wasm.VI64
instance (ArrowChoice c) => IsVal Value (ValueT Value c) where
instance ArrowChoice c => IsVal Value (ValueT Value c) where
type JoinVal y (ValueT Value c) = ()
i32const = proc w32 -> returnA -< Value $ Wasm.VI32 w32
i64const = proc w64 -> returnA -< Value $ Wasm.VI64 w64
iBinOp eCont = proc (bs,op,Value v1,Value v2) ->
case (bs,op,v1,v2) of
(BS32, IAdd, Wasm.VI32 val1, Wasm.VI32 val2) -> returnA -< toVal32 $ val1 + val2
(BS32, IMul, Wasm.VI32 val1, Wasm.VI32 val2) -> returnA -< toVal32 $ val1 * val2
(BS32, ISub, Wasm.VI32 val1, Wasm.VI32 val2) -> returnA -< toVal32 $ val1 - val2
(BS64, IAdd, Wasm.VI64 val1, Wasm.VI64 val2) -> returnA -< toVal64 $ val1 + val2
(BS64, IMul, Wasm.VI64 val1, Wasm.VI64 val2) -> returnA -< toVal64 $ val1 * val2
(BS64, ISub, Wasm.VI64 val1, Wasm.VI64 val2) -> returnA -< toVal64 $ val1 - val2
iBinOp _eCont = proc (bs,op,Value v1,Value v2) ->
case (bs,op,v1,v2) of
(BS32, IAdd, Wasm.VI32 val1, Wasm.VI32 val2) -> returnA -< toVal32 $ val1 + val2
(BS32, IMul, Wasm.VI32 val1, Wasm.VI32 val2) -> returnA -< toVal32 $ val1 * val2
(BS32, ISub, Wasm.VI32 val1, Wasm.VI32 val2) -> returnA -< toVal32 $ val1 - val2
(BS64, IAdd, Wasm.VI64 val1, Wasm.VI64 val2) -> returnA -< toVal64 $ val1 + val2
(BS64, IMul, Wasm.VI64 val1, Wasm.VI64 val2) -> returnA -< toVal64 $ val1 * val2
(BS64, ISub, Wasm.VI64 val1, Wasm.VI64 val2) -> returnA -< toVal64 $ val1 - val2
_ -> returnA -< error "iBinOp: cannot apply binary operator to given arguments."
iRelOp = proc (bs,op,Value v1, Value v2) ->
case (bs,op,v1,v2) of
(BS32, IEq, Wasm.VI32 val1, Wasm.VI32 val2) ->
returnA -< toVal32 $ if val1 == val2 then 1 else 0
case (bs,op,v1,v2) of
(BS32, IEq, Wasm.VI32 val1, Wasm.VI32 val2) ->
returnA -< toVal32 $ if val1 == val2 then 1 else 0
-- (BS64, ILtU, Wasm.VI64 val1, Wasm.VI64 val2) ->
-- returnA -< toVal64 $ if val1 < val2 then 1 else 0
(BS64, IEq, Wasm.VI64 val1, Wasm.VI64 val2) ->
returnA -< toVal32 $ if val1 == val2 then 1 else 0
(BS64, IEq, Wasm.VI64 val1, Wasm.VI64 val2) ->
returnA -< toVal32 $ if val1 == val2 then 1 else 0
_ -> returnA -< error "iRelOp: cannot apply binary operator to given arguments."
i32ifNeqz f g = proc (v, x) -> do
case v of
Value (Wasm.VI32 0) -> g -< x
Value (Wasm.VI32 _) -> f -< x
_ -> returnA -< error "validation failure"
case v of
Value (Wasm.VI32 0) -> g -< x
Value (Wasm.VI32 _) -> f -< x
_ -> returnA -< error "i32ifNeqz: condition of unexpected type"
ifHasType f g = proc (v,t,x) -> do
case (v,t) of
......@@ -96,6 +88,27 @@ instance (ArrowChoice c) => IsVal Value (ValueT Value c) where
(Value (Wasm.VF64 _), F64) -> f -< x
_ -> g -< x
f32const = error "TODO: implement f32const"
f64const = error "TODO: implement f64const"
iUnOp = error "TODO: implement iUnOp"
i32eqz = error "TODO: implement i32eqz"
i64eqz = error "TODO: implement i64eqz"
fUnOp = error "TODO: implement fUnOp"
fBinOp = error "TODO: implement fBinOp"
fRelOp = error "TODO: implement fRelOp"
i32WrapI64 = error "TODO: implement i32WrapI64"
iTruncFU = error "TODO: implement iTruncFU"
iTruncFS = error "TODO: implement iTruncFS"
i64ExtendSI32 = error "TODO: implement i64ExtendSI32"
i64ExtendUI32 = error "TODO: implement i64ExtendUI32"
fConvertIU = error "TODO: implement fConvertIU"
fConvertIS = error "TODO: implement fConvertIS"
f32DemoteF64 = error "TODO: implement f32DemoteF64"
f64PromoteF32 = error "TODO: implement f64PromoteF32"
iReinterpretF = error "TODO: implement iReinterpretF"
fReinterpretI = error "TODO: implement IReinterpretI"
listLookup = error "TODO: implement listLookup"
instance (Arrow c) => IsException (Exc Value) Value (ValueT Value c) where
type JoinExc y (ValueT Value c) = ()
exception = arr id
......@@ -103,6 +116,7 @@ instance (Arrow c) => IsException (Exc Value) Value (ValueT Value c) where
addVal :: Wasm.Value -> Wasm.Value -> Wasm.Value
addVal (Wasm.VI32 v1) (Wasm.VI32 v2) = Wasm.VI32 $ v1 + v2
addVal _ _ = error "addVal: cannot add values. Unexpected types"
--evalNumericInst :: (Instruction Natural) -> [Value] -> Error (Exc Value) Value
......@@ -172,12 +186,12 @@ invokeExported :: StaticGlobalState Value
-> ModuleInstance
-> Text
-> [Value]
-> (Error
-> Error
[Char]
(JoinVector Value,
(Tables,
(Memories,
(StaticGlobalState Value, Error (Exc Value) (JoinList Value, [Value]))))))
(StaticGlobalState Value, Error (Exc Value) (JoinList Value, [Value])))))
invokeExported staticS mem tab modInst funcName args =
let ?fixpointAlgorithm = Function.fix in
Trans.run
......
......@@ -18,7 +18,6 @@ import Control.Arrow.Transformer.Writer
import Data.Profunctor.Unsafe
import Numeric.Natural (Natural)
class ArrowStack v c => ArrowDebuggableStack v c | c -> v where
getStack :: c () [v]
......
......@@ -56,8 +56,8 @@ class ArrowGlobalState v m c | c -> v, c -> m where
deriving instance (ArrowGlobalState v m c) => ArrowGlobalState v m (ValueT v2 c)
instance (Profunctor c, Arrow c, ArrowGlobalState v m c) => ArrowGlobalState v m (StateT s c) where
readGlobal = lift' readGlobal
writeGlobal = lift' writeGlobal
readGlobal = lift' readGlobal
writeGlobal = lift' writeGlobal
-- readFunction :: (StateT s c) (f, x) y -> (StateT s c) (Int, x) y
-- a :: (StateT s c) (f, x) y
-- unlift a :: Underlying (StateT s c) (f, x) y
......@@ -72,12 +72,12 @@ instance (Profunctor c, Arrow c, ArrowGlobalState v m c) => ArrowGlobalState v m
-- modify (flip a) :: (StateT s c) (f,x) y
-- readFunction (modify (flip a)) :: c (Int, x) y
-- second (readFunction (modify (flip a))) :: c (s, (Int,x)) (s, y)
readFunction a = lift $ transform (unlift a)
readFunction a = lift $ transform (unlift a)
-- -- proc (f,x) -> arr -< (s, (f,x)) :: c (f,x) (s, y)
-- -- ((proc (f,x) -> arr -< (s, (f,x))) >>^ snd) :: c (f,x) y
-- -- readFunction ((proc (f,x) -> arr -< (s, (f,x))) >>^ snd) :: c (Int, x) y
-- -- c (s, (Int, x)) y
where transform f = proc (s, (i,x)) -> readFunction (proc (f,(s2,x)) -> f -< (s2, (f,x))) -< (i,(s,x))
where transform f = proc (s, (i,x)) -> readFunction (proc (fun,(s2,x)) -> f -< (s2, (fun,x))) -< (i,(s,x))
-- -- arr :: c (s, (f,x)) (s, y)
-- -- proc (f,(s2,x)) -> arr -< (s2, (f,x)) :: c (f,(s,x)) (s, y)
-- -- ((proc (f,(s2,x)) -> arr -< (s2, (f,x))) >>^ snd) :: c (f,(s,x)) y
......@@ -89,8 +89,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
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
......@@ -105,32 +105,37 @@ instance (Profunctor c, Arrow c, ArrowGlobalState v m c) => ArrowGlobalState v m
-- -- func "" :: c (Int, (s,x)) y (for z = (s x))
-- y <- func ((proc (f,(s2,x)) -> arr -< (s2, (f,x))) >>^ snd) -< (i,(s,x))
-- returnA -< (s,y)
readTable = error "TODO: Implement StateT.readTable"
deriving instance (Arrow c, Profunctor c, ArrowGlobalState v m c) => ArrowGlobalState v m (CE.ExceptT e c)
deriving instance (O.Complete e, Arrow c, Profunctor c, ArrowGlobalState v m c) => ArrowGlobalState v m (AE.ExceptT e 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 m c) => ArrowGlobalState v m (KleisliT f c) where
readGlobal = lift' readGlobal
writeGlobal = lift' writeGlobal
readFunction a = lift (readFunction (unlift a))
fetchMemory = lift' fetchMemory
storeMemory = lift' storeMemory
readGlobal = lift' readGlobal
writeGlobal = lift' writeGlobal
readFunction a = lift (readFunction (unlift a))
fetchMemory = lift' fetchMemory
storeMemory = lift' storeMemory
readTable = error "TODO: Implement KleisliT.readTable"
instance (Arrow c, Profunctor c, ArrowGlobalState v m c) => ArrowGlobalState v m (ReaderT r c) where
readGlobal = lift' readGlobal
writeGlobal = lift' writeGlobal
-- unlift arr :: c (r, (f,x)) y
-- lift :: c (r, (Int,x)) y -> c (Int,x) y
-- transform :: c (r, (f,x)) y -> c (r, (Int,x)) y
-- readFunction :: c (f,x) y -> c (Int,x) y
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
readGlobal = lift' readGlobal
writeGlobal = lift' writeGlobal
-- unlift arr :: c (r, (f,x)) y
-- lift :: c (r, (Int,x)) y -> c (Int,x) y
-- transform :: c (r, (f,x)) y -> c (r, (Int,x)) y
-- readFunction :: c (f,x) y -> c (Int,x) y
readFunction a = lift $ transform (unlift a)
where transform f = proc (r, (i,x)) ->
readFunction (proc (fun,(r,x)) -> f -< (r, (fun,x))) -< (i,(r,x))
fetchMemory = lift' fetchMemory
storeMemory = lift' storeMemory
readTable = error "TODO: Implement ReaderT.readTable"
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
readGlobal = lift' readGlobal
writeGlobal = lift' writeGlobal
readFunction a = lift (readFunction (unlift a))
fetchMemory = lift' fetchMemory
storeMemory = lift' storeMemory
readTable = error "TODO: Implement WriterT.readTable"
......@@ -29,11 +29,14 @@ deriving instance (Arrow c, Profunctor c, ArrowMemSizable sz c) => ArrowMemSizab
deriving instance (O.Complete e, Arrow c, Profunctor c, ArrowMemSizable sz c) => ArrowMemSizable sz (AE.ExceptT e c)
instance (Monad f, Arrow c, Profunctor c, ArrowMemSizable sz c) => ArrowMemSizable sz (KleisliT f c) where
memsize = lift' memsize
-- TODO
memgrow = error "TODO: implement KleisliT.memgrow"
--deriving instance (ArrowMemSizable sz c) => ArrowMemSizable sz (StackT v c)
instance (ArrowMemSizable sz c) => ArrowMemSizable sz (StateT s c) where
-- TODO
memsize = error "TODO: implement StateT.memSize"
memgrow = error "TODO: implement StateT.memgrow"
instance (ArrowMemSizable sz c) => ArrowMemSizable sz (ReaderT r c) where
-- TODO
memsize = error "TODO: implement ReaderT.memSize"
memgrow = error "TODO: implement ReaderT.memgrow"
instance (ArrowMemSizable sz c) => ArrowMemSizable sz (WriterT r c) where
-- TODO
memsize = error "TODO: implement WriterT.memSize"
memgrow = error "TODO: implement WriterT.memgrow"
......@@ -45,13 +45,13 @@ instance (Arrow c, Profunctor c, Functor f, ArrowMemory addr bytes c) => ArrowMe
-- 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
-- where moveIn (m, ey) = fmap ((,) m) ey
memstore a1 a2 = lift $
(memstore (unlift a1) (unlift a2))-- >>^ moveIn
where moveIn (m, ey) = fmap ((,) m) ey
memstore (unlift a1) (unlift a2)-- >>^ moveIn
-- where moveIn (m, ey) = fmap ((,) m) ey
instance (Arrow c, ArrowMemory addr bytes c) => ArrowMemory addr bytes (StateT s c) where
type Join y (StateT s c) = Join (s,y) c
......@@ -72,4 +72,6 @@ instance (Arrow c, ArrowMemory addr bytes c) => ArrowMemory addr bytes (ReaderT
memstore a1 a2 = lift $ proc (r, (ma,addr,bytes,x)) ->
memstore (unlift a1) (unlift a2) -< (ma, addr, bytes, (r,x))
instance (ArrowMemory addr bytes c) => ArrowMemory addr bytes (WriterT r c) where
-- TODO
type Join x (WriterT r c) = Join (r,x) c
memread = error "TODO: Implement WriterT.memread"
memstore = error "TODO: Implement WriterT.memstore"
......@@ -55,6 +55,7 @@ instance (Arrow c, ArrowSerialize val dat valTy datDecTy datEncTy c) => ArrowSer
encode (proc (dat, (r,x)) -> (unlift a) -< (r, (dat,x)))
-< (val, valTy, datEncTy, (r,x))
instance (ArrowSerialize val dat valTy datDecTy datEncTy c) => ArrowSerialize val dat valTy datDecTy datEncTy (WriterT w c) where
-- TODO
decode = error "TODO: implement WriterT.decode"
encode = error "TODO: implement WriterT.encode"
deriving instance (Arrow c, ArrowSerialize val dat valTy datDecTy datEncTy c) => ArrowSerialize val dat valTy datDecTy datEncTy (AbsStore.StoreT store c)
......@@ -48,13 +48,13 @@ instance (Arrow c, Profunctor c, ArrowStaticGlobalState v c) => ArrowStaticGloba
readGlobal = lift' readGlobal
writeGlobal = lift' writeGlobal
readFunction a = lift $ transform (unlift a)
where transform f = proc (s, (i,x)) -> readFunction (proc (f,(s2,x)) -> f -< (s2, (f,x))) -< (i,(s,x))
where transform f = proc (s, (i,x)) -> readFunction (proc (y,(s2,x)) -> f -< (s2, (y,x))) -< (i,(s,x))
instance (Arrow c, Profunctor c, ArrowStaticGlobalState v c) => ArrowStaticGlobalState v (ReaderT r c) where
readGlobal = lift' readGlobal
writeGlobal = lift' writeGlobal
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))
readFunction (proc (y,(r,x)) -> f -< (r, (y,x))) -< (i,(r,x))
instance (Arrow c, Profunctor c, Monoid r, ArrowStaticGlobalState v c) => ArrowStaticGlobalState v (WriterT r c) where
readGlobal = lift' readGlobal
writeGlobal = lift' writeGlobal
......
......@@ -54,4 +54,5 @@ instance (Arrow c, ArrowTable v c) => ArrowTable v (ReaderT r c) where
(proc (i,v,(r,x)) -> unlift h -< (r, (i,v,x)))
-< (ta,ix,(r,x))
instance (ArrowTable v c) => ArrowTable v (WriterT r c) where
-- TODO
type JoinTable y (WriterT r c) = JoinTable (r,y) c
readTable = error "TODO: Implement WriterT.readTable"
......@@ -8,35 +8,35 @@ module Control.Arrow.Transformer.Abstract.GlobalState where
import Prelude hiding (read)
import Abstract
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.State
import Control.Arrow.Transformer.Abstract.Store
import Control.Category
import Data.Abstract.FreeCompletion
import Data.Abstract.Map (Map)
import Data.Profunctor
-- import Abstract
-- 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.State
-- import Control.Arrow.Transformer.Abstract.Store
-- import Control.Category
-- import Data.Abstract.FreeCompletion
-- import Data.Abstract.Map (Map)
-- import Data.Profunctor
--newtype GlobalStateT v storeV c x y = GlobalStateT (StateT (GlobalState v) (StoreT (Map (Int,v) storeV) c) x y)
-- deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowLift, ArrowReader r,
......
......@@ -16,7 +16,6 @@ import Control.Arrow.Const
import Control.Arrow.Except
import Control.Arrow.Fail
import Control.Arrow.Fix
import Control.Arrow.Logger
import Control.Arrow.MemAddress
import Control.Arrow.Memory
import Control.Arrow.MemSizable
......@@ -24,7 +23,6 @@ import Control.Arrow.Order
import Control.Arrow.Reader
import Control.Arrow.Serialize
import Control.Arrow.Stack
import Control.Arrow.State
import Control.Arrow.StaticGlobalState
import Control.Arrow.Store
import Control.Arrow.Table
......@@ -42,19 +40,20 @@ newtype MemoryT c x y = MemoryT (c x y)
ArrowSerialize val dat valTy datDecTy datEncTy, ArrowTable v, ArrowJoin)
instance ArrowTrans MemoryT where
-- lift' :: c x y -> MemoryT v c x y
lift' = MemoryT
-- lift' :: c x y -> MemoryT v c x y
lift' = MemoryT
instance (Profunctor c, ArrowChoice c) => ArrowMemory () () (MemoryT c) where
type Join y (MemoryT c) = ArrowComplete y (MemoryT c)
memread sCont eCont = proc (_,(),_,x) -> (sCont -< ((),x)) <> (eCont -< x)
memstore sCont eCont = proc (_,(),(),x) -> (sCont -< x) <> (eCont -< x)
type Join y (MemoryT c) = ArrowComplete y (MemoryT c)
memread sCont eCont = proc (_,(),_,x) -> (sCont -< ((),x)) <> (eCont -< x)
memstore sCont eCont = proc (_,(),(),x) -> (sCont -< x) <> (eCont -< x)
instance (Arrow c, Profunctor c) => ArrowMemAddress base off () (MemoryT c) where
memaddr = arr $ const ()
memaddr = arr $ const ()
instance ArrowMemSizable Value (MemoryT c) where
-- TODO
memsize = error "TODO: implement MemoryT.memsize"
memgrow = error "TODO: implement MemoryT.memgrow"
deriving instance (Arrow c, Profunctor c, ArrowComplete y c) => ArrowComplete y (MemoryT c)
......
......@@ -18,11 +18,6 @@ import Control.Arrow.Const
import Control.Arrow.Except
import Control.Arrow.Fail
import Control.Arrow.Fix hiding (filter)
import Control.Arrow.GlobalState
import Control.Arrow.Logger
import Control.Arrow.MemAddress
import Control.Arrow.Memory
import Control.Arrow.MemSizable
import Control.Arrow.Order
import Control.Arrow.Reader
import Control.Arrow.Serialize
......
......@@ -9,7 +9,7 @@
module Control.Arrow.Transformer.Abstract.WasmFrame where
import Concrete
import Concrete()
import Control.Arrow
import Control.Arrow.Const
......@@ -47,7 +47,7 @@ instance (Hashable v) => Hashable (Vector v)
-- hashWithSalt salt v = hashWithSalt salt (Vec.toList v)
instance (PreOrd v) => PreOrd (Vector v) where
(Vector v1) (Vector v2) = all id $ Vec.zipWith () v1 v2
(Vector v1) (Vector v2) = and $ Vec.zipWith () v1 v2
instance (Complete v) => Complete (Vector v) where
(Vector v1) (Vector v2) = Vector $ Vec.zipWith () v1 v2
......@@ -60,7 +60,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 -< ())
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
......
......@@ -15,7 +15,6 @@ import Control.Arrow.Const
import Control.Arrow.Except
import Control.Arrow.Fail
import Control.Arrow.Fix
import Control.Arrow.Logger
import Control.Arrow.MemAddress
import Control.Arrow.Memory
import Control.Arrow.MemSizable
......@@ -49,41 +48,42 @@ newtype MemoryT c x y = MemoryT (StateT Memories c x y)
ArrowSerialize val dat valTy datDecTy datEncTy, ArrowTable v)
instance ArrowTrans MemoryT where
-- lift' :: c x y -> MemoryT v c x y
lift' a = MemoryT (lift' a)
-- lift' :: c x y -> MemoryT v c x y
lift' a = MemoryT (lift' a)
instance (ArrowChoice c, Profunctor c) => ArrowMemory Word32 (Vector Word8) (MemoryT c) where
type Join y (MemoryT c) = ()
memread (MemoryT sCont) (MemoryT eCont) = MemoryT $ proc (index,addr,size,x) -> do
let addrI = fromIntegral addr
mems <- get -< ()
let (MemInst _ vec) = mems ! index
case (addrI+size <= length vec) of