Commit 191f1f3d authored by Katharina Brandl's avatar Katharina Brandl
Browse files

Added more i64 operations and memsize/memgrow

parent 7ae7b9e9
Pipeline #128087 failed with stages
in 132 minutes and 42 seconds
......@@ -21,6 +21,12 @@ newtype Value = Value Wasm.Value deriving (Show, Eq)
type Memories = Vector MemInst
type Tables = Vector TableInst
int32 :: Word32 -> Value
int32 = Value . Wasm.VI32
int64 :: Word64 -> Value
int64 = Value . Wasm.VI64
--data DynamicGlobalState = DynamicGlobalState {
-- tableInstances :: Vector TableInst,
-- memInstances :: Vector MemInst
......
......@@ -57,10 +57,13 @@ instance (IsException (Exc Value) Value (ValueT Value c), ArrowChoice c) => IsVa
i64const = proc w64 -> returnA -< int64 w64
iUnOp = proc (bs,op,Value v0) -> case (bs,op,v0) of
(BS32, IClz, Wasm.VI32 v) -> returnA -< int32 $ fromIntegral $ countLeadingZeros v
(BS32, ICtz, Wasm.VI32 v) -> returnA -< int32 $ fromIntegral $ countTrailingZeros v
(BS32, IClz, Wasm.VI32 v) -> returnA -< int32 $ fromIntegral $ countLeadingZeros v
(BS32, ICtz, Wasm.VI32 v) -> returnA -< int32 $ fromIntegral $ countTrailingZeros v
(BS32, IPopcnt, Wasm.VI32 v) -> returnA -< int32 $ fromIntegral $ popCount v
_ -> trap -< "iUnOp: cannot apply operator to arguements"
(BS64, IClz, Wasm.VI64 v) -> returnA -< int64 $ fromIntegral $ countLeadingZeros v
(BS64, ICtz, Wasm.VI64 v) -> returnA -< int64 $ fromIntegral $ countTrailingZeros v
(BS64, IPopcnt, Wasm.VI64 v) -> returnA -< int64 $ fromIntegral $ popCount v
_ -> returnA -< error "iUnOp: cannot apply operator to arguements"
iBinOp _eCont = proc (bs,op,Value v1,Value v2) -> case (bs,op,v1,v2) of
(BS32, IAdd, Wasm.VI32 val1, Wasm.VI32 val2) -> returnA -< int32 $ val1 + val2
(BS32, ISub, Wasm.VI32 val1, Wasm.VI32 val2) -> returnA -< int32 $ val1 - val2
......@@ -89,9 +92,34 @@ instance (IsException (Exc Value) Value (ValueT Value c), ArrowChoice c) => IsVa
(BS32, IShrS, Wasm.VI32 val1, Wasm.VI32 val2) -> returnA -< int32 $ asWord32 $ asInt32 val1 `shiftR` (fromIntegral val2 `rem` 32)
(BS32, IRotl, Wasm.VI32 val1, Wasm.VI32 val2) -> returnA -< int32 $ val1 `rotateL` fromIntegral val2
(BS32, IRotr, Wasm.VI32 val1, Wasm.VI32 val2) -> returnA -< int32 $ val1 `rotateR` fromIntegral val2
-- (BS64, IAdd, Wasm.VI64 val1, Wasm.VI64 val2) -> returnA -< int64 $ val1 + val2
-- (BS64, IMul, Wasm.VI64 val1, Wasm.VI64 val2) -> returnA -< int64 $ val1 * val2
-- (BS64, ISub, Wasm.VI64 val1, Wasm.VI64 val2) -> returnA -< int64 $ val1 - val2
(BS64, IAdd, Wasm.VI64 val1, Wasm.VI64 val2) -> returnA -< int64 $ val1 + val2
(BS64, ISub, Wasm.VI64 val1, Wasm.VI64 val2) -> returnA -< int64 $ val1 - val2
(BS64, IMul, Wasm.VI64 val1, Wasm.VI64 val2) -> returnA -< int64 $ val1 * val2
(BS64, IDivU, Wasm.VI64 val1, Wasm.VI64 val2) ->
if val2 == 0
then trap -< "divide by 0"
else returnA -< int64 $ val1 `quot` val2
(BS64, IDivS, Wasm.VI64 val1, Wasm.VI64 val2) ->
if val2 == 0 || (val1 == 0x8000000000000000 && val2 == 0xFFFFFFFFFFFFFFFF)
then trap -< "divide by 0"
else returnA -< int64 $ asWord64 (asInt64 val1 `quot` asInt64 val2)
(BS64, IRemU, Wasm.VI64 val1, Wasm.VI64 val2) ->
if val2 == 0
then trap -< "divide by 0"
else returnA -< int64 $ val1 `rem` val2
(BS64, IRemS, Wasm.VI64 val1, Wasm.VI64 val2) ->
if val2 == 0
then trap -< "divide by 0"
else returnA -< int64 $ asWord64 (asInt64 val1 `rem` asInt64 val2)
(BS64, IAnd, Wasm.VI64 val1, Wasm.VI64 val2) -> returnA -< int64 $ val1 .&. val2
(BS64, IOr, Wasm.VI64 val1, Wasm.VI64 val2) -> returnA -< int64 $ val1 .|. val2
(BS64, IXor, Wasm.VI64 val1, Wasm.VI64 val2) -> returnA -< int64 $ val1 `xor` val2
(BS64, IShl, Wasm.VI64 val1, Wasm.VI64 val2) -> returnA -< int64 $ val1 `shiftL` (fromIntegral val2 `rem` 64)
(BS64, IShrU, Wasm.VI64 val1, Wasm.VI64 val2) -> returnA -< int64 $ val1 `shiftR` (fromIntegral val2 `rem` 64)
(BS64, IShrS, Wasm.VI64 val1, Wasm.VI64 val2) -> returnA -< int64 $ asWord64 $ asInt64 val1 `shiftR` (fromIntegral val2 `rem` 64)
(BS64, IRotl, Wasm.VI64 val1, Wasm.VI64 val2) -> returnA -< int64 $ val1 `rotateL` fromIntegral val2
(BS64, IRotr, Wasm.VI64 val1, Wasm.VI64 val2) -> returnA -< int64 $ val1 `rotateR` fromIntegral 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 -< int32 $ if val1 == val2 then 1 else 0
......@@ -104,8 +132,26 @@ instance (IsException (Exc Value) Value (ValueT Value c), ArrowChoice c) => IsVa
(BS32, ILeS, Wasm.VI32 val1, Wasm.VI32 val2) -> returnA -< int32 $ if asInt32 val1 <= asInt32 val2 then 1 else 0
(BS32, IGeU, Wasm.VI32 val1, Wasm.VI32 val2) -> returnA -< int32 $ if val1 >= val2 then 1 else 0
(BS32, IGeS, Wasm.VI32 val1, Wasm.VI32 val2) -> returnA -< int32 $ if asInt32 val1 >= asInt32 val2 then 1 else 0
(BS64, IEq, Wasm.VI64 val1, Wasm.VI64 val2) -> returnA -< int32 $ if val1 == val2 then 1 else 0
(BS64, INe, Wasm.VI64 val1, Wasm.VI64 val2) -> returnA -< int32 $ if val1 /= val2 then 1 else 0
(BS64, ILtU, Wasm.VI64 val1, Wasm.VI64 val2) -> returnA -< int32 $ if val1 < val2 then 1 else 0
(BS64, ILtS, Wasm.VI64 val1, Wasm.VI64 val2) -> returnA -< int32 $ if asInt64 val1 < asInt64 val2 then 1 else 0
(BS64, IGtU, Wasm.VI64 val1, Wasm.VI64 val2) -> returnA -< int32 $ if val1 > val2 then 1 else 0
(BS64, IGtS, Wasm.VI64 val1, Wasm.VI64 val2) -> returnA -< int32 $ if asInt64 val1 > asInt64 val2 then 1 else 0
(BS64, ILeU, Wasm.VI64 val1, Wasm.VI64 val2) -> returnA -< int32 $ if val1 <= val2 then 1 else 0
(BS64, ILeS, Wasm.VI64 val1, Wasm.VI64 val2) -> returnA -< int32 $ if asInt64 val1 <= asInt64 val2 then 1 else 0
(BS64, IGeU, Wasm.VI64 val1, Wasm.VI64 val2) -> returnA -< int32 $ if val1 >= val2 then 1 else 0
(BS64, IGeS, Wasm.VI64 val1, Wasm.VI64 val2) -> returnA -< int32 $ if asInt64 val1 >= asInt64 val2 then 1 else 0
_ -> returnA -< error "iRelOp: cannot apply binary operator to given arguments."
i32eqz = proc (Value v) -> case v of
(Wasm.VI32 val) -> returnA -< int32 $ if val == 0 then 1 else 0
_ -> returnA -< error "i32eqz: cannot apply operator to given argument."
i64eqz = proc (Value v) -> case v of
(Wasm.VI64 val) -> returnA -< int32 $ if val == 0 then 1 else 0
_ -> returnA -< error "i64eqz: cannot apply operator to given argument."
i32ifNeqz f g = proc (v, x) -> case v of
Value (Wasm.VI32 0) -> g -< x
Value (Wasm.VI32 _) -> f -< x
......@@ -121,8 +167,6 @@ instance (IsException (Exc Value) Value (ValueT Value c), ArrowChoice c) => IsVa
f32const = error "TODO: implement f32const"
f64const = error "TODO: implement f64const"
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"
......@@ -272,12 +316,6 @@ instantiateConcrete valMod = instantiate valMod Value toMem TableInst
-- val <- readIORef v
-- return $ GlobInst Mutable (Value val)
int32 :: Word32 -> Value
int32 = Value . Wasm.VI32
int64 :: Word64 -> Value
int64 = Value . Wasm.VI64
-- Conversion functions copied from https://github.com/SPY/haskell-wasm/blob/master/src/Language/Wasm/Interpreter.hs
asInt32 :: Word32 -> Int32
asInt32 w =
......
......@@ -19,11 +19,12 @@ import Control.Arrow.Transformer.State
import Control.Arrow.Transformer.Value
import Control.Arrow.Transformer.Writer
import qualified Data.Order as O
import Data.Profunctor
import GHC.Exts (Constraint)
class ArrowMemory addr bytes c | c -> addr, c -> bytes where
class ArrowMemory addr bytes sz c | c -> addr, c -> bytes, c -> sz where
type family Join y c :: Constraint
-- | memread f g (ma,addr,size,x)
......@@ -32,38 +33,38 @@ class ArrowMemory addr bytes c | c -> addr, c -> bytes where
-- | 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
memsize :: c Int sz
memgrow :: Join y c => c (sz,x) y -> c x y -> c (Int,sz,x) y
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
deriving instance (ArrowMemory addr bytes sz c) => ArrowMemory addr bytes sz (ValueT val2 c)
deriving instance (Arrow c, Profunctor c, ArrowMemory addr bytes sz c) => ArrowMemory addr bytes sz (CE.ExceptT e c)
deriving instance (O.Complete e, Arrow c, Profunctor c, ArrowMemory addr bytes sz c) => ArrowMemory addr bytes sz (AE.ExceptT e c)
instance (Arrow c, Profunctor c, Monad f, ArrowMemory addr bytes sz c) => ArrowMemory addr bytes sz (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)
-- 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
memread (unlift a1) (unlift a2)
memstore a1 a2 = lift $
memstore (unlift a1) (unlift a2)-- >>^ moveIn
-- where moveIn (m, ey) = fmap ((,) m) ey
memstore (unlift a1) (unlift a2)
memsize = lift' memsize
memgrow a1 a2 = lift $
memgrow (unlift a1) (unlift a2)
instance (Arrow c, ArrowMemory addr bytes c) => ArrowMemory addr bytes (StateT s c) where
instance (Arrow c, Profunctor c, ArrowMemory addr bytes sz c) => ArrowMemory addr bytes sz (StateT s c) where
type Join y (StateT s c) = Join (s,y) c
memread a1 a2 = lift $ proc (s, (ma,addr,i,x)) -> do
memread (proc (bytes,(s,x)) -> unlift a1 -< (s, (bytes,x)))
(unlift a2)
-< (ma,addr,i,(s,x))
memstore a1 a2 = lift $ proc (s, (ma,addr,bytes,x)) -> do
memstore (unlift a1) (unlift a2) -< (ma,addr,bytes,(s,x))
memsize = lift' memsize
memgrow a1 a2 = lift $ proc (s, (ma,sz,x)) -> do
memgrow (proc (sz,(s,x)) -> unlift a1 -< (s, (sz,x)))
(unlift a2)
-< (ma,sz,(s,x))
instance (Arrow c, ArrowMemory addr bytes c) => ArrowMemory addr bytes (ReaderT r c) where
instance (Arrow c, Profunctor c, ArrowMemory addr bytes sz c) => ArrowMemory addr bytes sz (ReaderT r c) where
type Join y (ReaderT r c) = Join y c
memread a1 a2 = lift $ proc (r, (ma,addr,i,x)) ->
memread (proc (bytes, (r,x)) -> unlift a1 -< (r, (bytes,x)))
......@@ -71,7 +72,14 @@ instance (Arrow c, ArrowMemory addr bytes c) => ArrowMemory addr bytes (ReaderT
-< (ma,addr,i,(r,x))
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
type Join x (WriterT r c) = Join (r,x) c
memread = error "TODO: Implement WriterT.memread"
memstore = error "TODO: Implement WriterT.memstore"
memsize = lift' memsize
memgrow a1 a2 = lift $ proc (r, (ma,sz,x)) ->
memgrow (proc (sz, (r,x)) -> unlift a1 -< (r, (sz,x)))
(unlift a2)
-< (ma,sz,(r,x))
instance (Arrow c, Profunctor c, Monoid r, ArrowMemory addr bytes sz c) => ArrowMemory addr bytes sz (WriterT r c) where
type Join x (WriterT r c) = Join (r,x) c
memread = error "TODO: implement WriterT.memread"
memstore = error "TODO: implement WriterT.memstore"
memsize = lift' memsize
memgrow = error "TODO: implement WriterT.memgrow"
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Arrow.Size where
import Control.Arrow
import Control.Arrow.Trans
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.State
import Control.Arrow.Transformer.Value
import Control.Arrow.Transformer.Writer
import qualified Data.Order as O
import Data.Profunctor
class ArrowSize v sz c | c -> v, c -> sz where
valToSize :: c v sz
sizeToVal :: c sz v
deriving instance (ArrowSize v sz c) => ArrowSize v sz (ValueT v2 c)
deriving instance (Arrow c, Profunctor c, ArrowSize v sz c) => ArrowSize v sz (CE.ExceptT e c)
deriving instance (O.Complete e, Arrow c, Profunctor c, ArrowSize v sz c) => ArrowSize v sz (AE.ExceptT e c)
instance (Arrow c, Profunctor c, Monad f, ArrowSize v sz c) => ArrowSize v sz (KleisliT f c) where
valToSize = lift' valToSize
sizeToVal = lift' sizeToVal
instance (Arrow c, Profunctor c, ArrowSize v sz c) => ArrowSize v sz (StateT s c) where
valToSize = lift' valToSize
sizeToVal = lift' sizeToVal
instance (Arrow c, Profunctor c, ArrowSize v sz c) => ArrowSize v sz (ReaderT s c) where
valToSize = lift' valToSize
sizeToVal = lift' sizeToVal
instance (Arrow c, Profunctor c, Monoid s, ArrowSize v sz c) => ArrowSize v sz (WriterT s c) where
valToSize = lift' valToSize
sizeToVal = lift' sizeToVal
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Arrow.Transformer.Abstract.Logger where
import Control.Category
import Control.Arrow
import Control.Arrow.Const
import Control.Arrow.DebuggableStack
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
import Control.Arrow.Order
import Control.Arrow.Reader
import Control.Arrow.Stack
import Control.Arrow.Trans
import Control.Arrow.Serialize
import Control.Arrow.State
import Control.Arrow.Transformer.State
import Control.Arrow.GlobalState
import Control.Arrow.Writer
import Control.Arrow.WasmFrame
import Data.Abstract.Powerset
import Data.Profunctor
newtype LoggerT v c x y = LoggerT (StateT (Pow [v]) c x y)
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowTrans, ArrowLift, ArrowRun,
ArrowConst r, ArrowReader r, ArrowFail e, ArrowExcept e,
ArrowGlobalState v1 m, ArrowFrame fd v1, ArrowMemory addr bytes,
ArrowMemAddress v1 n addr, ArrowSerialize v1 bytes valTy loadTy storeTy,
ArrowMemSizable v1, ArrowWriter w, ArrowStack s, ArrowDebuggableStack s, ArrowJoin)
instance (ArrowChoice c, Profunctor c) => ArrowLogger v (LoggerT v c) where
log = LoggerT $ proc logVal -> do
state <- get -< ()
put -< fmap ((:) logVal) state
deriving instance (Arrow c, Profunctor c, ArrowComplete (Pow [v],y) c) => ArrowComplete y (LoggerT v c)
instance ArrowFix (Underlying (LoggerT v c) x y) => ArrowFix (LoggerT v c x y) where
type Fix (LoggerT v c x y) = Fix (Underlying (LoggerT v c) x y)--StackT v (Fix c ([v],x) ([v],y))
......@@ -9,7 +9,8 @@
module Control.Arrow.Transformer.Abstract.Memory where
import UnitAnalysisValue
import Abstract (BaseValue(..))
import UnitAnalysisValue (Value(..),valueI32)
import Control.Arrow
import Control.Arrow.Const
......@@ -18,10 +19,10 @@ import Control.Arrow.Fail
import Control.Arrow.Fix
import Control.Arrow.MemAddress
import Control.Arrow.Memory
import Control.Arrow.MemSizable
import Control.Arrow.Order
import Control.Arrow.Reader
import Control.Arrow.Serialize
import Control.Arrow.Size
import Control.Arrow.Stack
import Control.Arrow.StaticGlobalState
import Control.Arrow.Store
......@@ -43,17 +44,22 @@ instance ArrowTrans MemoryT where
-- lift' :: c x y -> MemoryT v c x y
lift' = MemoryT
instance (Profunctor c, ArrowChoice c) => ArrowMemory () () (MemoryT c) where
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)
memsize = arr $ const ()
memgrow sCont eCont = proc (_,(),x) -> (sCont -< ((),x)) <> (eCont -< x)
instance (ArrowChoice c, Profunctor c) => ArrowSize Value () (MemoryT c) where
valToSize = proc (Value v) -> case v of
(VI32 _) -> returnA -< ()
_ -> returnA -< error "valToSize: arguments needs to be an i32 integer."
sizeToVal = proc () -> returnA -< valueI32
instance (Arrow c, Profunctor c) => ArrowMemAddress base off () (MemoryT c) where
memaddr = arr $ const ()
instance ArrowMemSizable Value (MemoryT c) where
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)
......
......@@ -23,6 +23,7 @@ import Control.Arrow.Memory
import Control.Arrow.Order
import Control.Arrow.Reader
import Control.Arrow.Serialize
import Control.Arrow.Size
import Control.Arrow.Stack
import Control.Arrow.State
import Control.Arrow.StaticGlobalState
......@@ -42,7 +43,7 @@ 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, ArrowStaticGlobalState v, ArrowReader m, ArrowTable v,
ArrowMemory addr bytes, ArrowJoin)
ArrowMemory addr bytes sz, ArrowSize v sz, ArrowJoin)
instance ArrowTrans SerializeT where
lift' = SerializeT
......
......@@ -9,6 +9,7 @@
module Control.Arrow.Transformer.Concrete.Memory where
import Concrete
import Data (pageSize)
import Control.Arrow
import Control.Arrow.Const
......@@ -17,9 +18,9 @@ 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.Size
import Control.Arrow.Stack
import Control.Arrow.State
import Control.Arrow.StaticGlobalState
......@@ -51,7 +52,7 @@ instance ArrowTrans MemoryT where
-- 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
instance (ArrowChoice c, Profunctor c) => ArrowMemory Word32 (Vector Word8) Int (MemoryT c) where
type Join y (MemoryT c) = ()
memread (MemoryT sCont) (MemoryT eCont) = MemoryT $ proc (memIndex,addr,size,x) -> do
let addrI = fromIntegral addr
......@@ -63,30 +64,45 @@ instance (ArrowChoice c, Profunctor c) => ArrowMemory Word32 (Vector Word8) (Mem
sCont -< (bytes,x)
else
eCont -< x
-- case (addrI+size <= length vec) of
-- True -> do
-- let content = Vec.slice addrI size vec
-- sCont -< (content,x)
-- False -> do
-- eCont -< x
memstore (MemoryT sCont) (MemoryT eCont) = MemoryT $ proc (index,addr, content, x) -> do
let addrI = fromIntegral addr
mems <- get -< ()
let (MemInst maxSize vec) = mems ! index
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)
put -< mems // [(index,newMem)]
sCont -< x
False -> do
eCont -< x
instance ArrowMemSizable Value (MemoryT c) where
memsize = error "TODO: implement MemoryT.memsize"
memgrow = error "TODO: implement MemoryT.memgrow"
memstore (MemoryT sCont) (MemoryT eCont) = MemoryT $ proc (memIndex, addr, content, x) -> do
let addrI = fromIntegral addr
mems <- get -< ()
let (MemInst maxSize vec) = mems ! memIndex
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)
put -< mems // [(memIndex,newMem)]
sCont -< x
False -> do
eCont -< x
memsize = MemoryT $ proc memIndex -> do
mems <- get -< ()
let (MemInst _ vec) = mems ! memIndex
let size = length vec
returnA -< size `quot` pageSize
memgrow (MemoryT _) (MemoryT eCont) = MemoryT $ proc (_,_,x) -> do
-- TODO: allow to grow the memory
eCont -< x
-- mems <- get -< ()
-- let (MemInst maxSize vec) = mems ! memIndex
-- let oldSize = (length vec) `quot` pageSize
-- if (oldSize + sz > maxSize)
-- then eCont -< x
-- -- we don't allow to grow memory so far -> TODO
-- else eCont -< x
-- -- TODO: grow memory
-- -- return old size
-- --sCont -< (oldSize,x)
instance (ArrowChoice c, Profunctor c) => ArrowSize Value Int (MemoryT c) where
valToSize = proc (Value v) -> case v of
(Wasm.VI32 val) -> returnA -< fromIntegral val
_ -> returnA -< error "valToSize: arguments needs to be an i32 integer"
sizeToVal = proc sz -> returnA -< int32 $ fromIntegral sz
instance (Arrow c, Profunctor c) => ArrowMemAddress Value Natural Word32 (MemoryT c) where
memaddr = proc (Value (Wasm.VI32 base), off) -> returnA -< (base + fromIntegral off)
......
......@@ -20,10 +20,10 @@ import Control.Arrow.Fix
--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
import Control.Arrow.Size
import Control.Arrow.Stack
import Control.Arrow.State
import Control.Arrow.StaticGlobalState
......@@ -40,9 +40,9 @@ import Data.Profunctor
newtype StackT v c x y = StackT (StateT (JoinList v) c x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowTrans,ArrowLift,ArrowRun,
ArrowConst r, ArrowReader r, ArrowFail e, ArrowExcept e, ArrowWriter w,
ArrowStaticGlobalState v1, ArrowFrame fd v1, ArrowMemory addr bytes,
ArrowStaticGlobalState v1, ArrowFrame fd v1, ArrowMemory addr bytes sz,
ArrowMemAddress v1 n addr, ArrowSerialize v1 bytes valTy loadTy storeTy,
ArrowMemSizable v1, ArrowTable v1)
ArrowSize v1 sz, ArrowTable v1)
deriving instance (ArrowComplete (JoinList v, y) c) => ArrowComplete y (StackT v c)
......
......@@ -19,10 +19,10 @@ import Control.Arrow.Fail
import Control.Arrow.Fix
import Control.Arrow.MemAddress
import Control.Arrow.Memory
import Control.Arrow.MemSizable
import Control.Arrow.Order
import Control.Arrow.Reader
import Control.Arrow.Serialize
import Control.Arrow.Size
import Control.Arrow.Stack
import Control.Arrow.State
import Control.Arrow.StaticGlobalState
......@@ -42,8 +42,8 @@ import Data.Profunctor
newtype StaticGlobalStateT v c x y = StaticGlobalStateT (StateT (StaticGlobalState v) c x y)
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowLift, ArrowReader r,
ArrowFail e, ArrowExcept e, ArrowConst r, ArrowRun, ArrowFrame fd val,
ArrowStack st, ArrowSerialize val dat valTy datDecTy datEncTy, ArrowMemory addr bytes,
ArrowMemSizable val, ArrowMemAddress base off addr, ArrowTable v1, ArrowJoin)
ArrowStack st, ArrowSerialize val dat valTy datDecTy datEncTy, ArrowMemory addr bytes sz,
ArrowSize val sz, ArrowMemAddress base off addr, ArrowTable v1, ArrowJoin)
instance (ArrowState s c) => ArrowState s (StaticGlobalStateT v c) where
get = error "TODO: implement StaticGlobalStateT.get"
......
......@@ -33,6 +33,9 @@ import Language.Wasm.Validate (ValidModule)
import GHC.Generics (Generic)
import GHC.Exts
pageSize :: Int
pageSize = 64 * 1024
instance (Show v) => Pretty (Vector v) where pretty = viaShow
instance (Hashable v) => Hashable (Vector v) where
......
......@@ -29,9 +29,9 @@ import Control.Arrow.Fail as Fail
import Control.Arrow.Fix
import Control.Arrow.MemAddress
import Control.Arrow.Memory as Mem
import Control.Arrow.MemSizable
import Control.Arrow.Reader
import Control.Arrow.Serialize
import Control.Arrow.Size
import Control.Arrow.Stack
import Control.Arrow.Table
import qualified Control.Arrow.Utils as Arr
......@@ -96,11 +96,11 @@ type FrameData = (Natural, ModuleInstance)
type ArrowWasmMemory addr bytes v c =
( ArrowMemory addr bytes c,
type ArrowWasmMemory addr bytes sz v c =
( ArrowMemory addr bytes sz c,
ArrowMemAddress v Natural addr c,
ArrowSize v sz c,
ArrowSerialize v bytes ValueType LoadType StoreType c,
ArrowMemSizable v c,
Show addr, Show bytes)
type ArrowStaticComponents v c =
......@@ -109,9 +109,9 @@ type ArrowStaticComponents v c =
ArrowFrame FrameData v c,
ArrowReader LabelArities c)
type ArrowDynamicComponents v addr bytes exc e c =
type ArrowDynamicComponents v addr bytes sz exc e c =
( ArrowTable v c,
ArrowWasmMemory addr bytes v c,
ArrowWasmMemory addr bytes sz v c,
IsVal v c,
ArrowExcept exc c, IsException exc v c,
ArrowFail e c, IsString e,
......@@ -160,7 +160,7 @@ class Show v => IsVal v c | c -> v where
-- argument [v]: arguments going to be passed to the function