-- SPDX-FileCopyrightText: 2025-2026 Sören Tempel <soeren+git@soeren-tempel.net>
--
-- SPDX-License-Identifier: GPL-3.0-only

-- | This module describes the semantics of the [QBE](https://c9x.me/compile/)
-- intermediate representation using an abstract 'Simulator' monad.
-- Specifically, it abstractly describes the semantics of QBE's control-flow
-- constructs (such as functions, statements, and blocks) and instructions
-- using the primitives of this monad. The semantics can then be concretely
-- instantiated (refer to the instance of the 'Simulator' monad). This idea
-- is inspired by the paper [Flexible Instruction-Set Semantics via Abstract Monads]
-- (https://dl.acm.org/doi/10.1145/3607833).
module Language.QBE.Simulator
  ( BlockResult,
    execInstr,
    execStmt,
    execBlock,
    execFunc,
  )
where

import Control.Monad (unless, void, when)
import Control.Monad.Error.Class (throwError)
import Data.Functor ((<&>))
import Data.List (elemIndex, uncons)
import Data.Map qualified as Map
import Data.Maybe (fromMaybe, isJust, isNothing)
import Data.Word (Word8)
import Language.QBE.Simulator.Default.Expression qualified as DE
import Language.QBE.Simulator.Default.State
import Language.QBE.Simulator.Error
import Language.QBE.Simulator.Expression qualified as E
import Language.QBE.Simulator.Memory (addrOverlap)
import Language.QBE.Simulator.State
import Language.QBE.Types qualified as QBE

-- | Execution of a 'QBE.Block' can either return (with an optional return
-- value) or it can jump to another 'QBE.Block' which will then be executed.
type BlockResult v = (Either (Maybe v) QBE.Block)

------------------------------------------------------------------------

execVolatile :: (Simulator m v) => QBE.VolatileInstr -> m ()
execVolatile :: forall (m :: * -> *) v. Simulator m v => VolatileInstr -> m ()
execVolatile (QBE.Store ExtType
valTy Value
valReg Value
addrReg) = do
  -- Since byte and half are not first-class types in the IL, they are
  -- stored as words and have to be looked up as such.
  v
val <- case ExtType
valTy of
    ExtType
QBE.Byte -> BaseType -> Value -> m v
forall (m :: * -> *) v. Simulator m v => BaseType -> Value -> m v
lookupValue BaseType
QBE.Word Value
valReg
    ExtType
QBE.HalfWord -> BaseType -> Value -> m v
forall (m :: * -> *) v. Simulator m v => BaseType -> Value -> m v
lookupValue BaseType
QBE.Word Value
valReg
    (QBE.Base BaseType
bt) -> BaseType -> Value -> m v
forall (m :: * -> *) v. Simulator m v => BaseType -> Value -> m v
lookupValue BaseType
bt Value
valReg

  Address
addr <- BaseType -> Value -> m v
forall (m :: * -> *) v. Simulator m v => BaseType -> Value -> m v
lookupValue BaseType
QBE.Long Value
addrReg m v -> (v -> m Address) -> m Address
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= v -> m Address
forall (m :: * -> *) v. Simulator m v => v -> m Address
toAddress
  Address -> ExtType -> v -> m ()
forall (m :: * -> *) v.
Simulator m v =>
Address -> ExtType -> v -> m ()
writeMemory Address
addr ExtType
valTy v
val
execVolatile (QBE.Blit Value
src Value
dst Address
toCopy) = do
  v
srcAddrVal <- BaseType -> Value -> m v
forall (m :: * -> *) v. Simulator m v => BaseType -> Value -> m v
lookupValue BaseType
QBE.Long Value
src
  v
dstAddrVal <- BaseType -> Value -> m v
forall (m :: * -> *) v. Simulator m v => BaseType -> Value -> m v
lookupValue BaseType
QBE.Long Value
dst

  -- TODO: Check for invalid BLITs
  Address
srcAddr <- v -> m Address
forall (m :: * -> *) v. Simulator m v => v -> m Address
toAddress v
srcAddrVal
  Address
dstAddr <- v -> m Address
forall (m :: * -> *) v. Simulator m v => v -> m Address
toAddress v
dstAddrVal
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Address
srcAddr Address -> Address -> Bool
forall a. Eq a => a -> a -> Bool
/= Address
dstAddr Bool -> Bool -> Bool
&& Address -> Address -> Address -> Bool
addrOverlap Address
srcAddr Address
dstAddr Address
toCopy) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    EvalError -> m ()
forall a. EvalError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (EvalError -> m ()) -> EvalError -> m ()
forall a b. (a -> b) -> a -> b
$
      Address -> Address -> EvalError
OverlappingBlit Address
srcAddr Address
dstAddr

  -- Somehow allow specialization of memory copies, e.g. for qute-symex.
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Address
toCopy Address -> Address -> Bool
forall a. Ord a => a -> a -> Bool
> Address
0) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    (Address -> m ()) -> [Address] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
      ( \Address
off -> do
          v
srcByte <- LoadType -> Address -> m v
forall (m :: * -> *) v. Simulator m v => LoadType -> Address -> m v
readMemory (SubWordType -> LoadType
QBE.LSubWord SubWordType
QBE.UnsignedByte) (Address
srcAddr Address -> Address -> Address
forall a. Num a => a -> a -> a
+ Address
off)
          Address -> ExtType -> v -> m ()
forall (m :: * -> *) v.
Simulator m v =>
Address -> ExtType -> v -> m ()
writeMemory (Address
dstAddr Address -> Address -> Address
forall a. Num a => a -> a -> a
+ Address
off) ExtType
QBE.Byte v
srcByte
      )
      [Address
0 .. Address
toCopy Address -> Address -> Address
forall a. Num a => a -> a -> a
- Address
1]
execVolatile (QBE.VAStart Value
val) = do
  Address
ptr <- BaseType -> Value -> m v
forall (m :: * -> *) v. Simulator m v => BaseType -> Value -> m v
lookupValue BaseType
QBE.Long Value
val m v -> (v -> m Address) -> m Address
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= v -> m Address
forall (m :: * -> *) v. Simulator m v => v -> m Address
toAddress
  StackFrame v
