content: {-# LANGUAGE Arrows #-}
  {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE FunctionalDependencies #-}
  {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  {-# LANGUAGE ImplicitParams #-}
  {-# LANGUAGE OverloadedLists #-}
  {-# LANGUAGE PartialTypeSignatures #-}
  {-# LANGUAGE StandaloneDeriving #-}
  {-# LANGUAGE TypeFamilies #-}
  {-# LANGUAGE UndecidableInstances #-}
  {-# OPTIONS_GHC -fno-warn-orphans #-}
  {-# OPTIONS_GHC -fno-warn-type-defaults #-}
  module ConcreteInterpreter where
  
  import           Data hiding (I32Eqz)
  import           Concrete
  import           GenericInterpreter hiding (eval,evalNumericInst,evalParametricInst,invokeExported,store)
  import qualified GenericInterpreter as Generic
  
  import           Control.Arrow
  import qualified Control.Arrow.Trans as Trans
  import           Control.Arrow.Except
  import           Control.Arrow.Fail as Fail
  
  import           Control.Arrow.Transformer.JumpTypes
  import           Control.Arrow.Transformer.Stack
  import           Control.Arrow.Transformer.StaticGlobalState
  import           Control.Arrow.Transformer.Value
  import           Control.Arrow.Transformer.WasmFrame
  
  import           Control.Arrow.Transformer.Concrete.Failure
  import           Control.Arrow.Transformer.Concrete.Except
  import           Control.Arrow.Transformer.Concrete.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 qualified Data.Vector as Vec
  import           Data.Word
  import           Data.Bits
  
  import           Language.Wasm.FloatUtils
  import           Language.Wasm.Interpreter (ModuleInstance, asInt32,asInt64,asWord32,asWord64,nearest,
                                              floatFloor, doubleFloor, floatCeil, doubleCeil,
                                              floatTrunc, doubleTrunc, zeroAwareMin, zeroAwareMax)
  import qualified Language.Wasm.Interpreter as Wasm
  import           Language.Wasm.Structure hiding (exports, Const, Instruction, Function,Expression,Memory,Table)
  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
  
  instance (ArrowChoice c, ArrowFail Err c, Fail.Join Value c) => IsVal Value (ValueT Value c) where
      type JoinVal y (ValueT Value c) = ()
  
      i32const = proc w32 -> returnA -< int32 w32
      i64const = proc w64 -> returnA -< int64 w64
      f32const = proc f -> returnA -< float32 f
      f64const = proc d -> returnA -< float64 d
  
      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, 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
          (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
          (BS32, IMul, Wasm.VI32 val1, Wasm.VI32 val2) -> returnA -< int32 $ val1 * val2
          (BS32, IDivU, Wasm.VI32 val1, Wasm.VI32 val2) ->
            if val2 == 0
            then trap -< "iBinOp: division by zero."
            else returnA -< int32 $ val1 `quot` val2
          (BS32, IDivS, Wasm.VI32 val1, Wasm.VI32 val2) ->
            if val2 == 0 || (val1 == 0x80000000 && val2 == 0xFFFFFFFF)
            then trap -< "iBinOp: division by zero."
            else returnA -< int32 $ asWord32 (asInt32 val1 `quot` asInt32 val2)
          (BS32, IRemU, Wasm.VI32 val1, Wasm.VI32 val2) ->
            if val2 == 0
            then trap -< "iBinOp: division by zero."
            else returnA -< int32 $ val1 `rem` val2
          (BS32, IRemS, Wasm.VI32 val1, Wasm.VI32 val2) ->
            if val2 == 0
            then trap -< "iBinOp: division by zero."
            else returnA -< int32 $ asWord32 (asInt32 val1 `rem` asInt32 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, 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, 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, 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 -< "iBinOp: division by zero."
            else returnA -< int64 $ val1 `quot` val2
          (BS64, IDivS, Wasm.VI64 val1, Wasm.VI64 val2) ->
            if val2 == 0 || (val1 == 0x8000000000000000 && val2 == 0xFFFFFFFFFFFFFFFF)
            then trap -< "iBinOp: division by zero."
            else returnA -< int64 $ asWord64 (asInt64 val1 `quot` asInt64 val2)
          (BS64, IRemU, Wasm.VI64 val1, Wasm.VI64 val2) ->
            if val2 == 0
            then trap -< "iBinOp: division by zero."
            else returnA -< int64 $ val1 `rem` val2
          (BS64, IRemS, Wasm.VI64 val1, Wasm.VI64 val2) ->
            if val2 == 0
            then trap -< "iBinOp: division by zero."
            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
          (BS32, INe,  Wasm.VI32 val1, Wasm.VI32 val2) -> returnA -< int32 $ if val1 /= val2 then 1 else 0
          (BS32, ILtU, Wasm.VI32 val1, Wasm.VI32 val2) -> returnA -< int32 $ if val1 <  val2 then 1 else 0
          (BS32, ILtS, Wasm.VI32 val1, Wasm.VI32 val2) -> returnA -< int32 $ if asInt32 val1 < asInt32 val2 then 1 else 0
          (BS32, IGtU, Wasm.VI32 val1, Wasm.VI32 val2) -> returnA -< int32 $ if val1 >  val2 then 1 else 0
          (BS32, IGtS, Wasm.VI32 val1, Wasm.VI32 val2) -> returnA -< int32 $ if asInt32 val1 > asInt32 val2 then 1 else 0
          (BS32, ILeU, Wasm.VI32 val1, Wasm.VI32 val2) -> returnA -< int32 $ if val1 <= val2 then 1 else 0
          (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
          _                   -> returnA -< error "i32ifNeqz: condition of unexpected type"
  
      ifHasType f g = proc (v,t,x) -> do
                  case (v,t) of
                      (Value (Wasm.VI32 _), I32) -> f -< x
                      (Value (Wasm.VI64 _), I64) -> f -< x
                      (Value (Wasm.VF32 _), F32) -> f -< x
                      (Value (Wasm.VF64 _), F64) -> f -< x
                      _                          -> g -< x
  
      fUnOp = proc (bs,op,Value v) -> case (bs,op,v) of
          (BS32, FAbs,     Wasm.VF32 val) -> returnA -< float32 $ abs val
          (BS32, FNeg,     Wasm.VF32 val) -> returnA -< float32 $ negate val
          (BS32, FCeil,    Wasm.VF32 val) -> returnA -< float32 $ floatCeil val
          (BS32, FFloor,   Wasm.VF32 val) -> returnA -< float32 $ floatFloor val
          (BS32, FTrunc,   Wasm.VF32 val) -> returnA -< float32 $ floatTrunc val
          (BS32, FNearest, Wasm.VF32 val) -> returnA -< float32 $ nearest val
          (BS32, FSqrt,    Wasm.VF32 val) -> returnA -< float32 $ sqrt val
          (BS64, FAbs,     Wasm.VF64 val) -> returnA -< float64 $ abs val
          (BS64, FNeg,     Wasm.VF64 val) -> returnA -< float64 $ negate val
          (BS64, FCeil,    Wasm.VF64 val) -> returnA -< float64 $ doubleCeil val
          (BS64, FFloor,   Wasm.VF64 val) -> returnA -< float64 $ doubleFloor val
          (BS64, FTrunc,   Wasm.VF64 val) -> returnA -< float64 $ doubleTrunc val
          (BS64, FNearest, Wasm.VF64 val) -> returnA -< float64 $ nearest val
          (BS64, FSqrt,    Wasm.VF64 val) -> returnA -< float64 $ sqrt val
          _ -> returnA -< error "fUnOp: cannot apply operator to arguements"
      fBinOp = proc (bs,op,Value v1,Value v2) -> case (bs,op,v1,v2) of
          (BS32, FAdd,      Wasm.VF32 val1, Wasm.VF32 val2) -> returnA -< float32 $ val1 + val2
          (BS32, FSub,      Wasm.VF32 val1, Wasm.VF32 val2) -> returnA -< float32 $ val1 - val2
          (BS32, FMul,      Wasm.VF32 val1, Wasm.VF32 val2) -> returnA -< float32 $ val1 * val2
          (BS32, FDiv,      Wasm.VF32 val1, Wasm.VF32 val2) -> returnA -< float32 $ val1 / val2
          (BS32, FMin,      Wasm.VF32 val1, Wasm.VF32 val2) -> returnA -< float32 $ zeroAwareMin val1 val2
          (BS32, FMax,      Wasm.VF32 val1, Wasm.VF32 val2) -> returnA -< float32 $ zeroAwareMax val1 val2
          (BS32, FCopySign, Wasm.VF32 val1, Wasm.VF32 val2) -> returnA -< float32 $ copySign val1 val2
          (BS64, FAdd,      Wasm.VF64 val1, Wasm.VF64 val2) -> returnA -< float64 $ val1 + val2
          (BS64, FSub,      Wasm.VF64 val1, Wasm.VF64 val2) -> returnA -< float64 $ val1 - val2
          (BS64, FMul,      Wasm.VF64 val1, Wasm.VF64 val2) -> returnA -< float64 $ val1 * val2
          (BS64, FDiv,      Wasm.VF64 val1, Wasm.VF64 val2) -> returnA -< float64 $ val1 / val2
          (BS64, FMin,      Wasm.VF64 val1, Wasm.VF64 val2) -> returnA -< float64 $ zeroAwareMin val1 val2
          (BS64, FMax,      Wasm.VF64 val1, Wasm.VF64 val2) -> returnA -< float64 $ zeroAwareMax val1 val2
          (BS64, FCopySign, Wasm.VF64 val1, Wasm.VF64 val2) -> returnA -< float64 $ copySign val1 val2
          _ -> returnA -< error "fBinOp: cannot apply binary operator to given arguments."
      fRelOp = proc (bs,op,Value v1,Value v2) -> case (bs,op,v1,v2) of
          (BS32, FEq, Wasm.VF32 val1, Wasm.VF32 val2) -> returnA -< int32 $ if val1 == val2 then 1 else 0
          (BS32, FNe, Wasm.VF32 val1, Wasm.VF32 val2) -> returnA -< int32 $ if val1 /= val2 then 1 else 0
          (BS32, FLt, Wasm.VF32 val1, Wasm.VF32 val2) -> returnA -< int32 $ if val1 <  val2 then 1 else 0
          (BS32, FGt, Wasm.VF32 val1, Wasm.VF32 val2) -> returnA -< int32 $ if val1 >  val2 then 1 else 0
          (BS32, FLe, Wasm.VF32 val1, Wasm.VF32 val2) -> returnA -< int32 $ if val1 <= val2 then 1 else 0
          (BS32, FGe, Wasm.VF32 val1, Wasm.VF32 val2) -> returnA -< int32 $ if val1 >= val2 then 1 else 0
          (BS64, FEq, Wasm.VF64 val1, Wasm.VF64 val2) -> returnA -< int32 $ if val1 == val2 then 1 else 0
          (BS64, FNe, Wasm.VF64 val1, Wasm.VF64 val2) -> returnA -< int32 $ if val1 /= val2 then 1 else 0
          (BS64, FLt, Wasm.VF64 val1, Wasm.VF64 val2) -> returnA -< int32 $ if val1 <  val2 then 1 else 0
          (BS64, FGt, Wasm.VF64 val1, Wasm.VF64 val2) -> returnA -< int32 $ if val1 >  val2 then 1 else 0
          (BS64, FLe, Wasm.VF64 val1, Wasm.VF64 val2) -> returnA -< int32 $ if val1 <= val2 then 1 else 0
          (BS64, FGe, Wasm.VF64 val1, Wasm.VF64 val2) -> returnA -< int32 $ if val1 >= val2 then 1 else 0
          _ -> returnA -< error "fRelOp: cannot apply binary operator to given arguments."
      i32WrapI64 = proc (Value v) -> case v of
          (Wasm.VI64 val) -> returnA -< int32 $ fromIntegral $ val .&. 0xFFFFFFFF
          _ -> returnA -< error "i32WrapI64: cannot apply operator to given argument."
      iTruncFU = proc (bs1,bs2,x@(Value v)) -> do
        let errorTrunc = printf "iTruncFU: 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^32 || val <= -1
              then trap -< errorTrunc
              else returnA -< int32 $ truncate val
          (BS32, BS64, Wasm.VF64 val) ->
              if isNaN val || isInfinite val || val >= 2^32 || val <= -1
              then trap -< errorTrunc
              else returnA -< int32 $ truncate val
          (BS64, BS32, Wasm.VF32 val) ->
              if isNaN val || isInfinite val || val >= 2^64 || val <= -1
              then trap -< errorTrunc
              else returnA -< int64 $ truncate val
          (BS64, BS64, Wasm.VF64 val) ->
              if isNaN val || isInfinite val || val >= 2^64 || val <= -1
              then trap -< errorTrunc
              else returnA -< int64 $ truncate val
          _ -> 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 - 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 - 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 - 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 - 1
              then trap -< errorTrunc
              else returnA -< int64 $ truncate val
          _ -> 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."
      i64ExtendUI32 = proc (Value v) -> case v of
          (Wasm.VI32 val) -> returnA -< int64 $ fromIntegral val
          _ -> returnA -< error "i64ExtendUI32: cannot apply operator to given argument."
      fConvertIU = proc (bs1,bs2,Value v) -> case (bs1,bs2,v) of
          (BS32, BS32, Wasm.VI32 val) -> returnA -< float32 $ realToFrac val
          (BS32, BS64, Wasm.VI64 val) -> returnA -< float32 $ realToFrac val
          (BS64, BS32, Wasm.VI32 val) -> returnA -< float64 $ realToFrac val
          (BS64, BS64, Wasm.VI64 val) -> returnA -< float64 $ realToFrac val
          _ -> returnA -< error "fConvertIU: cannot apply operator to given argument."
      fConvertIS = proc (bs1,bs2,Value v) -> case (bs1,bs2,v) of
          (BS32, BS32, Wasm.VI32 val) -> returnA -< float32 $ realToFrac $ asInt32 val
          (BS32, BS64, Wasm.VI64 val) -> returnA -< float32 $ realToFrac $ asInt64 val
          (BS64, BS32, Wasm.VI32 val) -> returnA -< float64 $ realToFrac $ asInt32 val
          (BS64, BS64, Wasm.VI64 val) -> returnA -< float64 $ realToFrac $ asInt64 val
          _ -> returnA -< error "fConvertIS: cannot apply operator to given argument."
      f32DemoteF64 = proc (Value v) -> case v of
          (Wasm.VF64 val) -> returnA -< float32 $ realToFrac val
          _ -> returnA -< error "f32DemoteF64: cannot apply operator to given argument."
      f64PromoteF32 = proc (Value v) -> case v of
          (Wasm.VF32 val) -> returnA -< float64 $ realToFrac val
          _ -> returnA -< error "f64PromoteF32: cannot apply operator to given argument."
      iReinterpretF = proc (bs,Value v) -> case (bs,v) of
          (BS32, Wasm.VF32 val) -> returnA -< int32 $ floatToWord val
          (BS64, Wasm.VF64 val) -> returnA -< int64 $ doubleToWord val
          _ -> returnA -< error "iReinterpretF: cannot apply operator to given argument."
      fReinterpretI = proc (bs,Value v) -> case (bs,v) of
          (BS32, Wasm.VI32 val) -> returnA -< float32 $ wordToFloat val
          (BS64, Wasm.VI64 val) -> returnA -< float64 $ wordToDouble val
          _ -> returnA -< error "fReinterpretI: cannot apply operator to given argument."
      listLookup sCont eCont = proc (Value v,xs,x) -> case v of
          (Wasm.VI32 val) -> if fromIntegral val < length xs
                             then sCont -< xs !! fromIntegral val
                             else eCont -< x
          _ -> returnA -< error "listLookup: cannot apply operator to given arguments."
  
  instance (ArrowExcept (Exc Value) c) => IsException (Exc Value) Value (ValueT Value c) where
      type JoinExc y (ValueT Value c) = ()
      exception = arr id
      handleException = id
  
  type Result = (Error
                               Err
                               (JoinVector Value,
                                (Tables,
                                 (Memories,
                                  (StaticGlobalState Value, Error (Exc Value) (JoinList Value, [Value]))))))
  
  
  invokeExported :: StaticGlobalState Value
                          -> Memories
                          -> Tables
                          -> ModuleInstance
                          -> Text
                          -> [Value]
                          -> Result
  invokeExported staticS mem tab modInst funcName args =
      let ?fixpointAlgorithm = Function.fix in
      Trans.run
      (Generic.invokeExported ::
        ValueT Value
          (JumpTypesT
            (StackT Value
              (ExceptT (Generic.Exc Value)
                (StaticGlobalStateT Value
                  (MemoryT
                    (SerializeT
                      (TableT
                        (FrameT FrameData Value
                          (FailureT Err
                            (->)))))))))) (Text, [Value]) [Value]) (JoinVector Vec.empty,((0,modInst),(tab,(mem,(staticS,([],([],(funcName,args))))))))
  
  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 valMod = instantiate valMod Value toMem TableInst
      where
          toMem size lst = MemInst size (Vec.fromList lst)
  