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

-- | This module defines the abstract 'Simulator' monad and thus provides the primitives
-- used by "Language.QBE.Simulator" to describe the semantics of the QBE intermediate
-- representation.
module Language.QBE.Simulator.State
  ( -- * Abstract Monad
    Simulator (..),

    -- * Name Resolution
    SomeFunc (..),
    lookupFunc,
    lookupArgs,
    lookupGlobal,
    lookupLocal,
    lookupValue,

    -- * Helper
    liftMaybe,
    subType,
    runBinary,
    returnFromFunc,
    readNullArray,

    -- * Stack
    StackFrame (..),
    newStackFrame,
    storeLocal,
    modifyFrame,
    stackAlign,
    stackAlloc,
    stackSpill,
  )
where

import Control.Monad.Error.Class (MonadError, throwError)
import Data.Functor ((<&>))
import Data.Map qualified as Map
import Data.Maybe (catMaybes)
import Data.Word (Word64)
import Language.QBE.Simulator.Error
import Language.QBE.Simulator.Expression qualified as E
import Language.QBE.Simulator.Memory qualified as MEM
import Language.QBE.Types qualified as QBE

-- | Representation of a stack frame on the function call stack.
data StackFrame v
  = StackFrame
  { forall v. StackFrame v -> FuncDef
stkFunc :: QBE.FuncDef,
    forall v. StackFrame v -> Map LocalIdent v
stkVars :: Map.Map QBE.LocalIdent v,
    forall v. StackFrame v -> [v]
stkVarArgs :: [v],
    forall v. StackFrame v -> v
stkFp :: v
  }

-- | Create a new t'StackFrame' and push it onto the call stack.
newStackFrame ::
  (Simulator m v) =>
  -- | Definition of the functions to which this frame belongs.
  QBE.FuncDef ->
  -- | Named arguments passed to this function.
  Map.Map QBE.LocalIdent v ->
  -- | Optional, unnamed variadic arguments.
  [v] ->
  m (StackFrame v)
newStackFrame :: forall (m :: * -> *) v.
Simulator m v =>
FuncDef -> Map LocalIdent v -> [v] -> m (StackFrame v)
newStackFrame FuncDef
f Map LocalIdent v
args [v]
variadicArgs = do
  StackFrame v
frame <- m v
forall (m :: * -> *) v. Simulator m v => m v
getSP m v -> (v -> StackFrame v) -> m (StackFrame v)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> FuncDef -> Map LocalIdent v -> [v] -> v -> StackFrame v
forall v. FuncDef -> Map LocalIdent v -> [v] -> v -> StackFrame v
StackFrame FuncDef
f Map LocalIdent v
args [v]
variadicArgs
  StackFrame v -> m ()