stk <- m (StackFrame v)
forall (m :: * -> *) v. Simulator m v => m (StackFrame v)
activeFrame

  [(v, Address)]
addrs <- (v -> m (v, Address)) -> [v] -> m [(v, Address)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\v
v -> (v
v,) (Address -> (v, Address)) -> m Address -> m (v, Address)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> v -> m Address
forall (m :: * -> *) v. Simulator m v => v -> m Address
stackSpill v
v) (StackFrame v -> [v]
forall v. StackFrame v -> [v]
stkVarArgs StackFrame v
stk)
  case [(v, Address)] -> Maybe ((v, Address), [(v, Address)])
forall a. [a] -> Maybe (a, [a])
uncons [(v, Address)]
addrs of
    Just ((v
firstValue, Address
firstAddr), [(v, Address)]
_) -> do
      let valType :: ExtType
valType = v -> ExtType
forall v. ValueRepr v => v -> ExtType
E.getType v
firstValue
          valSize :: Address
valSize = Int -> Address
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Address) -> Int -> Address
forall a b. (a -> b) -> a -> b
$ ExtType -> Int
QBE.extTypeByteSize ExtType
valType

      -- Initially, the pointer stored in our representation of the “variable
      -- argument list” points one element beyond the argument list. This
      -- allows us to determine the element pointer in `vaarg` by always
      -- substracting the size of the requested element from the pointer.
      Address -> ExtType -> v -> m ()
forall (m :: * -> *) v.
Simulator m v =>
Address -> ExtType -> v -> m ()
writeMemory Address
ptr (BaseType -> ExtType
QBE.Base BaseType
QBE.Long) (v -> m ()) -> v -> m ()
forall a b. (a -> b) -> a -> b
$
        ExtType -> Address -> v
forall v. ValueRepr v => ExtType -> Address -> v
E.fromLit (BaseType -> ExtType
QBE.Base BaseType
QBE.Long) (Address
firstAddr Address -> Address -> Address
forall a. Num a => a -> a -> a
+ Address
valSize)
    Maybe ((v, Address), [(v, Address)])
