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: ...@@ -19,5 +19,5 @@ extra-deps:
- git: https://github.com/svenkeidel/husk-scheme/ - git: https://github.com/svenkeidel/husk-scheme/
commit: ca59598b11065eb29a45af7ffca27fc42a49abe5 commit: ca59598b11065eb29a45af7ffca27fc42a49abe5
- git: https://gitlab.rlp.net/plmz/external/haskell-wasm.git - git: https://gitlab.rlp.net/plmz/external/haskell-wasm.git
commit: 79a51ce931b183267ab4ac483d7dbaa724df7863 commit: cee605e726b74c1125686839591251158f283216
- knob-0.1.1 - knob-0.1.1
...@@ -41,3 +41,4 @@ tests: ...@@ -41,3 +41,4 @@ tests:
- sturdy-wasm - sturdy-wasm
- prettyprinter - prettyprinter
- fgl - fgl
- directory
...@@ -18,6 +18,8 @@ import GHC.Generics ...@@ -18,6 +18,8 @@ import GHC.Generics
newtype Value = Value Wasm.Value deriving (Show, Eq) newtype Value = Value Wasm.Value deriving (Show, Eq)
instance Pretty Value where
pretty = viaShow
type Memories = Vector MemInst type Memories = Vector MemInst
type Tables = Vector TableInst type Tables = Vector TableInst
......
...@@ -22,6 +22,7 @@ import Control.Arrow ...@@ -22,6 +22,7 @@ import Control.Arrow
import qualified Control.Arrow.Trans as Trans import qualified Control.Arrow.Trans as Trans
import Control.Arrow.Except import Control.Arrow.Except
import Control.Arrow.Fail as Fail import Control.Arrow.Fail as Fail
import Control.Arrow.Fix
import Control.Arrow.Transformer.JumpTypes import Control.Arrow.Transformer.JumpTypes
import Control.Arrow.Transformer.Stack import Control.Arrow.Transformer.Stack
...@@ -35,13 +36,21 @@ import Control.Arrow.Transformer.Concrete.Memory ...@@ -35,13 +36,21 @@ import Control.Arrow.Transformer.Concrete.Memory
import Control.Arrow.Transformer.Concrete.Serialize import Control.Arrow.Transformer.Concrete.Serialize
import Control.Arrow.Transformer.Concrete.Table import Control.Arrow.Transformer.Concrete.Table
import qualified Control.Monad.Primitive as Primitive
import Data.Concrete.Error import Data.Concrete.Error
import qualified Data.Function as Function 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.Lazy (Text)
import Data.Text.Prettyprint.Doc (pretty, hsep)
import qualified Data.Vector as Vec import qualified Data.Vector as Vec
import Data.Word
import Data.Bits import Data.Bits
import Debug.Trace
import Language.Wasm.FloatUtils import Language.Wasm.FloatUtils
import Language.Wasm.Interpreter (ModuleInstance, asInt32,asInt64,asWord32,asWord64,nearest, import Language.Wasm.Interpreter (ModuleInstance, asInt32,asInt64,asWord32,asWord64,nearest,
floatFloor, doubleFloor, floatCeil, doubleCeil, floatFloor, doubleFloor, floatCeil, doubleCeil,
...@@ -52,6 +61,7 @@ import Language.Wasm.Validate (ValidModule) ...@@ -52,6 +61,7 @@ import Language.Wasm.Validate (ValidModule)
import Numeric.IEEE (copySign) import Numeric.IEEE (copySign)
import Text.Printf import Text.Printf
--import Prettyprinter (pretty, hsep)
--trap :: IsException (Exc v) v c => c String x --trap :: IsException (Exc v) v c => c String x
--trap = throw <<< exception <<^ Trap --trap = throw <<< exception <<^ Trap
...@@ -68,10 +78,26 @@ instance (ArrowChoice c, ArrowFail Err c, Fail.Join Value c) => IsVal Value (Val ...@@ -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, IClz, Wasm.VI32 v) -> returnA -< int32 $ fromIntegral $ countLeadingZeros v
(BS32, ICtz, Wasm.VI32 v) -> returnA -< int32 $ fromIntegral $ countTrailingZeros v (BS32, ICtz, Wasm.VI32 v) -> returnA -< int32 $ fromIntegral $ countTrailingZeros v
(BS32, IPopcnt, Wasm.VI32 v) -> returnA -< int32 $ fromIntegral $ popCount 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, IClz, Wasm.VI64 v) -> returnA -< int64 $ fromIntegral $ countLeadingZeros v
(BS64, ICtz, Wasm.VI64 v) -> returnA -< int64 $ fromIntegral $ countTrailingZeros v (BS64, ICtz, Wasm.VI64 v) -> returnA -< int64 $ fromIntegral $ countTrailingZeros v
(BS64, IPopcnt, Wasm.VI64 v) -> returnA -< int64 $ fromIntegral $ popCount 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 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, IAdd, Wasm.VI32 val1, Wasm.VI32 val2) -> returnA -< int32 $ val1 + val2
(BS32, ISub, 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 ...@@ -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, IAnd, Wasm.VI32 val1, Wasm.VI32 val2) -> returnA -< int32 $ val1 .&. val2
(BS32, IOr, 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, 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, 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, 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, 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, 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 (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 ...@@ -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, IAnd, Wasm.VI64 val1, Wasm.VI64 val2) -> returnA -< int64 $ val1 .&. val2
(BS64, IOr, 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, 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, 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, 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, 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, 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 (BS64, IRotr, Wasm.VI64 val1, Wasm.VI64 val2) -> returnA -< int64 $ val1 `rotateR` fromIntegral val2
_ -> returnA -< error "iBinOp: cannot apply binary operator to given arguments." _ -> 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 ...@@ -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 if isNaN val || isInfinite val || val >= 2^64 || val <= -1
then trap -< errorTrunc then trap -< errorTrunc
else returnA -< int64 $ truncate val 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 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) let errorTrunc = printf "iTruncFS: truncation operator from %s to %s failed on %s." (show bs1) (show bs2) (show x)
case (bs1,bs2,v) of case (bs1,bs2,v) of
(BS32, BS32, Wasm.VF32 val) -> (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 then trap -< errorTrunc
else returnA -< int32 $ truncate val else returnA -< int32 $ truncate val
(BS32, BS64, Wasm.VF64 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 then trap -< errorTrunc
else returnA -< int32 $ truncate val else returnA -< int32 $ truncate val
(BS64, BS32, Wasm.VF32 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 then trap -< errorTrunc
else returnA -< int64 $ truncate val else returnA -< int64 $ truncate val
(BS64, BS64, Wasm.VF64 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 then trap -< errorTrunc
else returnA -< int64 $ truncate val 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 i64ExtendSI32 = proc (Value v) -> case v of
(Wasm.VI32 val) -> returnA -< int64 $ asWord64 $ fromIntegral $ asInt32 val (Wasm.VI32 val) -> returnA -< int64 $ asWord64 $ fromIntegral $ asInt32 val
_ -> returnA -< error "i64ExtendSI32: cannot apply operator to given argument." _ -> returnA -< error "i64ExtendSI32: cannot apply operator to given argument."
...@@ -322,6 +412,7 @@ invokeExported :: StaticGlobalState Value ...@@ -322,6 +412,7 @@ invokeExported :: StaticGlobalState Value
-> Result -> Result
invokeExported staticS mem tab modInst funcName args = invokeExported staticS mem tab modInst funcName args =
let ?fixpointAlgorithm = Function.fix in let ?fixpointAlgorithm = Function.fix in
--let ?fixpointAlgorithm = fixpointAlgorithm (trace p1 p2) in
Trans.run Trans.run
(Generic.invokeExported :: (Generic.invokeExported ::
ValueT Value ValueT Value
...@@ -335,6 +426,36 @@ invokeExported staticS mem tab modInst funcName args = ...@@ -335,6 +426,36 @@ invokeExported staticS mem tab modInst funcName args =
(FrameT FrameData Value (FrameT FrameData Value
(FailureT Err (FailureT Err
(->)))))))))) (Text, [Value]) [Value]) (JoinVector Vec.empty,((0,modInst),(tab,(mem,(staticS,([],([],(funcName,args)))))))) (->)))))))))) (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)) instantiateConcrete :: ValidModule -> IO (Either String (ModuleInstance, StaticGlobalState Value, Memories, Tables))
......
...@@ -32,7 +32,7 @@ import Control.Arrow.WasmFrame ...@@ -32,7 +32,7 @@ import Control.Arrow.WasmFrame
import Control.Arrow.Transformer.State import Control.Arrow.Transformer.State
import Control.Category import Control.Category (Category)
import Data.Profunctor import Data.Profunctor
import Data.Vector (Vector,(!),(//)) import Data.Vector (Vector,(!),(//))
...@@ -53,7 +53,7 @@ instance ArrowTrans MemoryT where ...@@ -53,7 +53,7 @@ instance ArrowTrans MemoryT where
-- lift' :: c x y -> MemoryT v c x y -- lift' :: c x y -> MemoryT v c x y
lift' a = MemoryT (lift' a) 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) = () type Join y (MemoryT c) = ()
memread (MemoryT sCont) (MemoryT eCont) = MemoryT $ proc (memIndex,addr,size,x) -> do memread (MemoryT sCont) (MemoryT eCont) = MemoryT $ proc (memIndex,addr,size,x) -> do
let addrI = fromIntegral addr let addrI = fromIntegral addr
...@@ -85,9 +85,17 @@ instance (ArrowChoice c, Profunctor c) => ArrowMemory Word32 (Vector Word8) Int ...@@ -85,9 +85,17 @@ instance (ArrowChoice c, Profunctor c) => ArrowMemory Word32 (Vector Word8) Int
let (MemInst _ vec) = mems ! memIndex let (MemInst _ vec) = mems ! memIndex
let size = length vec let size = length vec
returnA -< size `quot` pageSize returnA -< size `quot` pageSize
memgrow (MemoryT _) (MemoryT eCont) = MemoryT $ proc (_,_,x) -> do memgrow (MemoryT sCont) (MemoryT eCont) = MemoryT $ proc (memIndex,delta,x) -> do
-- TODO: allow to grow the memory mems <- get -< ()
eCont -< x 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 instance (ArrowChoice c, Profunctor c) => ArrowSize Value Int (MemoryT c) where
valToSize = proc (Value v) -> case v of valToSize = proc (Value v) -> case v of
...@@ -95,8 +103,8 @@ instance (ArrowChoice c, Profunctor c) => ArrowSize Value Int (MemoryT c) where ...@@ -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" _ -> returnA -< error "valToSize: arguments needs to be an i32 integer"
sizeToVal = proc sz -> returnA -< int32 $ fromIntegral sz sizeToVal = proc sz -> returnA -< int32 $ fromIntegral sz
instance (Arrow c, Profunctor c) => ArrowEffectiveAddress Value Natural Word32 (MemoryT c) where instance (Arrow c, Profunctor c) => ArrowEffectiveAddress Value Natural Word64 (MemoryT c) where
effectiveAddress = proc (Value (Wasm.VI32 base), off) -> returnA -< (base + fromIntegral off) 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 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) type Fix (MemoryT c x y) = Fix (Underlying (MemoryT c) x y)
...@@ -35,6 +35,7 @@ import Data.Vector (Vector) ...@@ -35,6 +35,7 @@ import Data.Vector (Vector)
import qualified Data.Vector as Vec import qualified Data.Vector as Vec
import Data.Word import Data.Word
import Language.Wasm.FloatUtils
import qualified Language.Wasm.Interpreter as Wasm import qualified Language.Wasm.Interpreter as Wasm
import Language.Wasm.Structure hiding (exports, Const) import Language.Wasm.Structure hiding (exports, Const)
...@@ -44,22 +45,80 @@ newtype SerializeT c x y = SerializeT (c x y) ...@@ -44,22 +45,80 @@ newtype SerializeT c x y = SerializeT (c x y)
ArrowStack st, ArrowState s, ArrowGlobals v, ArrowFunctions, ArrowReader m, ArrowTable v) 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 instance (Profunctor c, ArrowChoice c) => ArrowSerialize Value (Vector Word8) ValueType LoadType StoreType (SerializeT c) where
decode sCont = proc (dat, decTy, valTy, x) -> do decode sCont = proc (dat, decTy, valTy, x) -> do
case (valTy,decTy) of case (valTy,decTy) of
(I32,L_I32) -> do (I32,L_I32) -> sCont -< (toVal Wasm.VI32 dat, x)
let val = Vec.foldr (\w8 w32 -> (w32 `shiftL` 4) + fromIntegral w8) (fromIntegral $ Vec.last dat) dat (I64,L_I64) -> sCont -< (toVal Wasm.VI64 dat, x)
let result = Value $ Wasm.VI32 val (F32, L_F32) -> do
sCont -< (result, x) let i = toIntegral dat
_ -> returnA -< error "decode: do not support type" sCont -< (Value $ Wasm.VF32 $ wordToFloat i, x)
encode sCont = proc (Value val, valTy, datEncTy, x) -> do (F64, L_F64) -> do
case (val, valTy, datEncTy) of let i = toIntegral dat
(Wasm.VI32 v, I32, S_I32) -> do sCont -< (Value $ Wasm.VF64 $ wordToDouble i, x)
let vec = Vec.generate 4 (byte v) (I32, L_I8S) -> do
sCont -< (vec, x) let i = toIntegral dat :: Word8
_ -> returnA -< error "encode: do not support type" 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 where byte :: (Integral i, Bits i) => i -> Int -> Word8
byte v i = fromIntegral $ (v `shiftR` (i*8)) .&. 0xFF byte v i = fromIntegral $ (v `shiftR` (i*8)) .&. 0xFF
instance ArrowTrans SerializeT where instance ArrowTrans SerializeT where
lift' = SerializeT lift' = SerializeT
......
...@@ -47,9 +47,8 @@ newtype StaticGlobalStateT v c x y = StaticGlobalStateT (StateT (StaticGlobalSta ...@@ -47,9 +47,8 @@ newtype StaticGlobalStateT v c x y = StaticGlobalStateT (StateT (StaticGlobalSta
ArrowSize val sz, ArrowEffectiveAddress base off addr, ArrowTable v1, ArrowJoin) ArrowSize val sz, ArrowEffectiveAddress base off addr, ArrowTable v1, ArrowJoin)
instance (ArrowState s c) => ArrowState s (StaticGlobalStateT v c) where instance (ArrowState s c) => ArrowState s (StaticGlobalStateT v c) where
get = error "TODO: implement StaticGlobalStateT.get" get = lift' get
put = error "TODO: implement StaticGlobalStateT.put" put = lift' put
-- TODO
instance ArrowTrans (StaticGlobalStateT v) where instance ArrowTrans (StaticGlobalStateT v) where
lift' a = StaticGlobalStateT (lift' a) lift' a = StaticGlobalStateT (lift' a)
...@@ -74,7 +73,7 @@ instance (ArrowChoice c, Profunctor c) => ArrowFunctions (StaticGlobalStateT v c ...@@ -74,7 +73,7 @@ instance (ArrowChoice c, Profunctor c) => ArrowFunctions (StaticGlobalStateT v c
StaticGlobalState{funcInstances = fs} <- get -< () StaticGlobalState{funcInstances = fs} <- get -< ()
case fs ! i of case fs ! i of
FuncInst fTy modInst bdy -> returnA -< (fTy,modInst,bdy) 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 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) 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 ...@@ -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 instance (ArrowChoice c, Profunctor c) => ArrowFrame fd v (FrameT fd v c) where
inNewFrame (FrameT (ReaderT f)) = inNewFrame (FrameT (ReaderT f)) =