forall (m :: * -> *) v. Simulator m v => StackFrame v -> m ()
pushStackFrame StackFrame v
frame m () -> m (StackFrame v) -> m (StackFrame v)
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> StackFrame v -> m (StackFrame v)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StackFrame v
frame
{-# INLINEABLE newStackFrame #-}

-- | Store a local variable with a given name and value in the given t'StackFrame'.
storeLocal :: QBE.LocalIdent -> v -> StackFrame v -> StackFrame v
storeLocal :: forall v. LocalIdent -> v -> StackFrame v -> StackFrame v
storeLocal LocalIdent
ident v
value frame :: StackFrame v
frame@(StackFrame {stkVars :: forall v. StackFrame v -> Map LocalIdent v
stkVars = Map LocalIdent v
v}) =
  StackFrame v
frame {stkVars = Map.insert ident value v}

-- | Lookup a local variable in the current t'StackFrame'.
lookupLocal :: StackFrame v -> QBE.LocalIdent -> Maybe v
lookupLocal :: forall v. StackFrame v -> LocalIdent -> Maybe v
lookupLocal (StackFrame {stkVars :: forall v. StackFrame v -> Map LocalIdent v
stkVars = Map LocalIdent v
v}) = (LocalIdent -> Map LocalIdent v -> Maybe v)
-> Map LocalIdent v -> LocalIdent -> Maybe v
forall a b c. (a -> b -> c) -> b -> a -> c
flip LocalIdent -> Map LocalIdent v -> Maybe v
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Map LocalIdent v
v
{-# INLINEABLE lookupLocal #-}

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

-- | Representation of a function.
data SomeFunc m v
  = -- | A simulated function whose execution is intercepted by the Simulator.
    SSimFunc ([v] -> m (Maybe v))
  | -- | A QBE function defined in the input program.
    SFuncDef QBE.FuncDef

-- | This is an “abstract monad” representing the Simulator and allowing
-- interaction with an encapsulated Simulator state @m@. Conceptually,
-- this monads describes the primitives based on which the semantics of
-- the QBE intermediate representation are abstractly described in
-- 'Language.QBE.Simulator'.
--
-- An instance of this monad then provides concrete semantics for these
-- primitives. For example, the module "Language.QBE.Simulator.Default.State"
-- provides an implementation of a polymorphic Simulator state implement over a
-- "Control.Monad.State" monad.
--
-- The idea is inspired by Bourgeat et al. <https://doi.org/10.1145/3607833>.
class (E.ValueRepr v, MonadError EvalError m) => Simulator m v | m -> v where
  -- | Check if a value of type 'E.ValueRepr' evaluates to true. This is used
  -- within "Language.QBE.Simulator" to implement conditional jumps.
  isTrue :: v -> m Bool

  -- | Convert a value of type 'E.ValueRepr' to a 'MEM.Address' that can be
  -- used to index a "Language.QBE.Simulator.Memory".
  toAddress :: v -> m MEM.Address

  -- | Lookup the address of a data symbol.
  lookupSymbol :: QBE.GlobalIdent -> m (Maybe MEM.Address)

  -- | Find a function by name, required to implement [call instructions](https://c9x.me/compile/doc/il-v1.2.html#Call).
  findFunc :: QBE.GlobalIdent -> m (Maybe (SomeFunc m v))

  -- | Find a function by "text segment" address, used for the implementation of function pointers.
  findFuncByAddr :: MEM.Address -> m (Maybe (SomeFunc m v))

  -- | Return the t'StackFrame' of the currently executed function.
  activeFrame :: m (StackFrame v)

  -- | Push a new t'StackFrame' onto the function call stack.
  pushStackFrame :: StackFrame v -> m ()

  -- | Pop the current stack frame from the function call stack.
  -- Should throw 'EmptyStack' when invoked on an empty function call stack.
  popStackFrame :: m (StackFrame v)

  -- | Get the current value of the stack pointer.
  getSP :: m v

  -- | Set the value of the stack pointer.
  setSP :: v -> m ()

  -- | Write a value to memory.
  writeMemory :: MEM.Address -> QBE.ExtType -> v -> m () -- TODO: LoadType?

  -- | Read a value from memory.
  readMemory :: QBE.LoadType -> MEM.Address -> m v

-- | Extracts the element out of a 'Just' or throw the given 'EvalError' if
-- if its argument is 'Nothing'.
liftMaybe :: (MonadError EvalError m) => EvalError -> Maybe a -> m a
liftMaybe :: forall (m :: * -> *) a.
MonadError EvalError m =>
EvalError -> Maybe a -> m a
liftMaybe EvalError
e Maybe a
Nothing = EvalError -> m a
forall a. EvalError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError EvalError
e
liftMaybe EvalError
_ (Just a
r) = a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
r
{-# INLINE liftMaybe #-}

-- | Implements the subtyping rules of the QBE intermediate representation.
--
-- See <https://c9x.me/compile/doc/il-v1.2.html#Subtyping>.
subType :: (Simulator m v) => QBE.BaseType -> v -> m v
subType :: forall (m :: * -> *) v. Simulator m v => BaseType -> v -> m v
subType BaseType
baseTy v
v = 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
$ BaseType -> ExtType -> Maybe v
subType' BaseType
baseTy (v -> ExtType
forall v. ValueRepr v => v -> ExtType
E.getType v
v)
  where
    subType' :: BaseType -> ExtType -> Maybe v
subType' BaseType
QBE.Word (QBE.Base BaseType
QBE.Word) = v -> Maybe v
forall a. a -> Maybe a
Just v
v
    subType' BaseType
QBE.Word (QBE.Base BaseType
QBE.Long) =
      ExtType -> v -> Maybe v
forall v. ValueRepr v => ExtType -> v -> Maybe v
E.extract (BaseType -> ExtType
QBE.Base BaseType
QBE.Word) v
v
    subType' BaseType
QBE.Long (QBE.Base BaseType
QBE.Long) = v -> Maybe v
forall a. a -> Maybe a
Just v
v
    subType' BaseType
QBE.Single (QBE.Base BaseType
QBE.Single) = v -> Maybe v
forall a. a -> Maybe a
Just v
v
    subType' BaseType
QBE.Double (QBE.Base BaseType
QBE.Double) = v -> Maybe v
forall a. a -> Maybe a
Just v
v
    subType' BaseType
_ ExtType
_ = Maybe v
forall a. Maybe a
Nothing
{-# INLINEABLE subType #-}

-- | Invoke a binary operation and perform subtyping (see 'subType') on its
-- results for the provided 'QBE.BaseType'. If the operation returns a 'Nothing'
-- value a 'TypingError' is raised.
runBinary ::
  (Simulator m v) =>
  QBE.BaseType ->
  (v -> v -> Maybe v) ->
  v ->
  v ->
  m v
runBinary :: forall (m :: * -> *) v.
Simulator m v =>
BaseType -> (v -> v -> Maybe v) -> v -> v -> m v
runBinary BaseType
ty v -> v -> Maybe v
op v
lhs v
rhs =
  EvalError -> Maybe v -> m v
forall (m :: * -> *) a.
MonadError EvalError m =>
EvalError -> Maybe a -> m a
liftMaybe EvalError
TypingError (v -> v -> Maybe v
op v
lhs v
rhs) m v -> (v -> 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
>>= BaseType -> v -> m v
forall (m :: * -> *) v. Simulator m v => BaseType -> v -> m v
subType BaseType
ty
{-# INLINEABLE runBinary #-}

-- | Modify the current t'StackFrame', e.g. to add a new local variable to it.
-- If the function call stack is currently empty an 'EmptyStack' error is thrown.
modifyFrame :: (Simulator m v) => (StackFrame v -> StackFrame v) -> m ()
modifyFrame :: forall (m :: * -> *) v.
Simulator m v =>
(StackFrame v -> StackFrame v) -> m ()
modifyFrame StackFrame v -> StackFrame v
func = do
  StackFrame v
frame <- m (StackFrame v)
forall (m :: * -> *) v. Simulator m v => m (StackFrame v)
popStackFrame
  StackFrame v -> m ()
forall (m :: * -> *) v. Simulator m v => StackFrame v -> m ()
pushStackFrame (StackFrame v -> StackFrame v
func StackFrame v
frame)
{-# INLINEABLE modifyFrame #-}

-- | Align a stack address. Contrary to 'MEM.alignAddr', this rounds down to
-- the nearest aligned addressed (not up) as the stack grows downward. Further,
-- since the SP representation is presently not fixed, it operates on 'E.ValueRepr'.
stackAlign :: (E.ValueRepr v) => v -> v -> Maybe v
stackAlign :: forall v. ValueRepr v => v -> v -> Maybe v
stackAlign v
addr v
alignment =
  v
addr v -> v -> Maybe v
forall v. ValueRepr v => v -> v -> Maybe v
`E.urem` v
alignment 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
addr `E.sub`)
{-# INLINEABLE stackAlign #-}

-- | Allocate a given amount of bytes on the stack with the given alignment.
-- Advances the stack pointer accordingly.
stackAlloc :: (Simulator m v) => v -> Word64 -> m v
stackAlloc :: forall (m :: * -> *) v. Simulator m v => v -> Word64 -> m v
stackAlloc v
size Word64
align = do
  v
stkPtr <- m v
forall (m :: * -> *) v. Simulator m v => m v
getSP
  let newStkPtr :: Maybe v
newStkPtr = v
stkPtr v -> v -> Maybe v
forall v. ValueRepr v => v -> v -> Maybe v
`E.sub` v
size 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` ExtType -> Word64 -> v
forall v. ValueRepr v => ExtType -> Word64 -> v
E.fromLit (BaseType -> ExtType
QBE.Base BaseType
QBE.Long) Word64
align)
  case Maybe v
newStkPtr of
    Just v
ptr -> v -> m ()
forall (m :: * -> *) v. Simulator m v => v -> m ()
setSP v
ptr m () -> m v -> m v
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> v -> m v
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure v
ptr
    Maybe v
Nothing -> EvalError -> m v
forall a. EvalError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError EvalError
InvalidAddressType
{-# INLINEABLE stackAlloc #-}

-- | Allocate space for the given value on the stack and store it there.
-- Returns a reference (i.e., a memory address) fore the allocated memory.
stackSpill :: (Simulator m v) => v -> m MEM.Address
stackSpill :: forall (m :: * -> *) v. Simulator m v => v -> m Word64
stackSpill v
val = do
  let ty :: ExtType
ty = v -> ExtType
forall v. ValueRepr v => v -> ExtType
E.getType v
val
      size :: Word64
size = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64) -> Int -> Word64
forall a b. (a -> b) -> a -> b
$ ExtType -> Int
QBE.extTypeByteSize ExtType
ty
      sizeVal :: v
sizeVal = ExtType -> Word64 -> v
forall v. ValueRepr v => ExtType -> Word64 -> v
E.fromLit (BaseType -> ExtType
QBE.Base BaseType
QBE.Long) Word64
size
  Word64
ptr <- v -> Word64 -> m v
forall (m :: * -> *) v. Simulator m v => v -> Word64 -> m v
stackAlloc v
sizeVal Word64
size m v -> (v -> m Word64) -> m Word64
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 Word64
forall (m :: * -> *) v. Simulator m v => v -> m Word64
toAddress
  Word64 -> ExtType -> v -> m ()
forall (m :: * -> *) v.
Simulator m v =>
Word64 -> ExtType -> v -> m ()
writeMemory Word64
ptr ExtType
ty v
val
  Word64 -> m Word64
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word64
ptr
{-# INLINEABLE stackSpill #-}

-- | Trigger a function return, popping its t'StackFrame' from the call stack
-- and updating both the stack and frame pointer.
returnFromFunc :: (Simulator m v) => m ()
returnFromFunc :: forall (m :: * -> *) v. Simulator m v => m ()
returnFromFunc = m (StackFrame v)
forall (m :: * -> *) v. Simulator m v => m (StackFrame v)
popStackFrame m (StackFrame v) -> (StackFrame v -> m ()) -> m ()
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 ()
forall (m :: * -> *) v. Simulator m v => v -> m ()
setSP (v -> m ()) -> (StackFrame v -> v) -> StackFrame v -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StackFrame v -> v
forall v. StackFrame v -> v
stkFp
{-# INLINE returnFromFunc #-}

maybeLookup :: (Simulator m v) => String -> Maybe a -> m a
maybeLookup :: forall (m :: * -> *) v a. Simulator m v => String -> Maybe a -> m a
maybeLookup String
name = EvalError -> Maybe a -> m a
forall (m :: * -> *) a.
MonadError EvalError m =>
EvalError -> Maybe a -> m a
liftMaybe (String -> EvalError
UnknownVariable String
name)
{-# INLINE maybeLookup #-}

-- | Lookup a global variable, might throw an 'UnknownVariable' error.
lookupGlobal :: (Simulator m v) => QBE.BaseType -> QBE.GlobalIdent -> m v
lookupGlobal :: forall (m :: * -> *) v.
Simulator m v =>
BaseType -> GlobalIdent -> m v
lookupGlobal BaseType
ty GlobalIdent
name = do
  Word64
v <- GlobalIdent -> m (Maybe Word64)
forall (m :: * -> *) v.
Simulator m v =>
GlobalIdent -> m (Maybe Word64)
lookupSymbol GlobalIdent
name m (Maybe Word64) -> (Maybe Word64 -> m Word64) -> m Word64
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Maybe Word64 -> m Word64
forall (m :: * -> *) v a. Simulator m v => String -> Maybe a -> m a
maybeLookup (GlobalIdent -> String
forall a. Show a => a -> String
show GlobalIdent
name)
  BaseType -> v -> m v
forall (m :: * -> *) v. Simulator m v => BaseType -> v -> m v
subType BaseType
ty (ExtType -> Word64 -> v
forall v. ValueRepr v => ExtType -> Word64 -> v
E.fromLit (BaseType -> ExtType
QBE.Base BaseType
QBE.Long) Word64
v)
{-# INLINEABLE lookupGlobal #-}

-- | Lookup a 'QBE.Value', invoking the correct lookup function. For example,
-- 'lookupGlobal' for globals or 'lookupLocal' for local variables.
lookupValue :: (Simulator m v) => QBE.BaseType -> QBE.Value -> m v
lookupValue :: forall (m :: * -> *) v. Simulator m v => BaseType -> Value -> m v
lookupValue BaseType
ty (QBE.VConst (QBE.Const (QBE.Number Word64
v))) =
  v -> m v
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (v -> m v) -> v -> m v
forall a b. (a -> b) -> a -> b
$ ExtType -> Word64 -> v
forall v. ValueRepr v => ExtType -> Word64 -> v
E.fromLit (BaseType -> ExtType
QBE.Base BaseType
ty) Word64
v
lookupValue BaseType
ty (QBE.VConst (QBE.Const (QBE.SFP Float
v))) =
  BaseType -> v -> m v
forall (m :: * -> *) v. Simulator m v => BaseType -> v -> m v
subType BaseType
ty (Float -> v
forall v. ValueRepr v => Float -> v
E.fromFloat Float
v)
lookupValue BaseType
ty (QBE.VConst (QBE.Const (QBE.DFP Double
v))) =
  BaseType -> v -> m v
forall (m :: * -> *) v. Simulator m v => BaseType -> v -> m v
subType BaseType
ty (Double -> v
forall v. ValueRepr v => Double -> v
E.fromDouble Double
v)
lookupValue BaseType
ty (QBE.VConst (QBE.Const (QBE.Global GlobalIdent
k))) = BaseType -> GlobalIdent -> m v
forall (m :: * -> *) v.
Simulator m v =>
BaseType -> GlobalIdent -> m v
lookupGlobal BaseType
ty GlobalIdent
k
lookupValue BaseType
ty (QBE.VConst (QBE.Thread GlobalIdent
k)) = BaseType -> GlobalIdent -> m v
forall (m :: * -> *) v.
Simulator m v =>
BaseType -> GlobalIdent -> m v
lookupGlobal BaseType
ty GlobalIdent
k
lookupValue BaseType
ty (QBE.VConst (QBE.Extern GlobalIdent
k)) = BaseType -> GlobalIdent -> m v
forall (m :: * -> *) v.
Simulator m v =>
BaseType -> GlobalIdent -> m v
lookupGlobal BaseType
ty GlobalIdent
k
lookupValue BaseType
ty (QBE.VConst (QBE.ExternThread GlobalIdent
k)) = BaseType -> GlobalIdent -> m v
forall (m :: * -> *) v.
Simulator m v =>
BaseType -> GlobalIdent -> m v
lookupGlobal BaseType
ty GlobalIdent
k
lookupValue BaseType
ty (QBE.VLocal LocalIdent
k) = do
  v
v <- m (StackFrame v)
forall (m :: * -> *) v. Simulator m v => m (StackFrame v)
activeFrame m (StackFrame v) -> (StackFrame v -> 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
>>= String -> Maybe v -> m v
forall (m :: * -> *) v a. Simulator m v => String -> Maybe a -> m a
maybeLookup (LocalIdent -> String
forall a. Show a => a -> String
show LocalIdent
k) (Maybe v -> m v)
-> (StackFrame v -> Maybe v) -> StackFrame v -> m v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StackFrame v -> LocalIdent -> Maybe v)
-> LocalIdent -> StackFrame v -> Maybe v
forall a b c. (a -> b -> c) -> b -> a -> c
flip StackFrame v -> LocalIdent -> Maybe v
forall v. StackFrame v -> LocalIdent -> Maybe v
lookupLocal LocalIdent
k
  BaseType -> v -> m v
forall (m :: * -> *) v. Simulator m v => BaseType -> v -> m v
subType BaseType
ty v
v
{-# INLINEABLE lookupValue #-}

lookupFuncName :: (Simulator m v) => QBE.GlobalIdent -> m (SomeFunc m v)
lookupFuncName :: forall (m :: * -> *) v.
Simulator m v =>
GlobalIdent -> m (SomeFunc m v)
lookupFuncName GlobalIdent
name = do
  Maybe (SomeFunc m v)
maybeFunc <- GlobalIdent -> m (Maybe (SomeFunc m v))
forall (m :: * -> *) v.
Simulator m v =>
GlobalIdent -> m (Maybe (SomeFunc m v))
findFunc GlobalIdent
name
  case Maybe (SomeFunc m v)
maybeFunc of
    Just SomeFunc m v
def -> SomeFunc m v -> m (SomeFunc m v)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SomeFunc m v
def
    Maybe (SomeFunc m v)
Nothing -> EvalError -> m (SomeFunc m v)
forall a. EvalError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GlobalIdent -> EvalError
UnknownFunction GlobalIdent
name)
{-# INLINEABLE lookupFuncName #-}

-- | Interpret the given 'QBE.Value' as a function reference, either
-- looking it up by name or by address. If the function could not be
-- found by address an 'UnknownFunctionAddr' is thrown, otherwise an
-- 'UnknownFunction' error is thrown.
lookupFunc :: (Simulator m v) => QBE.Value -> m (SomeFunc m v)
lookupFunc :: forall (m :: * -> *) v. Simulator m v => Value -> m (SomeFunc m v)
lookupFunc (QBE.VConst (QBE.Extern GlobalIdent
n)) = GlobalIdent -> m (SomeFunc m v)
forall (m :: * -> *) v.
Simulator m v =>
GlobalIdent -> m (SomeFunc m v)
lookupFuncName GlobalIdent
n
lookupFunc (QBE.VConst (QBE.Const (QBE.Global GlobalIdent
n))) = GlobalIdent -> m (SomeFunc m v)
forall (m :: * -> *) v.
Simulator m v =>
GlobalIdent -> m (SomeFunc m v)
lookupFuncName GlobalIdent
n
lookupFunc Value
value = do
  Word64
addr <- BaseType -> Value -> m v
forall (m :: * -> *) v. Simulator m v => BaseType -> Value -> m v
lookupValue BaseType
QBE.Long Value
value m v -> (v -> m Word64) -> m Word64
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 Word64
forall (m :: * -> *) v. Simulator m v => v -> m Word64
toAddress
  Maybe (SomeFunc m v)
maybeFunc <- Word64 -> m (Maybe (SomeFunc m v))
forall (m :: * -> *) v.
Simulator m v =>
Word64 -> m (Maybe (SomeFunc m v))
findFuncByAddr Word64
addr
  case Maybe (SomeFunc m v)
maybeFunc of
    Just SomeFunc m v
def -> SomeFunc m v -> m (SomeFunc m v)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SomeFunc m v
def
    Maybe (SomeFunc m v)
Nothing -> EvalError -> m (SomeFunc m v)
forall a. EvalError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Word64 -> EvalError
UnknownFunctionAddr Word64
addr)
{-# INLINEABLE lookupFunc #-}

lookupArg :: (Simulator m v) => QBE.FuncArg -> m (Maybe v)
lookupArg :: forall (m :: * -> *) v. Simulator m v => FuncArg -> m (Maybe v)
lookupArg (QBE.ArgReg Abity
abity Value
value) =
  v -> Maybe v
forall a. a -> Maybe a
Just (v -> Maybe v) -> m v -> m (Maybe v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BaseType -> Value -> m v
forall (m :: * -> *) v. Simulator m v => BaseType -> Value -> m v
lookupValue (Abity -> BaseType
QBE.abityToBase Abity
abity) Value
value
lookupArg (QBE.ArgEnv Value
_) = String -> m (Maybe v)
forall a. HasCallStack => String -> a
error String
"env function parameters not supported"
lookupArg FuncArg
QBE.ArgVar = Maybe v -> m (Maybe v)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe v
forall a. Maybe a
Nothing
{-# INLINEABLE lookupArg #-}

-- | Lookup the arguments to a function.
lookupArgs :: (Simulator m v) => [QBE.FuncArg] -> m [v]
lookupArgs :: forall (m :: * -> *) v. Simulator m v => [FuncArg] -> m [v]
lookupArgs [FuncArg]
args = [Maybe v] -> [v]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe v] -> [v]) -> m [Maybe v] -> m [v]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FuncArg -> m (Maybe v)) -> [FuncArg] -> m [Maybe v]
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 FuncArg -> m (Maybe v)
forall (m :: * -> *) v. Simulator m v => FuncArg -> m (Maybe v)
lookupArg [FuncArg]
args
{-# INLINE lookupArgs #-}

-- | Read a null-terminated C string from memory at the given 'MEM.Address'.
-- The return value is a list of 8-bit values.
readNullArray :: (Simulator m v) => MEM.Address -> m [v]
readNullArray :: forall (m :: * -> *) v. Simulator m v => Word64 -> m [v]
readNullArray Word64
addr = Word64 -> [v] -> m [v]
forall {m :: * -> *} {a}. Simulator m a => Word64 -> [a] -> m [a]
go Word64
addr []
  where
    go :: Word64 -> [a] -> m [a]
go Word64
a [a]
acc = do
      a
byte <- LoadType -> Word64 -> m a
forall (m :: * -> *) v. Simulator m v => LoadType -> Word64 -> m v
readMemory (SubWordType -> LoadType
QBE.LSubWord SubWordType
QBE.SignedByte) Word64
a
      if a -> Word64
forall v. ValueRepr v => v -> Word64
E.toWord64 a
byte Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
0
        then [a] -> m [a]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [a]
acc
        else Word64 -> [a] -> m [a]
go (Word64
a Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1) ([a]
acc [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a
byte])
{-# INLINE readNullArray #-}