Nothing -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
execVolatile (QBE.DBGLoc {}) = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
{-# INLINEABLE execVolatile #-}

execBinaryTy ::
  (Simulator m v) =>
  QBE.BaseType ->
  (v -> v -> Maybe v) ->
  (QBE.BaseType, QBE.Value) ->
  (QBE.BaseType, QBE.Value) ->
  m v
execBinaryTy :: forall (m :: * -> *) v.
Simulator m v =>
BaseType
-> (v -> v -> Maybe v)
-> (BaseType, Value)
-> (BaseType, Value)
-> m v
execBinaryTy BaseType
retTy v -> v -> Maybe v
op (BaseType
lty, Value
lhs) (BaseType
rty, Value
rhs) = do
  v
v1 <- BaseType -> Value -> m v
forall (m :: * -> *) v. Simulator m v => BaseType -> Value -> m v
lookupValue BaseType
lty Value
lhs
  v
v2 <- BaseType -> Value -> m v
forall (m :: * -> *) v. Simulator m v => BaseType -> Value -> m v
lookupValue BaseType
rty Value
rhs
  BaseType -> (v -> v -> Maybe v) -> v -> v -> m v
forall (m :: * -> *) v.
Simulator m v =>
BaseType -> (v -> v -> Maybe v) -> v -> v -> m v
runBinary BaseType
retTy v -> v -> Maybe v
op v
v1 v
v2

execBinary ::
  (Simulator m v) =>
  QBE.BaseType ->
  (v -> v -> Maybe v) ->
  QBE.Value ->
  QBE.Value ->
  m v
execBinary :: forall (m :: * -> *) v.
Simulator m v =>
BaseType -> (v -> v -> Maybe v) -> Value -> Value -> m v
execBinary BaseType
retTy v -> v -> Maybe v
op Value
lhs Value
rhs =
  BaseType
-> (v -> v -> Maybe v)
-> (BaseType, Value)
-> (BaseType, Value)
-> m v
forall (m :: * -> *) v.
Simulator m v =>
BaseType
-> (v -> v -> Maybe v)
-> (BaseType, Value)
-> (BaseType, Value)
-> m v
execBinaryTy BaseType
retTy v -> v -> Maybe v
op (BaseType
retTy, Value
lhs) (BaseType
retTy, Value
rhs)
{-# INLINE execBinary #-}

execShift ::
  (Simulator m v) =>
  QBE.BaseType ->
  (v -> v -> Maybe v) ->
  QBE.Value ->
  QBE.Value ->
  m v
execShift :: forall (m :: * -> *) v.
Simulator m v =>
BaseType -> (v -> v -> Maybe v) -> Value -> Value -> m v
execShift BaseType
retTy v -> v -> Maybe v
op Value
lhs Value
amount =
  BaseType
-> (v -> v -> Maybe v)
-> (BaseType, Value)
-> (BaseType, Value)
-> m v
forall (m :: * -> *) v.
Simulator m v =>
BaseType
-> (v -> v -> Maybe v)
-> (BaseType, Value)
-> (BaseType, Value)
-> m v
execBinaryTy BaseType
retTy v -> v -> Maybe v
op (BaseType
retTy, Value
lhs) (BaseType
QBE.Word, Value
amount)
{-# INLINE execShift #-}

-- | Execute a single 'QBE.Instr'. The 'QBE.BaseType' denotes the return value type.
-- For example, as provided in the enclosing 'QBE.Assign'.
execInstr :: (Simulator m v) => QBE.BaseType -> QBE.Instr -> m v
execInstr :: forall (m :: * -> *) v. Simulator m v => BaseType -> Instr -> m v
execInstr BaseType
retTy (QBE.Neg Value
op) = do
  v
v <- BaseType -> Value -> m v
forall (m :: * -> *) v. Simulator m v => BaseType -> Value -> m v
lookupValue BaseType
retTy Value
op
  EvalError -> Maybe v -> m v
forall (m :: * -> *) a.
MonadError EvalError m =>
EvalError -> Maybe a -> m a
liftMaybe EvalError
TypingError (v -> Maybe v
forall v. ValueRepr v => v -> Maybe v
E.neg v
v)
execInstr BaseType
retTy (QBE.Add Value
lhs Value
rhs) = BaseType -> (v -> v -> Maybe v) -> Value -> Value -> m v
forall (m :: * -> *) v.
Simulator m v =>
BaseType -> (v -> v -> Maybe v) -> Value -> Value -> m v
execBinary BaseType
retTy v -> v -> Maybe v
forall v. ValueRepr v => v -> v -> Maybe v
E.add Value
lhs Value
rhs
execInstr BaseType
retTy (QBE.Sub Value
lhs Value
rhs) = BaseType -> (v -> v -> Maybe v) -> Value -> Value -> m v
forall (m :: * -> *) v.
Simulator m v =>
BaseType -> (v -> v -> Maybe v) -> Value -> Value -> m v
execBinary BaseType
retTy v -> v -> Maybe v
forall v. ValueRepr v => v -> v -> Maybe v
E.sub Value
lhs Value
rhs
execInstr BaseType
retTy (QBE.Mul Value
lhs Value
rhs) = BaseType -> (v -> v -> Maybe v) -> Value -> Value -> m v
forall (m :: * -> *) v.
Simulator m v =>
BaseType -> (v -> v -> Maybe v) -> Value -> Value -> m v
execBinary BaseType
retTy v -> v -> Maybe v
forall v. ValueRepr v => v -> v -> Maybe v
E.mul Value
lhs Value
rhs
execInstr BaseType
retTy (QBE.Div Value
lhs Value
rhs) = BaseType -> (v -> v -> Maybe v) -> Value -> Value -> m v
forall (m :: * -> *) v.
Simulator m v =>
BaseType -> (v -> v -> Maybe v) -> Value -> Value -> m v
execBinary BaseType
retTy v -> v -> Maybe v
forall v. ValueRepr v => v -> v -> Maybe v
E.div Value
lhs Value
rhs
execInstr BaseType
retTy (QBE.Or Value
lhs Value
rhs) = BaseType -> (v -> v -> Maybe v) -> Value -> Value -> m v
forall (m :: * -> *) v.
Simulator m v =>
BaseType -> (v -> v -> Maybe v) -> Value -> Value -> m v
execBinary BaseType
retTy v -> v -> Maybe v
forall v. ValueRepr v => v -> v -> Maybe v
E.or Value
lhs Value
rhs
execInstr BaseType
retTy (QBE.Xor Value
lhs Value
rhs) = BaseType -> (v -> v -> Maybe v) -> Value -> Value -> m v
forall (m :: * -> *) v.
Simulator m v =>
BaseType -> (v -> v -> Maybe v) -> Value -> Value -> m v
execBinary BaseType
retTy v -> v -> Maybe v
forall v. ValueRepr v => v -> v -> Maybe v
E.xor Value
lhs Value
rhs
execInstr BaseType
retTy (QBE.And Value
lhs Value
rhs) = BaseType -> (v -> v -> Maybe v) -> Value -> Value -> m v
forall (m :: * -> *) v.
Simulator m v =>
BaseType -> (v -> v -> Maybe v) -> Value -> Value -> m v
execBinary BaseType
retTy v -> v -> Maybe v
forall v. ValueRepr v => v -> v -> Maybe v
E.and Value
lhs Value
rhs
execInstr BaseType
retTy (QBE.URem Value
lhs Value
rhs) = BaseType -> (v -> v -> Maybe v) -> Value -> Value -> m v
forall (m :: * -> *) v.
Simulator m v =>
BaseType -> (v -> v -> Maybe v) -> Value -> Value -> m v
execBinary BaseType
retTy v -> v -> Maybe v
forall v. ValueRepr v => v -> v -> Maybe v
E.urem Value
lhs Value
rhs
execInstr BaseType
retTy (QBE.Rem Value
lhs Value
rhs) = BaseType -> (v -> v -> Maybe v) -> Value -> Value -> m v
forall (m :: * -> *) v.
Simulator m v =>
BaseType -> (v -> v -> Maybe v) -> Value -> Value -> m v
execBinary BaseType
retTy v -> v -> Maybe v
forall v. ValueRepr v => v -> v -> Maybe v
E.srem Value
lhs Value
rhs
execInstr BaseType
retTy (QBE.UDiv Value
lhs Value
rhs) = BaseType -> (v -> v -> Maybe v) -> Value -> Value -> m v
forall (m :: * -> *) v.
Simulator m v =>
BaseType -> (v -> v -> Maybe v) -> Value -> Value -> m v
execBinary BaseType
retTy v -> v -> Maybe v
forall v. ValueRepr v => v -> v -> Maybe v
E.udiv Value
lhs Value
rhs
execInstr BaseType
retTy (QBE.Sar Value
lhs Value
rhs) = BaseType -> (v -> v -> Maybe v) -> Value -> Value -> m v
forall (m :: * -> *) v.
Simulator m v =>
BaseType -> (v -> v -> Maybe v) -> Value -> Value -> m v
execShift BaseType
retTy v -> v -> Maybe v
forall v. ValueRepr v => v -> v -> Maybe v
E.sar Value
lhs Value
rhs
execInstr BaseType
retTy (QBE.Shr Value
lhs Value
rhs) = BaseType -> (v -> v -> Maybe v) -> Value -> Value -> m v
forall (m :: * -> *) v.
Simulator m v =>
BaseType -> (v -> v -> Maybe v) -> Value -> Value -> m v
execShift BaseType
retTy v -> v -> Maybe v
forall v. ValueRepr v => v -> v -> Maybe v
E.shr Value
lhs Value
rhs
execInstr BaseType
retTy (QBE.Shl Value
lhs Value
rhs) = BaseType -> (v -> v -> Maybe v) -> Value -> Value -> m v
forall (m :: * -> *) v.
Simulator m v =>
BaseType -> (v -> v -> Maybe v) -> Value -> Value -> m v
execShift BaseType
retTy v -> v -> Maybe v
forall v. ValueRepr v => v -> v -> Maybe v
E.shl Value
lhs Value
rhs
execInstr BaseType
retTy (QBE.Load LoadType
ty Value
addrVal) = do
  Address
addr <- BaseType -> Value -> m v
forall (m :: * -> *) v. Simulator m v => BaseType -> Value -> m v
lookupValue BaseType
QBE.Long Value
addrVal m v -> (v -> m Address) -> m Address
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= v -> m Address
forall (m :: * -> *) v. Simulator m v => v -> m Address
toAddress
  v
val <- LoadType -> Address -> m v
forall (m :: * -> *) v. Simulator m v => LoadType -> Address -> m v
readMemory LoadType
ty Address
addr
  BaseType -> v -> m v
forall (m :: * -> *) v. Simulator m v => BaseType -> v -> m v
subType BaseType
retTy v
val
execInstr BaseType
QBE.Long (QBE.Alloc AllocSize
align Value
sizeValue) = do
  v
size <- BaseType -> Value -> m v
forall (m :: * -> *) v. Simulator m v => BaseType -> Value -> m v
lookupValue BaseType
QBE.Long Value
sizeValue
  v -> Address -> m v
forall (m :: * -> *) v. Simulator m v => v -> Address -> m v
stackAlloc v
size (Int -> Address
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Address) -> Int -> Address
forall a b. (a -> b) -> a -> b
$ AllocSize -> Int
QBE.getSize AllocSize
align)
execInstr BaseType
_ QBE.Alloc {} = EvalError -> m v
forall a. EvalError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError EvalError
InvalidAddressType
execInstr BaseType
retTy (QBE.CompareInt IntArg
intArg IntCmpOp
cmpOp Value
lhs Value
rhs) = do
  let cmpTy :: BaseType
cmpTy = IntArg -> BaseType
QBE.i2BaseType IntArg
intArg
  v
v1 <- BaseType -> Value -> m v
forall (m :: * -> *) v. Simulator m v => BaseType -> Value -> m v
lookupValue BaseType
cmpTy Value
lhs
  v
v2 <- BaseType -> Value -> m v
forall (m :: * -> *) v. Simulator m v => BaseType -> Value -> m v
lookupValue BaseType
cmpTy Value
rhs

  let exprOp :: v -> v -> Maybe v
exprOp = IntCmpOp -> v -> v -> Maybe v
forall v. ValueRepr v => IntCmpOp -> v -> v -> Maybe v
E.compareIntExpr IntCmpOp
cmpOp
  BaseType -> (v -> v -> Maybe v) -> v -> v -> m v
forall (m :: * -> *) v.
Simulator m v =>
BaseType -> (v -> v -> Maybe v) -> v -> v -> m v
runBinary BaseType
retTy v -> v -> Maybe v
exprOp v
v1 v
v2
execInstr BaseType
retTy (QBE.CompareFloat FloatArg
floatArg FloatCmpOp
cmpOp Value
lhs Value
rhs) = do
  let cmpTy :: BaseType
cmpTy = FloatArg -> BaseType
QBE.f2BaseType FloatArg
floatArg
  v
v1 <- BaseType -> Value -> m v
forall (m :: * -> *) v. Simulator m v => BaseType -> Value -> m v
lookupValue BaseType
cmpTy Value
lhs
  v
v2 <- BaseType -> Value -> m v
forall (m :: * -> *) v. Simulator m v => BaseType -> Value -> m v
lookupValue BaseType
cmpTy Value
rhs

  let exprOp :: v -> v -> Maybe v
exprOp = FloatCmpOp -> v -> v -> Maybe v
forall v. ValueRepr v => FloatCmpOp -> v -> v -> Maybe v
E.compareFloatExpr FloatCmpOp
cmpOp
  BaseType -> (v -> v -> Maybe v) -> v -> v -> m v
forall (m :: * -> *) v.
Simulator m v =>
BaseType -> (v -> v -> Maybe v) -> v -> v -> m v
runBinary BaseType
retTy v -> v -> Maybe v
exprOp v
v1 v
v2
-- exts is only valid with a double return type.
execInstr BaseType
QBE.Double (QBE.Ext ExtArg
QBE.ExtSingle Value
value) = do
  v
v <- BaseType -> Value -> m v
forall (m :: * -> *) v. Simulator m v => BaseType -> Value -> m v
lookupValue BaseType
QBE.Single Value
value
  EvalError -> Maybe v -> m v
forall (m :: * -> *) a.
MonadError EvalError m =>
EvalError -> Maybe a -> m a
liftMaybe EvalError
TypingError (Maybe v -> m v) -> Maybe v -> m v
forall a b. (a -> b) -> a -> b
$ v -> Maybe v
forall v. ValueRepr v => v -> Maybe v
E.extendFloat v
v
execInstr BaseType
retTy (QBE.Ext ExtArg
extArg Value
value) = do
  v
v <- BaseType -> Value -> m v
forall (m :: * -> *) v. Simulator m v => BaseType -> Value -> m v
lookupValue BaseType
QBE.Word Value
value
  let (Bool
isSigned, ExtType
extTy) = ExtArg -> (Bool, ExtType)
QBE.toExtType ExtArg
extArg
  EvalError -> Maybe v -> m v
forall (m :: * -> *) a.
MonadError EvalError m =>
EvalError -> Maybe a -> m a
liftMaybe
    EvalError
TypingError
    (ExtType -> v -> Maybe v
forall v. ValueRepr v => ExtType -> v -> Maybe v
E.extract ExtType
extTy v
v Maybe v -> (v -> Maybe v) -> Maybe v
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ExtType -> Bool -> v -> Maybe v
forall v. ValueRepr v => ExtType -> Bool -> v -> Maybe v
E.extend (BaseType -> ExtType
QBE.Base BaseType
retTy) Bool
isSigned)
execInstr BaseType
QBE.Single (QBE.TruncDouble Value
value) = do
  v
v <- BaseType -> Value -> m v
forall (m :: * -> *) v. Simulator m v => BaseType -> Value -> m v
lookupValue BaseType
QBE.Double Value
value
  EvalError -> Maybe v -> m v
forall (m :: * -> *) a.
MonadError EvalError m =>
EvalError -> Maybe a -> m a
liftMaybe EvalError
TypingError (Maybe v -> m v) -> Maybe v -> m v
forall a b. (a -> b) -> a -> b
$ v -> Maybe v
forall v. ValueRepr v => v -> Maybe v
E.truncFloat v
v
-- truncd is only valid with a single return type.
execInstr BaseType
_ (QBE.TruncDouble Value
_) = EvalError -> m v
forall a. EvalError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError EvalError
TypingError
execInstr BaseType
retTy (QBE.Copy Value
value) = BaseType -> Value -> m v
forall (m :: * -> *) v. Simulator m v => BaseType -> Value -> m v
lookupValue BaseType
retTy Value
value
execInstr BaseType
retTy (QBE.FloatToInt FloatArg
floatArg Bool
isSigned Value
value) = do
  v
v <- BaseType -> Value -> m v
forall (m :: * -> *) v. Simulator m v => BaseType -> Value -> m v
lookupValue (FloatArg -> BaseType
QBE.f2BaseType FloatArg
floatArg) Value
value
  EvalError -> Maybe v -> m v
forall (m :: * -> *) a.
MonadError EvalError m =>
EvalError -> Maybe a -> m a
liftMaybe EvalError
TypingError (Maybe v -> m v) -> Maybe v -> m v
forall a b. (a -> b) -> a -> b
$ ExtType -> Bool -> v -> Maybe v
forall v. ValueRepr v => ExtType -> Bool -> v -> Maybe v
E.floatToInt (BaseType -> ExtType
QBE.Base BaseType
retTy) Bool
isSigned v
v
execInstr BaseType
retTy (QBE.IntToFloat IntArg
intArg Bool
isSigned Value
value) = do
  v
v <- BaseType -> Value -> m v
forall (m :: * -> *) v. Simulator m v => BaseType -> Value -> m v
lookupValue (IntArg -> BaseType
QBE.i2BaseType IntArg
intArg) Value
value
  EvalError -> Maybe v -> m v
forall (m :: * -> *) a.
MonadError EvalError m =>
EvalError -> Maybe a -> m a
liftMaybe EvalError
TypingError (Maybe v -> m v) -> Maybe v -> m v
forall a b. (a -> b) -> a -> b
$ ExtType -> Bool -> v -> Maybe v
forall v. ValueRepr v => ExtType -> Bool -> v -> Maybe v
E.intToFloat (BaseType -> ExtType
QBE.Base BaseType
retTy) Bool
isSigned v
v
execInstr BaseType
retTy (QBE.Cast Value
value) = do
  -- We must deduce the value type to use for lookup from
  -- the return type as manadated by the cast type string.
  let valueType :: BaseType
valueType =
        case BaseType
retTy of
          BaseType
QBE.Word -> BaseType
QBE.Single
          BaseType
QBE.Long -> BaseType
QBE.Double
          BaseType
QBE.Single -> BaseType
QBE.Word
          BaseType
QBE.Double -> BaseType
QBE.Long

  -- TODO: Consider adding an explicit operation for casting
  -- of floating points to the expression language abstraction.
  v
v <- BaseType -> Value -> m v
forall (m :: * -> *) v. Simulator m v => BaseType -> Value -> m v
lookupValue BaseType
valueType Value
value
  v -> m v
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ExtType -> Address -> v
forall v. ValueRepr v => ExtType -> Address -> v
E.fromLit (BaseType -> ExtType
QBE.Base BaseType
retTy) (Address -> v) -> Address -> v
forall a b. (a -> b) -> a -> b
$ v -> Address
forall v. ValueRepr v => v -> Address
E.toWord64 v
v)
execInstr BaseType
retTy (QBE.VAArg Value
argLst) = do
  -- 'argsCtx' represents the “variable argument list”. Currently,
  -- it is not modeled after a specific ABI but simply contains a
  -- pointer to the previous argument. This pointer is updated by
  -- each invocation of the `vaarg` instruction.
  Address
argsCtx <- BaseType -> Value -> m v
forall (m :: * -> *) v. Simulator m v => BaseType -> Value -> m v
lookupValue BaseType
QBE.Long Value
argLst m v -> (v -> m Address) -> m Address
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= v -> m Address
forall (m :: * -> *) v. Simulator m v => v -> m Address
toAddress

  v
prevPtr <- LoadType -> Address -> m v
forall (m :: * -> *) v. Simulator m v => LoadType -> Address -> m v
readMemory (BaseType -> LoadType
QBE.LBase BaseType
QBE.Long) Address
argsCtx
  let retTySize :: v
retTySize =
        ExtType -> Address -> v
forall v. ValueRepr v => ExtType -> Address -> v
E.fromLit
          (BaseType -> ExtType
QBE.Base BaseType
QBE.Long)
          (Int -> Address
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Address) -> Int -> Address
forall a b. (a -> b) -> a -> b
$ BaseType -> Int
QBE.baseTypeByteSize BaseType
retTy)

  -- Obtain current pointer by subtracting size from 'prevPtr'
  -- and align the pointer down to the nearest aligned address.
  v
