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

wasm core testsuite

parent e8ae0cea
Pipeline #152687 failed with stages
in 81 minutes and 43 seconds
[submodule "wasm/test/spec"]
path = wasm/test/spec
url = https://github.com/WebAssembly/testsuite.git
......@@ -19,5 +19,5 @@ extra-deps:
- git: https://github.com/svenkeidel/husk-scheme/
commit: ca59598b11065eb29a45af7ffca27fc42a49abe5
- git: https://gitlab.rlp.net/plmz/external/haskell-wasm.git
commit: 79a51ce931b183267ab4ac483d7dbaa724df7863
commit: cee605e726b74c1125686839591251158f283216
- knob-0.1.1
......@@ -41,3 +41,4 @@ tests:
- sturdy-wasm
- prettyprinter
- fgl
- directory
......@@ -18,6 +18,8 @@ import GHC.Generics
newtype Value = Value Wasm.Value deriving (Show, Eq)
instance Pretty Value where
pretty = viaShow
type Memories = Vector MemInst
type Tables = Vector TableInst
......
......@@ -22,6 +22,7 @@ import Control.Arrow
import qualified Control.Arrow.Trans as Trans
import Control.Arrow.Except
import Control.Arrow.Fail as Fail
import Control.Arrow.Fix
import Control.Arrow.Transformer.JumpTypes
import Control.Arrow.Transformer.Stack
......@@ -35,13 +36,21 @@ import Control.Arrow.Transformer.Concrete.Memory
import Control.Arrow.Transformer.Concrete.Serialize
import Control.Arrow.Transformer.Concrete.Table
import qualified Control.Monad.Primitive as Primitive
import Data.Concrete.Error
import qualified Data.Function as Function
import Data.IORef (writeIORef)
import qualified Data.Primitive.ByteArray as ByteArray
import Data.Text.Lazy (Text)
import Data.Text.Prettyprint.Doc (pretty, hsep)
import qualified Data.Vector as Vec
import Data.Word
import Data.Bits
import Debug.Trace
import Language.Wasm.FloatUtils
import Language.Wasm.Interpreter (ModuleInstance, asInt32,asInt64,asWord32,asWord64,nearest,
floatFloor, doubleFloor, floatCeil, doubleCeil,
......@@ -52,6 +61,7 @@ import Language.Wasm.Validate (ValidModule)
import Numeric.IEEE (copySign)
import Text.Printf
--import Prettyprinter (pretty, hsep)
--trap :: IsException (Exc v) v c => c String x
--trap = throw <<< exception <<^ Trap
......@@ -68,10 +78,26 @@ instance (ArrowChoice c, ArrowFail Err c, Fail.Join Value c) => IsVal Value (Val
(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
(BS32, IExtend8S, Wasm.VI32 v) -> do
let half = v .&. 0xFF
returnA -< int32 $ if half >= 0x80 then asWord32 (fromIntegral half - 0x100) else half
(BS32, IExtend16S, Wasm.VI32 v) -> do
let half = v .&. 0xFFFF
returnA -< int32 $ if half >= 0x8000 then asWord32 (fromIntegral half - 0x10000) else half
(BS32, IExtend32S, Wasm.VI32 v) -> returnA -< int32 v
(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"
(BS64, IExtend8S, Wasm.VI64 v) -> do
let half = v .&. 0xFF
returnA -< int64 $ if half >= 0x80 then asWord64 (fromIntegral half - 0x100) else half
(BS64, IExtend16S, Wasm.VI64 v) -> do
let quart = v .&. 0xFFFF
returnA -< int64 $ if quart >= 0x8000 then asWord64 (fromIntegral quart - 0x10000) else quart
(BS64, IExtend32S, Wasm.VI64 v) -> do
let half = v .&. 0xFFFFFFFF
returnA -< int64 $ if half >= 0x80000000 then asWord64 (fromIntegral half - 0x100000000) else half
_ -> returnA -< error $ "iUnOp: cannot apply operator " ++ show op ++ " to arguement " ++ show v0 ++ " with " ++ show bs ++ "."
iBinOp = 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
......@@ -95,9 +121,9 @@ instance (ArrowChoice c, ArrowFail Err c, Fail.Join Value c) => IsVal Value (Val
(BS32, IAnd, Wasm.VI32 val1, Wasm.VI32 val2) -> returnA -< int32 $ val1 .&. val2
(BS32, IOr, Wasm.VI32 val1, Wasm.VI32 val2) -> returnA -< int32 $ val1 .|. val2
(BS32, IXor, Wasm.VI32 val1, Wasm.VI32 val2) -> returnA -< int32 $ val1 `xor` val2
(BS32, IShl, Wasm.VI32 val1, Wasm.VI32 val2) -> returnA -< int32 $ val1 `shiftL` (fromIntegral val2 `rem` 32)
(BS32, IShrU, Wasm.VI32 val1, Wasm.VI32 val2) -> returnA -< int32 $ val1 `shiftR` (fromIntegral val2 `rem` 32)
(BS32, IShrS, Wasm.VI32 val1, Wasm.VI32 val2) -> returnA -< int32 $ asWord32 $ asInt32 val1 `shiftR` (fromIntegral val2 `rem` 32)
(BS32, IShl, Wasm.VI32 val1, Wasm.VI32 val2) -> returnA -< int32 $ val1 `shiftL` fromIntegral (val2 `rem` 32)
(BS32, IShrU, Wasm.VI32 val1, Wasm.VI32 val2) -> returnA -< int32 $ val1 `shiftR` fromIntegral (val2 `rem` 32)
(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
......@@ -123,9 +149,9 @@ instance (ArrowChoice c, ArrowFail Err c, Fail.Join Value c) => IsVal Value (Val
(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, 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."
......@@ -241,27 +267,91 @@ instance (ArrowChoice c, ArrowFail Err c, Fail.Join Value c) => IsVal Value (Val
if isNaN val || isInfinite val || val >= 2^64 || val <= -1
then trap -< errorTrunc
else returnA -< int64 $ truncate val
_ -> returnA -< error "iTruncFU: cannot apply operator to given argument."
_ -> returnA -< error errorTrunc
iTruncFS = proc (bs1,bs2,x@(Value v)) -> do
let errorTrunc = printf "iTruncFS: truncation operator from %s to %s failed on %s." (show bs1) (show bs2) (show x)
case (bs1,bs2,v) of
(BS32, BS32, Wasm.VF32 val) ->
if isNaN val || isInfinite val || val >= 2^31 || val < -2^31
if isNaN val || isInfinite val || val >= 2^31 || val < -2^31 - 1
then trap -< errorTrunc
else returnA -< int32 $ truncate val
(BS32, BS64, Wasm.VF64 val) ->
if isNaN val || isInfinite val || val >= 2^31 || val < -2^31
if isNaN val || isInfinite val || val >= 2^31 || val <= -2^31 - 1
then trap -< errorTrunc
else returnA -< int32 $ truncate val
(BS64, BS32, Wasm.VF32 val) ->
if isNaN val || isInfinite val || val >= 2^63 || val < -2^63
if isNaN val || isInfinite val || val >= 2^63 || val < -2^63 - 1
then trap -< errorTrunc
else returnA -< int64 $ truncate val
(BS64, BS64, Wasm.VF64 val) ->
if isNaN val || isInfinite val || val >= 2^63 || val < -2^63
if isNaN val || isInfinite val || val >= 2^63 || val < -2^63 - 1
then trap -< errorTrunc
else returnA -< int64 $ truncate val
_ -> returnA -< error "iTruncFS: cannot apply operator to given argument."
_ -> returnA -< error errorTrunc
iTruncSatFU = proc (bs1,bs2,x@(Value v)) -> do
let errorTrunc = printf "iTruncSatFU: truncation operator from %s to %s failed on %s." (show bs1) (show bs2) (show x)
case (bs1,bs2,v) of
(BS32, BS32, Wasm.VF32 val) ->
if val <= -1 || isNaN val
then returnA -< int32 0
else if val >= 2^32
then returnA -< int32 0xffffffff
else returnA -< int32 $ truncate val
(BS32, BS64, Wasm.VF64 val) ->
if val <= -1 || isNaN val
then returnA -< int32 0
else if val >= 2^32
then returnA -< int32 0xffffffff
else returnA -< int32 $ truncate val
(BS64, BS32, Wasm.VF32 val) ->
if val <= -1 || isNaN val
then returnA -< int64 0
else if val >= 2^64
then returnA -< int64 0xffffffffffffffff
else returnA -< int64 $ truncate val
(BS64, BS64, Wasm.VF64 val) ->
if val <= -1 || isNaN val
then returnA -< int64 0
else if val >= 2^64
then returnA -< int64 0xffffffffffffffff
else returnA -< int64 $ truncate val
_ -> returnA -< error errorTrunc
iTruncSatFS = proc (bs1,bs2,x@(Value v)) -> do
let errorTrunc = printf "iTruncSatFS: truncation operator from %s to %s failed on %s." (show bs1) (show bs2) (show x)
case (bs1,bs2,v) of
(BS32, BS32, Wasm.VF32 val) ->
if isNaN val
then returnA -< int32 0
else if val >= 2^31
then returnA -< int32 0x7fffffff
else if val <= -2^31 - 1
then returnA -< int32 0x80000000
else returnA -< int32 $ asWord32 $ truncate val
(BS32, BS64, Wasm.VF64 val) ->
if isNaN val
then returnA -< int32 0
else if val >= 2^31
then returnA -< int32 0x7fffffff
else if val <= -2^31 - 1
then returnA -< int32 0x80000000
else returnA -< int32 $ asWord32 $ truncate val
(BS64, BS32, Wasm.VF32 val) ->
if isNaN val
then returnA -< int64 0
else if val >= 2^63
then returnA -< int64 0x7fffffffffffffff
else if val <= -2^63 - 1
then returnA -< int64 0x8000000000000000
else returnA -< int64 $ asWord64 $ truncate val
(BS64, BS64, Wasm.VF64 val) ->
if isNaN val
then returnA -< int64 0
else if val >= 2^63
then returnA -< int64 0x7fffffffffffffff
else if val <= -2^63 - 1
then returnA -< int64 0x8000000000000000
else returnA -< int64 $ asWord64 $ truncate val
_ -> returnA -< error errorTrunc
i64ExtendSI32 = proc (Value v) -> case v of
(Wasm.VI32 val) -> returnA -< int64 $ asWord64 $ fromIntegral $ asInt32 val
_ -> returnA -< error "i64ExtendSI32: cannot apply operator to given argument."
......@@ -322,6 +412,7 @@ invokeExported :: StaticGlobalState Value
-> Result
invokeExported staticS mem tab modInst funcName args =
let ?fixpointAlgorithm = Function.fix in
--let ?fixpointAlgorithm = fixpointAlgorithm (trace p1 p2) in
Trans.run
(Generic.invokeExported ::
ValueT Value
......@@ -335,6 +426,36 @@ invokeExported staticS mem tab modInst funcName args =
(FrameT FrameData Value
(FailureT Err
(->)))))))))) (Text, [Value]) [Value]) (JoinVector Vec.empty,((0,modInst),(tab,(mem,(staticS,([],([],(funcName,args))))))))
where
p1 (locals,(_,(_,(_,(_,(stack,(_,instr))))))) = hsep [pretty stack, pretty locals, pretty instr]
p2 (Success (_, (_,(_,(_, Success (stack,_)))))) = pretty stack
p2 _ = pretty "Fail"
invokeExported' :: Wasm.Store -> ModuleInstance -> Text -> [Wasm.Value] -> IO (Maybe [Wasm.Value])
invokeExported' store modInst funcName wasmArgs = do
(gs, ms, ts) <- storeToGlobalState store Value toMem TableInst
let res = invokeExported gs ms ts modInst funcName (map Value wasmArgs)
case res of
(Fail _) -> return Nothing
(Success (_,(_,(newMems,(StaticGlobalState _ sturdyGlobs,Success (_,funcRes)))))) -> do
let storeMems = Wasm.memInstances store
let wasmGlobs = Wasm.globalInstances store
Vec.zipWithM_ (\(MemInst _ vec) (Wasm.MemoryInstance _ oldMem) -> do
newMem <- toByteArray vec
writeIORef oldMem newMem) newMems storeMems
Vec.zipWithM_ (\(GlobInst _ (Value v)) g ->
case g of
Wasm.GIMut _ ref -> writeIORef ref v
_ -> return ()) sturdyGlobs wasmGlobs
return $ Just (map (\(Value x) -> x) funcRes)
_ -> error "cannot happen in valid module"
where
toMem size lst = MemInst size (Vec.fromList lst)
toByteArray :: Vec.Vector Word8 -> IO (ByteArray.MutableByteArray (Primitive.PrimState IO))
toByteArray vec = do
mem <- ByteArray.newByteArray (Vec.length vec)
Vec.imapM_ (ByteArray.writeByteArray mem) vec
return mem
instantiateConcrete :: ValidModule -> IO (Either String (ModuleInstance, StaticGlobalState Value, Memories, Tables))
......
......@@ -32,7 +32,7 @@ import Control.Arrow.WasmFrame
import Control.Arrow.Transformer.State
import Control.Category
import Control.Category (Category)
import Data.Profunctor
import Data.Vector (Vector,(!),(//))
......@@ -53,7 +53,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) Int (MemoryT c) where
instance (ArrowChoice c, Profunctor c) => ArrowMemory Word64 (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
......@@ -85,9 +85,17 @@ instance (ArrowChoice c, Profunctor c) => ArrowMemory Word32 (Vector Word8) Int
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
memgrow (MemoryT sCont) (MemoryT eCont) = MemoryT $ proc (memIndex,delta,x) -> do
mems <- get -< ()
let (MemInst maxSize vec) = mems ! memIndex
let size = length vec `quot` pageSize
let isOk = maybe True ((>= (size+delta)) . fromIntegral) maxSize
if isOk
then do
let deltaVec = Vec.replicate (delta*pageSize) 0
put -< mems // [(memIndex, MemInst maxSize (vec Vec.++ deltaVec))]
sCont -< (size,x)
else eCont -< x
instance (ArrowChoice c, Profunctor c) => ArrowSize Value Int (MemoryT c) where
valToSize = proc (Value v) -> case v of
......@@ -95,8 +103,8 @@ instance (ArrowChoice c, Profunctor c) => ArrowSize Value Int (MemoryT c) where
_ -> returnA -< error "valToSize: arguments needs to be an i32 integer"
sizeToVal = proc sz -> returnA -< int32 $ fromIntegral sz
instance (Arrow c, Profunctor c) => ArrowEffectiveAddress Value Natural Word32 (MemoryT c) where
effectiveAddress = proc (Value (Wasm.VI32 base), off) -> returnA -< (base + fromIntegral off)
instance (Arrow c, Profunctor c) => ArrowEffectiveAddress Value Natural Word64 (MemoryT c) where
effectiveAddress = proc (Value (Wasm.VI32 base), off) -> returnA -< (fromIntegral base + fromIntegral off)
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)
......@@ -35,6 +35,7 @@ import Data.Vector (Vector)
import qualified Data.Vector as Vec
import Data.Word
import Language.Wasm.FloatUtils
import qualified Language.Wasm.Interpreter as Wasm
import Language.Wasm.Structure hiding (exports, Const)
......@@ -44,22 +45,80 @@ newtype SerializeT c x y = SerializeT (c x y)
ArrowStack st, ArrowState s, ArrowGlobals v, ArrowFunctions, ArrowReader m, ArrowTable v)
instance (Profunctor c, ArrowChoice c) => ArrowSerialize Value (Vector Word8) ValueType LoadType StoreType (SerializeT c) where
decode sCont = proc (dat, decTy, valTy, x) -> do
case (valTy,decTy) of
(I32,L_I32) -> do
let val = Vec.foldr (\w8 w32 -> (w32 `shiftL` 4) + fromIntegral w8) (fromIntegral $ Vec.last dat) dat
let result = Value $ Wasm.VI32 val
sCont -< (result, x)
_ -> returnA -< error "decode: do not support type"
encode sCont = proc (Value val, valTy, datEncTy, x) -> do
case (val, valTy, datEncTy) of
(Wasm.VI32 v, I32, S_I32) -> do
let vec = Vec.generate 4 (byte v)
sCont -< (vec, x)
_ -> returnA -< error "encode: do not support type"
decode sCont = proc (dat, decTy, valTy, x) -> do
case (valTy,decTy) of
(I32,L_I32) -> sCont -< (toVal Wasm.VI32 dat, x)
(I64,L_I64) -> sCont -< (toVal Wasm.VI64 dat, x)
(F32, L_F32) -> do
let i = toIntegral dat
sCont -< (Value $ Wasm.VF32 $ wordToFloat i, x)
(F64, L_F64) -> do
let i = toIntegral dat
sCont -< (Value $ Wasm.VF64 $ wordToDouble i, x)
(I32, L_I8S) -> do
let i = toIntegral dat :: Word8
let signedI = Wasm.asWord32 $ if i >= 128 then (-1) * fromIntegral (0xFF - i + 1) else fromIntegral i
sCont -< (Value $ Wasm.VI32 signedI, x)
(I32, L_I8U) -> sCont -< (toVal Wasm.VI32 dat, x)
(I32, L_I16S) -> do
let i = toIntegral dat :: Word16
let signedI = Wasm.asWord32 $ if i >= 2^(15::Int) then (-1) * fromIntegral (0xFFFF - i + 1) else fromIntegral i
sCont -< (Value $ Wasm.VI32 signedI, x)
(I32, L_I16U) -> sCont -< (toVal Wasm.VI32 dat, x)
(I64, L_I8S) -> do
let i = toIntegral dat :: Word8
let signedI = Wasm.asWord64 $ if i >= 128 then (-1) * fromIntegral (0xFF - i + 1) else fromIntegral i
sCont -< (Value $ Wasm.VI64 signedI, x)
(I64, L_I8U) -> sCont -< (toVal Wasm.VI64 dat, x)
(I64, L_I16S) -> do
let i = toIntegral dat :: Word16
let signedI = Wasm.asWord64 $ if i >= 2^(15::Int) then (-1) * fromIntegral (0xFFFF - i + 1) else fromIntegral i
sCont -< (Value $ Wasm.VI64 signedI, x)
(I64, L_I16U) -> sCont -< (toVal Wasm.VI64 dat, x)
(I64, L_I32S) -> do
let i = toIntegral dat :: Word32
let signedI = Wasm.asWord64 $ fromIntegral $ Wasm.asInt32 i
sCont -< (Value $ Wasm.VI64 signedI, x)
(I64, L_I32U) -> sCont -< (toVal Wasm.VI64 dat, x)
_ -> returnA -< error "decode: do not support type"
where
toIntegral :: (Integral i, Bits i) => Vector Word8 -> i
toIntegral bytes = Vec.foldr (\a b -> (b `shiftL` 8) + fromIntegral a) (fromIntegral (0::Int)) bytes
toVal :: (Integral i, Bits i) => (i -> Wasm.Value) -> Vector Word8 -> Value
toVal c bytes = Value $ c $ toIntegral bytes
encode sCont = proc (Value val, valTy, datEncTy, x) -> do
case (val, valTy, datEncTy) of
(Wasm.VI32 v, I32, S_I32) -> do
let vec = Vec.generate 4 (byte v)
sCont -< (vec, x)
(Wasm.VI64 v, I64, S_I64) -> do
let vec = Vec.generate 8 (byte v)
sCont -< (vec, x)
(Wasm.VF32 v, F32, S_F32) -> do
let vec = Vec.generate 4 (byte (floatToWord v))
sCont -< (vec, x)
(Wasm.VF64 v, F64, S_F64) -> do
let vec = Vec.generate 8 (byte (doubleToWord v))
sCont -< (vec, x)
(Wasm.VI32 v, I32, S_I8) -> do
let vec = Vec.generate 1 (byte v)
sCont -< (vec, x)
(Wasm.VI32 v, I32, S_I16) -> do
let vec = Vec.generate 2 (byte v)
sCont -< (vec, x)
(Wasm.VI64 v, I64, S_I8) -> do
let vec = Vec.generate 1 (byte v)
sCont -< (vec, x)
(Wasm.VI64 v, I64, S_I16) -> do
let vec = Vec.generate 2 (byte v)
sCont -< (vec, x)
(Wasm.VI64 v, I64, S_I32) -> do
let vec = Vec.generate 4 (byte v)
sCont -< (vec, x)
_ -> returnA -< error "encode: do not support type"
where byte :: (Integral i, Bits i) => i -> Int -> Word8
byte v i = fromIntegral $ (v `shiftR` (i*8)) .&. 0xFF
where byte :: (Integral i, Bits i) => i -> Int -> Word8
byte v i = fromIntegral $ (v `shiftR` (i*8)) .&. 0xFF
instance ArrowTrans SerializeT where
lift' = SerializeT
......
......@@ -47,9 +47,8 @@ newtype StaticGlobalStateT v c x y = StaticGlobalStateT (StateT (StaticGlobalSta
ArrowSize val sz, ArrowEffectiveAddress base off addr, ArrowTable v1, ArrowJoin)
instance (ArrowState s c) => ArrowState s (StaticGlobalStateT v c) where
get = error "TODO: implement StaticGlobalStateT.get"
put = error "TODO: implement StaticGlobalStateT.put"
-- TODO
get = lift' get
put = lift' put
instance ArrowTrans (StaticGlobalStateT v) where
lift' a = StaticGlobalStateT (lift' a)
......@@ -74,7 +73,7 @@ instance (ArrowChoice c, Profunctor c) => ArrowFunctions (StaticGlobalStateT v c
StaticGlobalState{funcInstances = fs} <- get -< ()
case fs ! i of
FuncInst fTy modInst bdy -> returnA -< (fTy,modInst,bdy)
_ -> returnA -< error "not yet implemented"
_ -> returnA -< error "calling of external functions not yet implemented"
instance ArrowFix (Underlying (StaticGlobalStateT v c) x y) => ArrowFix (StaticGlobalStateT v c x y) where
type Fix (StaticGlobalStateT v c x y) = Fix (Underlying (StaticGlobalStateT v c) x y)
......
......@@ -48,8 +48,11 @@ instance (ArrowReader r c) => ArrowReader r (FrameT fd v c) where
instance (ArrowChoice c, Profunctor c) => ArrowFrame fd v (FrameT fd v c) where
inNewFrame (FrameT (ReaderT f)) =
FrameT $ ReaderT $ proc (_,(fd, vs, x)) -> do
snapshot <- get -< ()
put -< JoinVector $ Vec.fromList vs
f -< (fd, x)
res <-f -< (fd, x)
put -< snapshot
returnA -< res
frameData = FrameT ask
getLocal = FrameT $ ReaderT $ proc (_,n) -> do
(JoinVector vec) <- get -< ()
......
{-# LANGUAGE Arrows #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
......@@ -202,6 +203,8 @@ data Instruction index =
| I32WrapI64 Label
| ITruncFU {- Int Size -} BitSize {- Float Size -} BitSize Label
| ITruncFS {- Int Size -} BitSize {- Float Size -} BitSize Label
| ITruncSatFU BitSize BitSize Label
| ITruncSatFS BitSize BitSize Label
| I64ExtendSI32 Label
| I64ExtendUI32 Label
| FConvertIU {- Float Size -} BitSize {- Int Size -} BitSize Label
......@@ -212,6 +215,9 @@ data Instruction index =
| FReinterpretI BitSize Label
deriving (Show, Eq, Generic)
instance Pretty (Instruction Natural) where
pretty = viaShow
instance HasLabel (Instruction i) where
label e = case e of
Unreachable l -> l
......@@ -272,6 +278,8 @@ instance HasLabel (Instruction i) where
I32WrapI64 l -> l
ITruncFU _ _ l -> l
ITruncFS _ _ l -> l
ITruncSatFU _ _ l -> l
ITruncSatFS _ _ l -> l
I64ExtendSI32 l -> l
I64ExtendUI32 l -> l
FConvertIU _ _ l -> l
......@@ -327,6 +335,26 @@ f32Load :: MemArg -> LInstruction
f32Load m = F32Load m <$> fresh
f64Load :: MemArg -> LInstruction
f64Load m = F64Load m <$> fresh
i32Load8S :: MemArg -> LInstruction
i32Load8S m = I32Load8S m <$> fresh
i32Load8U :: MemArg -> LInstruction
i32Load8U m = I32Load8U m <$> fresh
i32Load16S :: MemArg -> LInstruction
i32Load16S m = I32Load16S m <$> fresh
i32Load16U :: MemArg -> LInstruction
i32Load16U m = I32Load16U m <$> fresh
i64Load8S :: MemArg -> LInstruction
i64Load8S m = I64Load8S m <$> fresh
i64Load8U :: MemArg -> LInstruction
i64Load8U m = I64Load8U m <$> fresh
i64Load16S :: MemArg -> LInstruction
i64Load16S m = I64Load16S m <$> fresh
i64Load16U :: MemArg -> LInstruction
i64Load16U m = I64Load16U m <$> fresh
i64Load32S :: MemArg -> LInstruction
i64Load32S m = I64Load32S m <$> fresh
i64Load32U :: MemArg -> LInstruction
i64Load32U m = I64Load32U m <$> fresh
i32Store :: MemArg -> LInstruction
i32Store m = I32Store m <$> fresh
......@@ -336,6 +364,21 @@ f32Store :: MemArg -> LInstruction
f32Store m = F32Store m <$> fresh
f64Store :: MemArg -> LInstruction
f64Store m = F64Store m <$> fresh
i32Store8 :: MemArg -> LInstruction
i32Store8 m = I32Store8 m <$> fresh
i32Store16 :: MemArg -> LInstruction
i32Store16 m = I32Store16 m <$> fresh
i64Store8 :: MemArg -> LInstruction
i64Store8 m = I64Store8 m <$> fresh
i64Store16 :: MemArg -> LInstruction
i64Store16 m = I64Store16 m <$> fresh
i64Store32 :: MemArg -> LInstruction
i64Store32 m = I64Store32 m <$> fresh
currentMemory :: LInstruction
currentMemory = CurrentMemory <$> fresh
growMemory :: LInstruction
growMemory = GrowMemory <$> fresh
i32Const :: Word32 -> LInstruction
i32Const w32 = I32Const w32 <$> fresh
......@@ -367,11 +410,26 @@ iTruncFU :: BitSize -> BitSize -> LInstruction
iTruncFU b1 b2 = ITruncFU b1 b2 <$> fresh
iTruncFS :: BitSize -> BitSize -> LInstruction
iTruncFS b1 b2 = ITruncFS b1 b2 <$> fresh
iTruncSatFU :: BitSize -> BitSize -> LInstruction
iTruncSatFU b1 b2 = ITruncSatFU b1 b2 <$> fresh
iTruncSatFS :: BitSize -> BitSize -> LInstruction
iTruncSatFS b1 b2 = ITruncSatFS b1 b2 <$> fresh
i64ExtendSI32 :: LInstruction
i64ExtendSI32 = I64ExtendSI32 <$> fresh
i64ExtendUI32 :: LInstruction
i64ExtendUI32 = I64ExtendUI32 <$> fresh
fConvertIU :: BitSize -> BitSize -> LInstruction
fConvertIU b1 b2 = FConvertIU b1 b2 <$> fresh
fConvertIS :: BitSize -> BitSize -> LInstruction
fConvertIS b1 b2 = FConvertIS b1 b2 <$> fresh
f32DemoteF64 :: LInstruction
f32DemoteF64 = F32DemoteF64 <$> fresh
f64PromoteF32 :: LInstruction
f64PromoteF32 = F64PromoteF32 <$> fresh
iReinterpretF :: BitSize -> LInstruction
iReinterpretF b = IReinterpretF b <$> fresh
fReinterpretI :: BitSize -> LInstruction
fReinterpretI b = FReinterpretI b <$> fresh
convertInstruction :: Wasm.Instruction Natural -> LInstruction
convertInstruction inst = case inst of
......@@ -398,11 +456,29 @@ convertInstruction inst = case inst of
Wasm.I64Load m -> i64Load m
Wasm.F32Load m -> f32Load m
Wasm.F64Load m -> f64Load m
Wasm.I32Load8S m -> i32Load8S m