content: {-# LANGUAGE Arrows #-}
  {-# LANGUAGE ConstraintKinds #-}
  {-# LANGUAGE DeriveGeneric #-}
  {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE FunctionalDependencies #-}
  {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  {-# LANGUAGE ImplicitParams #-}
  {-# LANGUAGE RankNTypes #-}
  {-# LANGUAGE StandaloneDeriving #-}
  {-# LANGUAGE TypeFamilies #-}
  {-# LANGUAGE UndecidableInstances #-}
  {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
  -- | A generic interpreter for WebAssembly.
  -- | This implements the official specification https://webassembly.github.io/spec/.
  module GenericInterpreter where
  
  import Prelude hiding (Read, fail, log)
  
  import           Concrete()
  import           Data (Instruction(..), Function(..), LoadType(..), StoreType(..))
  
  import           Control.Arrow
  import           Control.Arrow.Except
  import qualified Control.Arrow.Except as Exc
  import           Control.Arrow.Fail as Fail
  import           Control.Arrow.Fix
  import           Control.Arrow.Functions
  import           Control.Arrow.EffectiveAddress
  import           Control.Arrow.JumpTypes
  import           Control.Arrow.Memory as Mem
  import           Control.Arrow.Serialize
  import           Control.Arrow.Size
  import           Control.Arrow.Stack
  import           Control.Arrow.Table
  import qualified Control.Arrow.Utils as Arr
  import           Control.Arrow.Globals
  import           Control.Arrow.WasmFrame
  
  import           Data.Hashable
  import           Data.Maybe(maybeToList)
  import           Data.Profunctor
  import           Data.Text.Lazy (Text)
  import           Data.Vector hiding (length, (++))
  import           Data.Word
  import           Data.Kind(Type)
  
  import           Language.Wasm.Structure (ValueType(..), BitSize, IUnOp(..), IBinOp(..), IRelOp(..),
                                            FUnOp(..), FBinOp(..), FRelOp(..), MemArg(..), FuncType(..), ResultType, BlockType(..))
  import           Language.Wasm.Interpreter (ModuleInstance(..), emptyModInstance, ExportInstance(..), ExternalValue(..))
  
  import           Numeric.Natural (Natural)
  import           Text.Printf
  
  import           GHC.Generics
  import           GHC.Exts
  
  -- | the kind of exceptions that can be thrown
  data Exc v = Jump Natural [v] | CallReturn [v] deriving (Show, Eq, Generic)
  
  -- | unrecoverable errors
  data Err = Trap String | InvocationError String deriving (Show, Eq, Generic)
  
  instance Hashable v => Hashable (Exc v)
  instance Hashable Err
  
  class ArrowExcept exc c => IsException exc v c | c -> v where
      type family JoinExc y (c :: Type -> Type -> Type) :: Constraint
      exception :: c (Exc v) exc
      handleException :: JoinExc y c => c (Exc v, x) y -> c (exc,x) y
  
  -- | fail with a trap
  trap :: (Fail.Join x c, ArrowFail Err c) => c String x
  trap = proc s -> fail -< (Trap s)
  
  -- | fail with an invocation error
  invocationError :: (Fail.Join x c, ArrowFail Err c) => c String x
  invocationError = proc s -> fail -< (InvocationError s)
  
  -- | stores a frame's static data (return arity and module instance)
  type FrameData = (Natural, ModuleInstance)
  
  type ArrowWasmMemory addr bytes sz v c =
    ( ArrowMemory addr bytes sz c,
      ArrowEffectiveAddress v Natural addr c,
      ArrowSize v sz c,
      ArrowSerialize v bytes ValueType LoadType StoreType c,
      Show addr, Show bytes)
  
  type ArrowStaticComponents v c =
    ( ArrowGlobals v c,
      ArrowFunctions c,
      ArrowStack v c,
      ArrowFrame FrameData v c,
      ArrowJumpTypes c)
  
  type ArrowDynamicComponents v addr bytes sz exc e c =
    ( ArrowTable v c,
      ArrowWasmMemory addr bytes sz v c,
      IsVal v c,
      ArrowExcept exc c, IsException exc v c,
      ArrowFail Err c,
      ArrowFix (c [Instruction Natural] ()),
      ?fixpointAlgorithm :: FixpointAlgorithm (Fix (c [Instruction Natural] ())))
  
  
  -- | the language interface
  class Show v => IsVal v c | c -> v where
      type family JoinVal y (c :: Type -> Type -> Type) :: Constraint
  
      i32const :: c Word32 v
      i64const :: c Word64 v
      f32const :: c Float v
      f64const :: c Double v
      iUnOp :: c (BitSize, IUnOp, v) v
      iBinOp :: JoinVal v c => c (BitSize, IBinOp, v, v) v
      i32eqz :: c v v
      i64eqz :: c v v
      iRelOp :: c (BitSize, IRelOp, v, v) v
      fUnOp :: c (BitSize, FUnOp, v) v
      fBinOp :: c (BitSize, FBinOp, v, v) v
      fRelOp :: c (BitSize, FRelOp, v, v) v
      i32WrapI64 :: c v v
      iTruncFU :: JoinVal v c => c (BitSize, BitSize, v) v
      iTruncFS :: JoinVal v c => c (BitSize, BitSize, v) v
      iTruncSatFU :: c (BitSize, BitSize, v) v
      iTruncSatFS :: c (BitSize, BitSize, v) v
      i64ExtendSI32 :: c v v
      i64ExtendUI32 :: c v v
      fConvertIU :: c (BitSize, BitSize, v) v
      fConvertIS :: c (BitSize, BitSize, v) v
      f32DemoteF64 :: c v v
      f64PromoteF32 :: c v v
      iReinterpretF :: c (BitSize, v) v
      fReinterpretI :: c (BitSize, v) v
      i32ifNeqz :: (JoinVal y c) => c x y -> c x y -> c (v, x) y
      -- | listLookup f g (v, xs, x):
      -- Looks up the `v`-th element in `xs` and passes it to `f`, or
      -- passes `x` to `g` if `v` is out of range of `xs`.
      listLookup :: (JoinVal y c) => c x y -> c x y -> c (v, [x], x) y
      ifHasType :: c x y -> c x y -> c (v, ValueType, x) y
  
  
  -- | entry point to the generic interpreter
  --
  -- invokes the function with the given name and the arguments
  
  -- the module instance comes from ArrowFrame
  -- ArrowGlobalState and ArrowWasmMemory are properly initialized
  -- argument Text: name of the function to execute
  -- argument [v]: arguments going to be passed to the function
  invokeExported ::
    ( ArrowChoice c,
      ArrowStaticComponents v c, ArrowDynamicComponents v addr bytes sz exc e c,
      JoinExc () c, Exc.Join () c,
      Mem.Join () c,
      JoinVal () c, JoinVal v c, Show v,
      Fail.Join [v] c,
      Fail.Join () c,
      Fail.Join v c,
      JoinTable () c)
    => c (Text, [v]) [v]
  invokeExported = proc (funcName, args) -> do
    (_, modInst) <- frameData -< () -- get the module instance
    -- look for a function with name funcName in the function's exports
    case find (\(ExportInstance n _) -> n == funcName) (exports modInst) of
        -- if found -> invoke
        Just (ExportInstance _ (ExternFunction addr)) -> invokeExternal -< (addr, args)
        _ -> invocationError  -< printf "Function with name %s was not found in module's exports" (show funcName)
  
  -- | invokes function with the given static index and the arguments
  invokeExternal ::
    ( ArrowChoice c,
      ArrowStaticComponents v c, ArrowDynamicComponents v addr bytes sz exc e c,
      JoinExc () c,
      Mem.Join () c,
      JoinVal () c, JoinVal v c, Show v,
      Exc.Join () c,
      Fail.Join () c,
      Fail.Join v c,
      JoinTable () c)
    => c (Int, [v]) [v]
  invokeExternal = proc (funcAddr, args) -> do
    funcData@(FuncType paramTys resultTys,_,_) <- readFunction -< funcAddr
    withCheckedType (withRootFrame (invoke eval)) -< (paramTys, args, (resultTys, Prelude.reverse args, funcData))
    where
      -- execute f with "dummy" frame
      withRootFrame f = proc (resultTys, args, x) -> do
        let rtLength = fromIntegral $ length resultTys
        inNewFrame
          (proc (rtLength, args, x) -> do
            pushn -< args -- push arguments to the stack
            f -< x -- execute function
            res <- popn -< rtLength -- pop result from the stack
            returnA -< Prelude.reverse res)
          -< ((rtLength, emptyModInstance), [], (rtLength, args, x))
  
      -- execute f if arguments match paramTys
      withCheckedType f = proc (paramTys, args, x) -> do
        if length paramTys /= length args
          then invocationError -< printf "Wrong number of arguments in external invocation. Expected %d but got %d" (length paramTys) (length args)
          else returnA -< ()
        Arr.zipWith
          (proc (arg, ty) ->
            ifHasType
              (arr $ const ())
              (proc (arg, ty) -> invocationError -< printf "Wrong argument type in external invocation. Expected %s but got %s" (show ty) (show arg))
              -< (arg, ty, (arg, ty)))
          -< (args, paramTys)
        f -< x
  
  -- | evaluates the list of instructions in the context provided by arrow c
  eval ::
    ( ArrowChoice c,
      ArrowStaticComponents v c, ArrowDynamicComponents v addr bytes sz exc e c,
      Fail.Join () c,
      JoinExc () c,
      Mem.Join () c,
      JoinVal () c, JoinVal v c, Show v,
      Exc.Join () c,
      JoinTable () c,
      Fail.Join v c)
    => c [Instruction Natural] ()
  eval = fix $ \eval' -> proc is -> do
      case is of
        [] -> returnA -< ()
        i:is' | isNumericInst i -> do
          push <<< evalNumericInst -< i
          eval' -< is'
        i:is' | isVariableInst i -> do
          evalVariableInst -< i
          eval' -< is'
        i:is' | isParametricInst i -> do
          evalParametricInst -< i
          eval' -< is'
        i:is' | isControlInst i -> do
          evalControlInst eval' -< i
          eval' -< is'
        i:is' | isMemoryInst i -> do
          evalMemoryInst -< i
          eval' -< is'
  
  evalControlInst ::
    ( ArrowChoice c, Profunctor c,
      ArrowStaticComponents v c,
      ArrowDynamicComponents v addr bytes sz exc e c,
      Fail.Join () c,
      JoinVal () c,
      JoinExc () c,
      Exc.Join () c,
      JoinTable () c)
    => c [Instruction Natural] () -> c (Instruction Natural) ()
  evalControlInst eval' = proc i -> case i of
    Unreachable _ -> trap -< "Execution of unreachable instruction"
    Nop _ -> returnA -< ()
    Block bt is _ -> do
      (FuncType _paramTys resultTys) <- expandType -< bt
      --popn -< fromIntegral (length paramTys)
      label eval' eval' -< (resultTys, is, [])
    Loop bt is l -> do
      (FuncType paramTys _resultTys) <- expandType -< bt
      --pars <- popn -< fromIntegral (length paramTys)
      --label (proc (pars,instr) -> do
      --           pushn -< pars
      --           eval' -< instr)
      --      (proc (_,instr) -> eval' -< instr)
      --      -< (paramTys, (pars,is), (pars,[Loop bt is l]))
      label eval' eval' -< (paramTys, is, [Loop bt is l])
    If bt isNZero isZero _ -> do
      v <- pop -< ()
      (FuncType _paramTys resultTys) <- expandType -< bt
      --popn -< fromIntegral (length paramTys)
      i32ifNeqz
        (proc (rt, isNZero, _) -> label eval' eval' -< (rt, isNZero, []))
        (proc (rt, _, isZero) -> label eval' eval' -< (rt, isZero, []))
        -< (v, (resultTys, isNZero, isZero))
    Br ix _ -> branch -< ix
    BrIf ix _ -> do
      v <- pop -< ()
      i32ifNeqz
        branch
        (arr $ const ())
        -< (v, ix)
    BrTable ls ldefault _ -> do
      v <- pop -< ()
      listLookup branch branch -< (v, ls, ldefault)
    Return _ -> do
      (n,_) <- frameData -< ()
      vs <- popn -< n
      throw <<< exception -< CallReturn vs
    Call ix _ -> do
      (_, modInst) <- frameData -< ()
      let funcAddr = funcaddrs modInst ! fromIntegral ix
      invoke eval' <<< readFunction -< funcAddr
    CallIndirect ix _ -> do
      (_, modInst) <- frameData -< () -- get the current module instance
      let tableAddr = tableaddrs modInst ! 0 -- get address of table 0
      let ftExpect = funcTypes modInst ! fromIntegral ix -- get expected functype
      funcAddr <- pop -< ()
      readTable
        (invokeChecked eval')
        (proc (ta,ix,_) -> trap -< printf "Index %s out of bounds for table address %s" (show ix) (show ta))
        (proc (ta,ix,_) -> trap -< printf "Index %s uninitialized for table address %s" (show ix) (show ta))
        -< (tableAddr, funcAddr, ftExpect)
  
  
  expandType :: (ArrowChoice c, ArrowStaticComponents v c) => c BlockType FuncType
  expandType = proc bt -> case bt of
      Inline mVal -> returnA -< FuncType [] (maybeToList mVal)
      TypeIndex idx -> do
          (_, modInst) <- frameData -< ()
          let ft = funcTypes modInst ! fromIntegral idx
          returnA -< ft
  
  
  
  invokeChecked ::
    ( ArrowChoice c,
      ArrowStaticComponents v c,
      IsVal v c, ArrowExcept exc c, IsException exc v c, JoinExc () c, Exc.Join () c, Fail.Join () c,
      ArrowFail Err c)
    => c [Instruction Natural] () -> c (Int, FuncType) ()
  invokeChecked eval' = proc (addr, ftExpect) -> do
    funcData@(ftActual,_,_) <- readFunction -< addr
    withCheckedType (invoke eval') -< (ftActual, ftExpect, funcData)
    where
      withCheckedType f = proc (ftActual, ftExpect, x) ->
        if ftActual == ftExpect
        then f -< x
        else trap -< printf "Mismatched function type in indirect call. Expected %s, actual %s." (show ftExpect) (show ftActual)
  
  -- | invoke function with code code within module instance funcModInst
  --
  --  the function execution can finish by different reasons:
  --
  --   * all instructions have been executed -> result are the top |resultTys| values on the stack
  --   * the function calls return -> result are the top |resultTys| values on the stack
  --   * the function produces a trap -> no result, trap is propagated
  invoke ::
    ( ArrowChoice c, ArrowStack v c, ArrowJumpTypes c,
      IsVal v c, ArrowFrame FrameData v c, ArrowExcept exc c, IsException exc v c, Exc.Join y c,
      ArrowStack v c, JoinExc y c)
    => c [Instruction Natural] y -> c (FuncType, ModuleInstance, Function) y
  invoke eval' = catch
      (proc (FuncType paramTys resultTys, funcModInst, Function _ localTys code) -> do
          vs <- popn -< fromIntegral $ length paramTys
          zeros <- Arr.map initLocal -< localTys
          let rtLength = fromIntegral $ length resultTys
          result <- inNewFrame (localNoJumpTypes $ localFreshStack $ label eval' eval') -< ((rtLength, funcModInst), Prelude.reverse vs ++ zeros, (resultTys, code, []))
          returnA -< result
          )
      (proc (_,e) -> handleException
                     (proc (exc,_) -> case exc of
                         CallReturn vs -> do
                             pushn -< vs
                             eval' -< []
                         --Trap _ -> throw <<< exception -< exc
                         Jump _ _ -> returnA -< error "invalid module: tried to jump through a function boundary")
                     -< (e,()))
    where
      initLocal :: (ArrowChoice c, IsVal v c) => c ValueType v
      initLocal = proc ty ->  case ty of
        I32 -> i32const -< 0
        I64 -> i64const -< 0
        F32 -> f32const -< 0
        F64 -> f64const -< 0
  
  -- | jumps to the enclosing block with given index
  branch :: (ArrowChoice c, ArrowExcept exc c, IsException exc v c, ArrowStack v c, ArrowJumpTypes c) => c Natural ()
  branch = proc ix -> do
    rt <- jumpType -< ix
    vs <- popn -< fromIntegral $ length rt
    throw <<< exception -< Jump ix vs
  
  -- | Introduces a branching point `g` that can be jumped to from within `f`.
  -- When escalating jumps, all label-local operands must be popped from the stack.
  -- This implementation assumes that ArrowExcept discards label-local operands in ArrowStack upon throw.
  label :: (ArrowChoice c, ArrowExcept exc c, IsException exc v c, ArrowStack v c, ArrowJumpTypes c, Exc.Join z c,
            ArrowStack v c, Show v, JoinExc z c)
    => c x z -> c y z -> c (ResultType, x, y) z
  label f g = catch
    -- after executing f without a break we expect |rt| results on top of the stack
    (proc (rt,x,_) -> do
      result <- withJumpType f -< (rt, x)
      returnA -< result
    )
    -- after a break the results are popped from the stack and passed back via exception e
    (proc ((_,_,y),e) -> handleException
                         (proc (exc,y) -> case exc of
                             Jump 0 vs -> do
                                 pushn -< vs
                                 g -< y
                             -- we expect all label-local operands are popped from the stack
                             Jump n vs -> throw <<< exception -< Jump (n-1) vs
                             _ -> throw <<< exception -< exc)
                         -< (e,y)
    )
  
  
  evalParametricInst :: (ArrowChoice c, Profunctor c, ArrowStack v c, IsVal v c, JoinVal () c)
    => c (Instruction Natural) ()
  evalParametricInst = proc i -> case i of
    Drop _ -> const () ^<< pop -< ()
    Select _ -> do
      v <- pop -< ()
      i32ifNeqz
        (const () ^<< pop)
        (proc () -> do
          (_,v2) <- pop2 -< ()
          push -< v2)
        -< (v, ())
  
  
  evalMemoryInst ::
    ( ArrowChoice c,
      ArrowStaticComponents v c, ArrowDynamicComponents v addr bytes sz exc e c,
      Mem.Join () c, Fail.Join () c)
    => c (Instruction Natural) ()
  evalMemoryInst = proc i -> case i of --withCurrentMemory $ proc (m,i) -> case i of
    I32Load (MemArg off _) _ -> load 4 L_I32 I32 -< off
    I64Load (MemArg off _) _ -> load 8 L_I64 I64 -< off
    F32Load (MemArg off _) _ -> load 4 L_F32 F32 -< off
    F64Load (MemArg off _) _ -> load 8 L_F64 F64 -< off
    I32Load8S (MemArg off _) _ -> load 1 L_I8S I32 -< off
    I32Load8U (MemArg off _) _ -> load 1 L_I8U I32 -< off
    I32Load16S (MemArg off _) _ -> load 2 L_I16S I32 -< off
    I32Load16U (MemArg off _) _ -> load 2 L_I16U I32 -< off
    I64Load8S (MemArg off _) _ -> load 1 L_I8S I64 -< off
    I64Load8U (MemArg off _) _ -> load 1 L_I8U I64 -< off
    I64Load16S (MemArg off _) _ -> load 2 L_I16S I64 -< off
    I64Load16U (MemArg off _) _ -> load 2 L_I16U I64 -< off
    I64Load32S (MemArg off _) _ -> load 4 L_I32S I64 -< off
    I64Load32U (MemArg off _) _ -> load 4 L_I32U I64 -< off
    I32Store (MemArg off _) _ -> store S_I32 I32 -< off
    I64Store (MemArg off _) _ -> store S_I64 I64 -< off
    F32Store (MemArg off _) _ -> store S_F32 F32 -< off
    F64Store (MemArg off _) _ -> store S_F64 F64 -< off
    I32Store8 (MemArg off _) _ -> store S_I8 I32 -< off
    I32Store16 (MemArg off _) _ -> store S_I16 I32 -< off
    I64Store8 (MemArg off _) _ -> store S_I8 I64 -< off
    I64Store16 (MemArg off _) _ -> store S_I16 I64 -< off
    I64Store32 (MemArg off _) _ -> store S_I32 I64 -< off
    CurrentMemory _ -> push <<< sizeToVal <<< memsize <<< memoryIndex -< ()
    GrowMemory _ -> do
      n <- valToSize <<< pop -< ()
      memIndex <- memoryIndex -< ()
      memgrow
        (push <<< sizeToVal <<^ fst)
        (proc _ -> push <<< i32const -< 0xFFFFFFFF) -- 0xFFFFFFFF ~= -1
        -< (memIndex, n, ())
  
  memoryIndex :: (Arrow c, ArrowFrame FrameData v c) => c () Int
  memoryIndex = proc () -> do
    (_,modInst) <- frameData -< ()
    returnA -< memaddrs modInst ! 0
  
  -- | loads byteSize bytes from memory and converts it to valType, the resulting value is pushed to the stack
  load ::
    ( ArrowChoice c,
      ArrowStaticComponents v c, ArrowDynamicComponents v addr bytes sz exc e c,
      Mem.Join () c, Fail.Join () c)
    => Int -> LoadType -> ValueType -> c Natural ()
  load byteSize loadType valType = proc off -> do
    base <- pop -< ()
    addr <- effectiveAddress -< (base, off)
    memIndex <- memoryIndex -< ()
    memread
      (proc (bytes,_) ->
        push <<< decode -< (bytes, loadType, valType))
      (proc addr -> trap -< printf "Memory access out of bounds: Cannot read %d bytes at address %s in current memory" byteSize (show addr))
      -< (memIndex, addr, byteSize, addr)
  
  -- | stores a value into the memory, value and memory address are read from the stack
  store ::
    ( ArrowChoice c,
      ArrowStaticComponents v c, ArrowDynamicComponents v addr bytes sz exc e c,
      Mem.Join () c, Fail.Join () c)
    => StoreType -> ValueType -> c Natural ()
  store storeType valType = proc off -> do
    v <- pop -< ()
    bytes <- encode -< (v, valType, storeType)
    base <- pop -< ()
    addr <- effectiveAddress -< (base, off)
    memIndex <- memoryIndex -< ()
    memstore
      (arr $ const ())
      (proc (addr,bytes) -> trap -< printf "Memory access out of bounds: Cannot write %s at address %s in current memory" (show bytes) (show addr))
      -< (memIndex, addr, bytes, (addr, bytes))
  
  evalVariableInst ::
    ( ArrowChoice c, ArrowStaticComponents v c)
    => c (Instruction Natural) ()
  evalVariableInst = proc i -> case i of
    GetLocal ix _ -> push <<< getLocal -< ix
    SetLocal ix _-> do
      v <- pop -< ()
      setLocal -< (ix, v)
    TeeLocal ix _ -> do
      v <- peek -< ()
      setLocal -< (ix, v)
    GetGlobal ix _ ->  do
      (_,modInst) <- frameData -< ()
      let globalAddr = globaladdrs modInst ! fromIntegral ix
      push <<< readGlobal -< globalAddr
    SetGlobal ix _ -> do
      v <- pop -< ()
      (_,modInst) <- frameData -< ()
      let globalAddr = globaladdrs modInst ! fromIntegral ix
      writeGlobal -< (globalAddr, v)
  
  
  evalNumericInst ::
    ( ArrowChoice c, ArrowStack v c, ArrowExcept exc c, IsException exc v c, IsVal v c, Show v, JoinVal v c,
      Fail.Join v c, ArrowFail Err c)
    => c (Instruction Natural) v
  evalNumericInst = proc i -> case i of
    I32Const lit _ -> i32const -< lit
    I64Const lit _ -> i64const -< lit
    F32Const lit _ -> f32const -< lit
    F64Const lit _ -> f64const -< lit
    IUnOp bs op _ -> do
      v <- pop -< ()
      iUnOp -< (bs, op, v)
    IBinOp bs op _ -> do
      (v1,v2) <- pop2 -< ()
      iBinOp -< (bs, op, v1, v2)
    I32Eqz _ -> do
      v <- pop -< ()
      i32eqz -< v
    I64Eqz _ -> do
      v <- pop -< ()
      i64eqz -< v
    IRelOp bs op _ -> do
      (v1,v2) <- pop2 -< ()
      iRelOp -< (bs, op, v1, v2)
    FBinOp bs op _ -> do
      (v1,v2) <- pop2 -< ()
      fBinOp -< (bs, op, v1, v2)
    FUnOp bs op _ -> do
      v <- pop -< ()
      fUnOp -< (bs, op, v)
    FRelOp bs op _ -> do
      (v1,v2) <- pop2 -< ()
      fRelOp -< (bs, op, v1, v2)
    I32WrapI64 _ -> do
      v <- pop -< ()
      i32WrapI64 -< v
    ITruncFU bs1 bs2 _ -> do
      v <- pop -< ()
      iTruncFU -< (bs1,bs2,v)
    ITruncFS bs1 bs2 _ -> do
      v <- pop -< ()
      iTruncFS -< (bs1,bs2,v)
    ITruncSatFU bs1 bs2 _ -> do
      v <- pop -< ()
      iTruncSatFU -< (bs1,bs2,v)
    ITruncSatFS bs1 bs2 _ -> do
      v <- pop -< ()
      iTruncSatFS -< (bs1,bs2,v)
    I64ExtendSI32 _ -> do
      v <- pop -< ()
      i64ExtendSI32 -< v
    I64ExtendUI32 _ -> do
      v <- pop -< ()
      i64ExtendUI32 -< v
    FConvertIU bs1 bs2 _ -> do
      v <- pop -< ()
      fConvertIU -< (bs1, bs2, v)
    FConvertIS bs1 bs2 _ -> do
      v <- pop -< ()
      fConvertIS -< (bs1, bs2, v)
    F32DemoteF64 _ -> do
      v <- pop -< ()
      f32DemoteF64 -< v
    F64PromoteF32 _ -> do
      v <- pop -< ()
      f64PromoteF32 -< v
    IReinterpretF bs _ -> do
      v <- pop -< ()
      iReinterpretF -< (bs, v)
    FReinterpretI bs _ -> do
      v <- pop -< ()
      fReinterpretI -< (bs, v)
  
  
  isControlInst :: Instruction index -> Bool
  isControlInst i = case i of
    Unreachable _ -> True
    Nop _ -> True
    Block{}-> True
    Loop{} -> True
    If{} -> True
    Br{} -> True
    BrIf{} -> True
    BrTable{} -> True
    Return _  -> True
    Call{} -> True
    CallIndirect{} -> True
    _ -> False
  
  isParametricInst :: Instruction index -> Bool
  isParametricInst i = case i of
    Drop _ -> True
    Select _ -> True
    _ -> False
  
  isMemoryInst :: Instruction index -> Bool
  isMemoryInst i = case i of
    I32Load _ _ -> True
    I64Load _ _ -> True
    F32Load _ _ -> True
    F64Load _ _ -> True
    I32Load8S _ _ -> True
    I32Load8U _ _ -> True
    I32Load16S _ _ -> True
    I32Load16U _ _ -> True
    I64Load8S _ _ -> True
    I64Load8U _ _ -> True
    I64Load16S _ _ -> True
    I64Load16U _ _ -> True
    I64Load32S _ _ -> True
    I64Load32U _ _ -> True
    I32Store _ _ -> True
    I64Store _ _ -> True
    F32Store _ _ -> True
    F64Store _ _ -> True
    I32Store8 _ _ -> True
    I32Store16 _ _ -> True
    I64Store8 _ _ -> True
    I64Store16 _ _ -> True
    I64Store32 _ _ -> True
    CurrentMemory _ -> True
    GrowMemory _ -> True
    _ -> False
  
  
  isVariableInst :: Instruction index -> Bool
  isVariableInst i = case i of
    GetLocal _ _ -> True
    SetLocal _ _ -> True
    TeeLocal _ _ -> True
    GetGlobal _ _ -> True
    SetGlobal _ _ -> True
    _ -> False
  
  isNumericInst :: Instruction index -> Bool
  isNumericInst i = case i of
    I32Const _ _ -> True
    I64Const _ _ -> True
    F32Const _ _ -> True
    F64Const _ _ -> True
    IUnOp _ _ _ -> True
    IBinOp _ _ _ -> True
    I32Eqz _ -> True
    I64Eqz _ -> True
    IRelOp _ _ _ -> True
    FUnOp _ _ _ -> True
    FBinOp _ _ _ -> True
    FRelOp _ _ _ -> True
    I32WrapI64 _ -> True
    ITruncFU _ _ _ -> True
    ITruncFS _ _ _ -> True
    ITruncSatFU _ _ _ -> True
    ITruncSatFS _ _ _ -> True
    I64ExtendSI32 _ -> True
    I64ExtendUI32 _ -> True
    FConvertIU  _ _ _ -> True
    FConvertIS _ _ _ -> True
    F32DemoteF64 _ -> True
    F64PromoteF32 _ -> True
    IReinterpretF _ _ -> True
    FReinterpretI _ _ -> True
    _ -> False
  
  