ptrAligned <-
    EvalError -> Maybe v -> m v
forall (m :: * -> *) a.
MonadError EvalError m =>
EvalError -> Maybe a -> m a
liftMaybe EvalError
InvalidAddressType (Maybe v -> m v) -> Maybe v -> m v
forall a b. (a -> b) -> a -> b
$
      (v
prevPtr v -> v -> Maybe v
forall v. ValueRepr v => v -> v -> Maybe v
`E.sub` v
retTySize) Maybe v -> (v -> Maybe v) -> Maybe v
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (v -> v -> Maybe v
forall v. ValueRepr v => v -> v -> Maybe v
`stackAlign` v
retTySize)

  v
val <- v -> m Address
forall (m :: * -> *) v. Simulator m v => v -> m Address
toAddress v
ptrAligned m Address -> (Address -> m v) -> m v
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LoadType -> Address -> m v
forall (m :: * -> *) v. Simulator m v => LoadType -> Address -> m v
readMemory (BaseType -> LoadType
QBE.LBase BaseType
retTy)
  Address -> ExtType -> v -> m ()
forall (m :: * -> *) v.
Simulator m v =>
Address -> ExtType -> v -> m ()
writeMemory Address
argsCtx (BaseType -> ExtType
QBE.Base BaseType
QBE.Long) v
ptrAligned
  v -> m v
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure v
val
{-# INLINEABLE execInstr #-}

-- | Execute a 'QBE.Statement', usually a sequence of 'QBE.Instruction'.
-- Therefore, this function iteratively calls 'execInstr' in the common case.
execStmt :: (Simulator m v) => QBE.Statement -> m ()
execStmt :: forall (m :: * -> *) v. Simulator m v => Statement -> m ()
execStmt (QBE.Assign LocalIdent
name BaseType
ty Instr
inst) = do
  v
newVal <- BaseType -> Instr -> m v
forall (m :: * -> *) v. Simulator m v => BaseType -> Instr -> m v
execInstr BaseType
ty Instr
inst
  (StackFrame v -> StackFrame v) -> m ()
forall (m :: * -> *) v.
Simulator m v =>
(StackFrame v -> StackFrame v) -> m ()
modifyFrame (LocalIdent -> v -> StackFrame v -> StackFrame v
forall v. LocalIdent -> v -> StackFrame v -> StackFrame v
storeLocal LocalIdent
name v
newVal)
execStmt (QBE.Volatile VolatileInstr
v) = VolatileInstr -> m ()
forall (m :: * -> *) v. Simulator m v => VolatileInstr -> m ()
execVolatile VolatileInstr
v
execStmt (QBE.Call Maybe (LocalIdent, Abity)
ret Value
toCall [FuncArg]
params) = do
  SomeFunc m v
function <- Value -> m (SomeFunc m v)
forall (m :: * -> *) v. Simulator m v => Value -> m (SomeFunc m v)
lookupFunc Value
toCall
  [v]
funcArgs <- [FuncArg] -> m [v]
forall (m :: * -> *) v. Simulator m v => [FuncArg] -> m [v]
lookupArgs [FuncArg]
params
  -- Sanity chekcs on funcArgs are performed by execFunc.

  Maybe v
mayRetVal <- case SomeFunc m v
function of
    SFuncDef FuncDef
funcDef -> FuncDef -> [v] -> m (Maybe v)
forall (m :: * -> *) v.
Simulator m v =>
FuncDef -> [v] -> m (Maybe v)
execFunc FuncDef
funcDef [v]
funcArgs
    SSimFunc [v] -> m (Maybe v)
simFunc -> [v] -> m (Maybe v)
simFunc [v]
funcArgs

  case Maybe v
mayRetVal of
    Maybe v
Nothing ->
      -- XXX: Could also check funcDef for the return value.
      if Maybe (LocalIdent, Abity) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (LocalIdent, Abity)
ret
        then () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        else EvalError -> m ()
forall a. EvalError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError EvalError
FunctionReturnIgnored
    Just v
retVal ->
      case Maybe (LocalIdent, Abity)
ret of
        Maybe (LocalIdent, Abity)
Nothing -> EvalError -> m ()
forall a. EvalError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError EvalError
AssignedVoidReturnValue
        Just (LocalIdent
ident, Abity
abity) -> do
          let baseTy :: BaseType
baseTy = Abity -> BaseType
QBE.abityToBase Abity
abity
          v
subTyped <- BaseType -> v -> m v
forall (m :: * -> *) v. Simulator m v => BaseType -> v -> m v
subType BaseType
baseTy v
retVal
          (StackFrame v -> StackFrame v) -> m ()
forall (m :: * -> *) v.
Simulator m v =>
(StackFrame v -> StackFrame v) -> m ()
modifyFrame (LocalIdent -> v -> StackFrame v -> StackFrame v
forall v. LocalIdent -> v -> StackFrame v -> StackFrame v
storeLocal LocalIdent
ident v
subTyped)
{-# INLINEABLE execStmt #-}

execJump :: (Simulator m v) => QBE.JumpInstr -> m (BlockResult v)
execJump :: forall (m :: * -> *) v.
Simulator m v =>
JumpInstr -> m (BlockResult v)
execJump JumpInstr
QBE.Halt = EvalError -> m (BlockResult v)
forall a. EvalError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError EvalError
EncounteredHalt
execJump (QBE.Jump BlockIdent
ident) = do
  Map BlockIdent Block
blocks <- FuncDef -> Map BlockIdent Block
QBE.fBlock (FuncDef -> Map BlockIdent Block)
-> m FuncDef -> m (Map BlockIdent Block)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (m (StackFrame v)
forall (m :: * -> *) v. Simulator m v => m (StackFrame v)
activeFrame m (StackFrame v) -> (StackFrame v -> FuncDef) -> m FuncDef
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> StackFrame v -> FuncDef
forall v. StackFrame v -> FuncDef
stkFunc)
  case BlockIdent -> Map BlockIdent Block -> Maybe Block
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup BlockIdent
ident Map BlockIdent Block
blocks of
    Just Block
bl -> BlockResult v -> m (BlockResult v)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BlockResult v -> m (BlockResult v))
-> BlockResult v -> m (BlockResult v)
forall a b. (a -> b) -> a -> b
$ Block -> BlockResult v
forall a b. b -> Either a b
Right Block
bl
    Maybe Block
Nothing -> EvalError -> m (BlockResult v)
forall a. EvalError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (BlockIdent -> EvalError
UnknownBlock BlockIdent
ident)
execJump (QBE.Jnz Value
cond BlockIdent
ifT BlockIdent
ifF) = do
  v
condValue <- BaseType -> Value -> m v
forall (m :: * -> *) v. Simulator m v => BaseType -> Value -> m v
lookupValue BaseType
QBE.Word Value
cond
  Bool
condResult <- v -> m Bool
forall (m :: * -> *) v. Simulator m v => v -> m Bool
isTrue v
condValue
  JumpInstr -> m (BlockResult v)
forall (m :: * -> *) v.
Simulator m v =>
JumpInstr -> m (BlockResult v)
execJump (JumpInstr -> m (BlockResult v)) -> JumpInstr -> m (BlockResult v)
forall a b. (a -> b) -> a -> b
$ BlockIdent -> JumpInstr
QBE.Jump (if Bool
condResult then BlockIdent
ifT else BlockIdent
ifF)
execJump (QBE.Return Maybe Value
v) = do
  FuncDef
func <- m (StackFrame v)
forall (m :: * -> *) v. Simulator m v => m (StackFrame v)
activeFrame m (StackFrame v) -> (StackFrame v -> FuncDef) -> m FuncDef
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> StackFrame v -> FuncDef
forall v. StackFrame v -> FuncDef
stkFunc
  case FuncDef -> Maybe Abity
QBE.fAbity FuncDef
func of
    Just Abity
abity -> do
      Value
retVal <-
        case Maybe Value
v of
          Maybe Value
Nothing -> EvalError -> m Value
forall a. EvalError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError EvalError
InvalidReturnValue
          Just Value
x -> Value -> m Value
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
x
      BaseType -> Value -> m v
forall (m :: * -> *) v. Simulator m v => BaseType -> Value -> m v
lookupValue (Abity -> BaseType
QBE.abityToBase Abity
abity) Value
retVal m v -> (v -> BlockResult v) -> m (BlockResult v)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Maybe v -> BlockResult v
forall a b. a -> Either a b
Left (Maybe v -> BlockResult v) -> (v -> Maybe v) -> v -> BlockResult v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> Maybe v
forall a. a -> Maybe a
Just)
    Maybe Abity
Nothing ->
      if Maybe Value -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Value
v
        then BlockResult v -> m (BlockResult v)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe v -> BlockResult v
forall a b. a -> Either a b
Left Maybe v
forall a. Maybe a
Nothing)
        else EvalError -> m (BlockResult v)
forall a. EvalError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError EvalError
InvalidReturnValue
{-# INLINEABLE execJump #-}

execPhi :: (Simulator m v) => Maybe QBE.BlockIdent -> QBE.Phi -> m ()
execPhi :: forall (m :: * -> *) v.
Simulator m v =>
Maybe BlockIdent -> Phi -> m ()
execPhi Maybe BlockIdent
Nothing Phi
_ = EvalError -> m ()
forall a. EvalError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError EvalError
InvalidPhiPosition
execPhi (Just BlockIdent
prevIdent) (QBE.Phi LocalIdent
name BaseType
ty Map BlockIdent Value
labels) =
  case BlockIdent -> Map BlockIdent Value -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup BlockIdent
prevIdent Map BlockIdent Value
labels of
    Maybe Value
Nothing -> EvalError -> m ()
forall a. EvalError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (BlockIdent -> EvalError
UnknownBlock BlockIdent
prevIdent)
    Just Value
v -> do
      v
retVal <- BaseType -> Value -> m v
forall (m :: * -> *) v. Simulator m v => BaseType -> Value -> m v
lookupValue BaseType
ty Value
v
      (StackFrame v -> StackFrame v) -> m ()
forall (m :: * -> *) v.
Simulator m v =>
(StackFrame v -> StackFrame v) -> m ()
modifyFrame (LocalIdent -> v -> StackFrame v -> StackFrame v
forall v. LocalIdent -> v -> StackFrame v -> StackFrame v
storeLocal LocalIdent
name v
retVal)
{-# INLINEABLE execPhi #-}

-- | Execute a BasicBlock, as represented by 'QBE.Block', by iteratively
-- invoking 'execStmt'. If this isn't the first executed BasicBlock within a a
-- 'QBE.Function', then the 'QBE.BlockIdent' of the previously executed
-- BasicBlock should be provided. This is required to properly execute [phi
-- instructions](https://c9x.me/compile/doc/il-v1.2.html#Phi).
execBlock :: (Simulator m v) => Maybe QBE.BlockIdent -> QBE.Block -> m (BlockResult v)
execBlock :: forall (m :: * -> *) v.
Simulator m v =>
Maybe BlockIdent -> Block -> m (BlockResult v)
execBlock Maybe BlockIdent
prevIdent Block
block = do
  (Phi -> m ()) -> [Phi] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Maybe BlockIdent -> Phi -> m ()
forall (m :: * -> *) v.
Simulator m v =>
Maybe BlockIdent -> Phi -> m ()
execPhi Maybe BlockIdent
prevIdent) (Block -> [Phi]
QBE.phi Block
block)
  (Statement -> m ()) -> [Statement] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Statement -> m ()
forall (m :: * -> *) v. Simulator m v => Statement -> m ()
execStmt (Block -> [Statement]
QBE.stmt Block
block)
  JumpInstr -> m (BlockResult v)
forall (m :: * -> *) v.
Simulator m v =>
JumpInstr -> m (BlockResult v)
execJump (Block -> JumpInstr
QBE.term Block
block)
{-# INLINEABLE execBlock #-}

execTilRet :: (Simulator m v) => Maybe QBE.BlockIdent -> QBE.Block -> m (BlockResult v)
execTilRet :: forall (m :: * -> *) v.
Simulator m v =>
Maybe BlockIdent -> Block -> m (BlockResult v)
execTilRet Maybe BlockIdent
prevIdent Block
block = Maybe BlockIdent -> BlockResult v -> m (BlockResult v)
forall {f :: * -> *} {v}.
Simulator f v =>
Maybe BlockIdent -> BlockResult v -> f (BlockResult v)
go Maybe BlockIdent
prevIdent (Block -> BlockResult v
forall a b. b -> Either a b
Right Block
block)
  where
    go :: Maybe BlockIdent -> BlockResult v -> f (BlockResult v)
go Maybe BlockIdent
_ retValue :: BlockResult v
retValue@(Left Maybe v
_) = BlockResult v -> f (BlockResult v)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure BlockResult v
retValue
    go Maybe BlockIdent
prevIdent' (Right Block
nextBlock) =
      Maybe BlockIdent -> Block -> f (BlockResult v)
forall (m :: * -> *) v.
Simulator m v =>
Maybe BlockIdent -> Block -> m (BlockResult v)
execBlock Maybe BlockIdent
prevIdent' Block
nextBlock f (BlockResult v)
-> (BlockResult v -> f (BlockResult v)) -> f (BlockResult v)
forall a b. f a -> (a -> f b) -> f b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe BlockIdent -> BlockResult v -> f (BlockResult v)
go (BlockIdent -> Maybe BlockIdent
forall a. a -> Maybe a
Just (BlockIdent -> Maybe BlockIdent) -> BlockIdent -> Maybe BlockIdent
forall a b. (a -> b) -> a -> b
$ Block -> BlockIdent
QBE.label Block
nextBlock)
{-# INLINEABLE execTilRet #-}

-- | Execute a 'QBE.FuncDef' until function return. If the function requires arguments to
-- be passed to it, these must be provided as a list. Limited sanity checking is performed
-- to ensure that the provided arguments match the declared function parameters. The return
-- value of 'execFunc' is the return value of the executed 'QBE.FuncDef'. If the function
-- has no return value, 'Nothing' is returned here.
execFunc :: (Simulator m v) => QBE.FuncDef -> [v] -> m (Maybe v)
execFunc :: forall (m :: * -> *) v.
Simulator m v =>
FuncDef -> [v] -> m (Maybe v)
execFunc func :: FuncDef
func@(QBE.FuncDef {fParams :: FuncDef -> [FuncParam]
QBE.fParams = [FuncParam]
params}) [v]
args = do
  -- Assumption: Variadic argument has been filtered from args (see lookupArgs).
  let varIdxMay :: Maybe Int
varIdxMay = FuncParam -> [FuncParam] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex FuncParam
QBE.Variadic [FuncParam]
params
      numNamed :: Int
numNamed = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe ([v] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [v]
args) Maybe Int
varIdxMay
      argsSane :: Bool
argsSane =
        if Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust Maybe Int
varIdxMay
          then [v] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [v]
args Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= [FuncParam] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [FuncParam]
params -- +1 for filtered '...'
          else [FuncParam] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [FuncParam]
params Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [v] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [v]
args
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
argsSane (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    EvalError -> m ()
forall a. EvalError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GlobalIdent -> EvalError
FuncArgsMismatch (GlobalIdent -> EvalError) -> GlobalIdent -> EvalError
forall a b. (a -> b) -> a -> b
$ FuncDef -> GlobalIdent
QBE.fName FuncDef
func)

  -- Separate name and unnamed variadic arguments using 'numNamed'
  -- and create a 'StackFrame' for 'func' that captures both.
  let vars :: Map LocalIdent v
vars =
        [(LocalIdent, v)] -> Map LocalIdent v
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(LocalIdent, v)] -> Map LocalIdent v)
-> [(LocalIdent, v)] -> Map LocalIdent v
forall a b. (a -> b) -> a -> b
$
          [LocalIdent] -> [v] -> [(LocalIdent, v)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((FuncParam -> LocalIdent) -> [FuncParam] -> [LocalIdent]
forall a b. (a -> b) -> [a] -> [b]
map FuncParam -> LocalIdent
paramName ([FuncParam] -> [LocalIdent]) -> [FuncParam] -> [LocalIdent]
forall a b. (a -> b) -> a -> b
$ Int -> [FuncParam] -> [FuncParam]
forall a. Int -> [a] -> [a]
take Int
numNamed [FuncParam]
params) [v]
args
  m (StackFrame v) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (StackFrame v) -> m ()) -> m (StackFrame v) -> m ()
forall a b. (a -> b) -> a -> b
$ FuncDef -> Map LocalIdent v -> [v] -> m (StackFrame v)
forall (m :: * -> *) v.
Simulator m v =>
FuncDef -> Map LocalIdent v -> [v] -> m (StackFrame v)
newStackFrame FuncDef
func Map LocalIdent v
vars (Int -> [v] -> [v]
forall a. Int -> [a] -> [a]
drop Int
numNamed [v]
args)

  BlockResult v
blockResult <- Maybe BlockIdent -> Block -> m (BlockResult v)
forall (m :: * -> *) v.
Simulator m v =>
Maybe BlockIdent -> Block -> m (BlockResult v)
execTilRet Maybe BlockIdent
forall a. Maybe a
Nothing (FuncDef -> Block
QBE.fEntry FuncDef
func) m (BlockResult v) -> m () -> m (BlockResult v)
forall a b. m a -> m b -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* m ()
forall (m :: * -> *) v. Simulator m v => m ()
returnFromFunc
  case BlockResult v
blockResult of
    Right Block
_block -> EvalError -> m (Maybe v)
forall a. EvalError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError EvalError
MissingFunctionReturn
    Left Maybe v
maybeValue -> Maybe v -> m (Maybe v)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe v
maybeValue
  where
    paramName :: QBE.FuncParam -> QBE.LocalIdent
    paramName :: FuncParam -> LocalIdent
paramName (QBE.Regular Abity
_ LocalIdent
n) = LocalIdent
n
    paramName (QBE.Env LocalIdent
n) = LocalIdent
n
    paramName FuncParam
QBE.Variadic = [Char] -> LocalIdent
forall a. HasCallStack => [Char] -> a
error [Char]
"unreachable"
{-# SPECIALIZE execFunc :: QBE.FuncDef -> [DE.RegVal] -> SimState DE.RegVal Word8 (Maybe DE.RegVal) #-}
{-# INLINEABLE execFunc #-}