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

module Language.QBE.Simulator.Default.State
  ( -- * Interpreter State
    Env (..),
    DataMem, -- XXX: required by initData.
    mkEnv,
    initData,
    loadObj, -- TODO: Don't export this.
    storeValues,

    -- * State Monad
    SimState (..),
    unliftCatch, -- TODO: Move this elsewhere.
    run,
  )
where

import Control.DeepSeq (NFData, force)
import Control.Exception
  ( ErrorCall (ErrorCall),
    Exception,
    assert,
    catch,
    evaluate,
    throwIO,
    try,
  )
import Control.Monad (foldM)
import Control.Monad.Error.Class (MonadError, catchError, throwError)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.State.Strict
  ( MonadState,
    StateT (StateT),
    evalStateT,
    execStateT,
    gets,
    modify,
    runStateT,
  )
import Data.Array.IO (IOArray)
import Data.Map qualified as Map
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Tuple (swap)
import Data.Word (Word8)
import Language.QBE (Definition (DefData), Program, globalFuncs)
import Language.QBE.Simulator.Default.Expression qualified as D
import Language.QBE.Simulator.Default.Funcs (lookupSimFunc)
import Language.QBE.Simulator.Error as Err
import Language.QBE.Simulator.Expression qualified as E
import Language.QBE.Simulator.Memory qualified as MEM
import Language.QBE.Simulator.State
import Language.QBE.Types qualified as QBE

data Env v b
  = Env
  { forall v b. Env v b -> Map GlobalIdent Address
envSyms :: Map.Map QBE.GlobalIdent MEM.Address,
    forall v b. Env v b -> Map GlobalIdent FuncDef
envFuncs :: Map.Map QBE.GlobalIdent QBE.FuncDef,
    forall v b. Env v b -> Map Address GlobalIdent
envFuncAddrs :: Map.Map MEM.Address QBE.GlobalIdent, -- TODO: IntMap?
    forall v b. Env v b -> Memory IOArray b
envMem :: MEM.Memory IOArray b,
    forall v b. Env v b -> [StackFrame v]
envStk :: [StackFrame v],
    forall v b. Env v b -> v
envStkPtr :: v,
    forall v b. Env v b -> Address
envDataPtr :: MEM.Address
  }

allocText :: MEM.Address -> [QBE.FuncDef] -> Map.Map MEM.Address QBE.GlobalIdent
allocText :: Address -> [FuncDef] -> Map Address GlobalIdent
allocText Address
_ [] = Map Address GlobalIdent
forall k a. Map k a
Map.empty
allocText Address
addr (FuncDef
func : [FuncDef]
rest) =
  Address
-> GlobalIdent
-> Map Address GlobalIdent
-> Map Address GlobalIdent
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Address
addr (FuncDef -> GlobalIdent
QBE.fName FuncDef
func) (Map Address GlobalIdent -> Map Address GlobalIdent)
-> Map Address GlobalIdent -> Map Address GlobalIdent
forall a b. (a -> b) -> a -> b
$
    Address -> [FuncDef] -> Map Address GlobalIdent
allocText (Address
addr Address -> Address -> Address
forall a. Num a => a -> a -> a
+ Address
pointerSize) [FuncDef]
rest
  where
    pointerSize :: MEM.Size
    pointerSize :: Address
pointerSize = 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
QBE.Long

mkEnv ::
  (MEM.Storable v b, E.ValueRepr v) =>
  Program ->
  MEM.Address ->
  MEM.Size ->
  IO (Env v b)
mkEnv :: forall v b.
(Storable v b, ValueRepr v) =>
Program -> Address -> Address -> IO (Env v b)
mkEnv Program
prog Address
a Address
s = do
  -- Memory Layout: Data memory starts at address zero and grows upward. The
  -- stack starts at the maximum address and grows downward towards address
  -- zero.
  --
  -- The """text segment""" is located after the stack memory. So technically,
  -- beyond the defined memory range. This is useful because it means that
  -- reading/writing that memory errors.
  --
  -- TODO: Check for stack overflow.
  Memory IOArray b
mem <- Address -> Address -> IO (Memory IOArray b)
forall (t :: * -> * -> *) a.
MArray t a IO =>
Address -> Address -> IO (Memory t a)
MEM.mkMemory Address
a Address
s
  let dataMem :: DataMem
dataMem = Address -> [DataDef] -> DataMem
allocData Address
a ((Definition -> Maybe DataDef) -> Program -> [DataDef]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Definition -> Maybe DataDef
isData Program
prog)
      fns :: [FuncDef]
fns = Program -> [FuncDef]
globalFuncs Program
prog
      txt :: Map Address GlobalIdent
txt = Address -> [FuncDef] -> Map Address GlobalIdent
allocText (Address -> Address
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Address -> Address) -> Address -> Address
forall a b. (a -> b) -> a -> b
$ Address
a Address -> Address -> Address
forall a. Num a => a -> a -> a
+ Address
s) [FuncDef]
fns
      env :: Env v b
env =
        Env
          { -- envSyms contains a mapping of function names to addresses
            -- (defined in envFuncAddrs) and addresses for all data defs.
            -- The latter is required here to enable forward references.
            envSyms :: Map GlobalIdent Address
envSyms = Map GlobalIdent Address
-> Map GlobalIdent Address -> Map GlobalIdent Address
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union (Map Address GlobalIdent -> Map GlobalIdent Address
getFuncPtr Map Address GlobalIdent
txt) (DataMem -> Map GlobalIdent Address
toSyms DataMem
dataMem),
            envFuncs :: Map GlobalIdent FuncDef
envFuncs = [FuncDef] -> Map GlobalIdent FuncDef
makeFuncs [FuncDef]
fns,
            envFuncAddrs :: Map Address GlobalIdent
envFuncAddrs = Map Address GlobalIdent
txt,
            envMem :: Memory IOArray b
envMem = Memory IOArray b
mem,
            envStk :: [StackFrame v]
envStk = [],
            envStkPtr :: v
envStkPtr = ExtType -> Address -> v
forall v. ValueRepr v => ExtType -> Address -> v
E.fromLit (BaseType -> ExtType
QBE.Base BaseType
QBE.Long) (Address -> v) -> Address -> v
forall a b. (a -> b) -> a -> b
$ Address
a Address -> Address -> Address
forall a. Num a => a -> a -> a
+ Address
s Address -> Address -> Address
forall a. Num a => a -> a -> a
- Address
1,
            envDataPtr :: Address
envDataPtr = Address
a
          }
  StateT (Env v b) IO () -> Env v b -> IO (Env v b)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT (DataMem -> StateT (Env v b) IO ()
forall v b.
(Storable v b, ValueRepr v) =>
DataMem -> StateT (Env v b) IO ()
initData DataMem
dataMem) Env v b
env
  where
    makeFuncs :: [QBE.FuncDef] -> Map.Map QBE.GlobalIdent QBE.FuncDef
    makeFuncs :: [FuncDef] -> Map GlobalIdent FuncDef
makeFuncs = [(GlobalIdent, FuncDef)] -> Map GlobalIdent FuncDef
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(GlobalIdent, FuncDef)] -> Map GlobalIdent FuncDef)
-> ([FuncDef] -> [(GlobalIdent, FuncDef)])
-> [FuncDef]
-> Map GlobalIdent FuncDef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FuncDef -> (GlobalIdent, FuncDef))
-> [FuncDef] -> [(GlobalIdent, FuncDef)]
forall a b. (a -> b) -> [a] -> [b]
map (\FuncDef
f -> (FuncDef -> GlobalIdent
QBE.fName FuncDef
f, FuncDef
f))

    getFuncPtr ::
      Map.Map MEM.Address QBE.GlobalIdent ->
      Map.Map QBE.GlobalIdent MEM.Address
    getFuncPtr :: Map Address GlobalIdent -> Map GlobalIdent Address
getFuncPtr = [(GlobalIdent, Address)] -> Map GlobalIdent Address
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(GlobalIdent, Address)] -> Map GlobalIdent Address)
-> (Map Address GlobalIdent -> [(GlobalIdent, Address)])
-> Map Address GlobalIdent
-> Map GlobalIdent Address
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Address, GlobalIdent) -> (GlobalIdent, Address))
-> [(Address, GlobalIdent)] -> [(GlobalIdent, Address)]
forall a b. (a -> b) -> [a] -> [b]
map (Address, GlobalIdent) -> (GlobalIdent, Address)
forall a b. (a, b) -> (b, a)
swap ([(Address, GlobalIdent)] -> [(GlobalIdent, Address)])
-> (Map Address GlobalIdent -> [(Address, GlobalIdent)])
-> Map Address GlobalIdent
-> [(GlobalIdent, Address)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Address GlobalIdent -> [(Address, GlobalIdent)]
forall k a. Map k a -> [(k, a)]
Map.toList

    toSyms :: DataMem -> Map.Map QBE.GlobalIdent MEM.Address
    toSyms :: DataMem -> Map GlobalIdent Address
toSyms = [(GlobalIdent, Address)] -> Map GlobalIdent Address
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(GlobalIdent, Address)] -> Map GlobalIdent Address)
-> (DataMem -> [(GlobalIdent, Address)])
-> DataMem
-> Map GlobalIdent Address
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Address, DataDef) -> (GlobalIdent, Address))
-> DataMem -> [(GlobalIdent, Address)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Address
k, DataDef
v) -> (DataDef -> GlobalIdent
QBE.name DataDef
v, Address
k))

    isData :: Definition -> Maybe QBE.DataDef
    isData :: Definition -> Maybe DataDef
isData (DefData DataDef
def) = DataDef -> Maybe DataDef
forall a. a -> Maybe a
Just DataDef
def
    isData Definition
_ = Maybe DataDef
forall a. Maybe a
Nothing

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

-- TODO: Move this to Loader.hs

storeBytes ::
  (MEM.Storable v b) =>
  MEM.Address ->
  [b] ->
  StateT (Env v b) IO MEM.Address
storeBytes :: forall v b.
Storable v b =>
Address -> [b] -> StateT (Env v b) IO Address
storeBytes Address
addr [b]
bytes = do
  Memory IOArray b
mem <- (Env v b -> Memory IOArray b)
-> StateT (Env v b) IO (Memory IOArray b)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Env v b -> Memory IOArray b
forall v b. Env v b -> Memory IOArray b
envMem
  IO () -> StateT (Env v b) IO ()
forall a. IO a -> StateT (Env v b) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT (Env v b) IO ())
-> IO () -> StateT (Env v b) IO ()
forall a b. (a -> b) -> a -> b
$ Memory IOArray b -> Address -> [b] -> IO ()
forall (t :: * -> * -> *) a.
MArray t a IO =>
Memory t a -> Address -> [a] -> IO ()
MEM.storeBytes Memory IOArray b
mem Address
addr [b]
bytes
  Address -> StateT (Env v b) IO Address
forall a. a -> StateT (Env v b) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Address -> StateT (Env v b) IO Address)
-> Address -> StateT (Env v b) IO Address
forall a b. (a -> b) -> a -> b
$ Address
addr Address -> Address -> Address
forall a. Num a => a -> a -> a
+ Int -> Address
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([b] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [b]
bytes)
{-# INLINEABLE storeBytes #-}

storeValue ::
  (MEM.Storable v b) =>
  MEM.Address ->
  v ->
  StateT (Env v b) IO MEM.Address
storeValue :: forall v b.
Storable v b =>
Address -> v -> StateT (Env v b) IO Address
storeValue Address
addr = Address -> [b] -> StateT (Env v b) IO Address
forall v b.
Storable v b =>
Address -> [b] -> StateT (Env v b) IO Address
storeBytes Address
addr ([b] -> StateT (Env v b) IO Address)
-> (v -> [b]) -> v -> StateT (Env v b) IO Address
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> [b]
forall valTy byteTy. Storable valTy byteTy => valTy -> [byteTy]
MEM.toBytes
{-# INLINE storeValue #-}

storeValues ::
  (MEM.Storable v b) =>
  MEM.Address ->
  [v] ->
  StateT (Env v b) IO MEM.Address
storeValues :: forall v b.
Storable v b =>
Address -> [v] -> StateT (Env v b) IO Address
storeValues Address
addr = Address -> [b] -> StateT (Env v b) IO Address
forall v b.
Storable v b =>
Address -> [b] -> StateT (Env v b) IO Address
storeBytes Address
addr ([b] -> StateT (Env v b) IO Address)
-> ([v] -> [b]) -> [v] -> StateT (Env v b) IO Address
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (v -> [b]) -> [v] -> [b]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap v -> [b]
forall valTy byteTy. Storable valTy byteTy => valTy -> [byteTy]
MEM.toBytes
{-# INLINE storeValues #-}

loadItem ::
  forall v b.
  (MEM.Storable v b, E.ValueRepr v) =>
  MEM.Address ->
  QBE.ExtType ->
  QBE.DataItem ->
  StateT (Env v b) IO MEM.Address
loadItem :: forall v b.
(Storable v b, ValueRepr v) =>
Address -> ExtType -> DataItem -> StateT (Env v b) IO Address
loadItem Address
addr ExtType
QBE.Byte (QBE.DString String
str) = do
  Address -> [v] -> StateT (Env v b) IO Address
forall v b.
Storable v b =>
Address -> [v] -> StateT (Env v b) IO Address
storeValues Address
addr ([v] -> StateT (Env v b) IO Address)
-> [v] -> StateT (Env v b) IO Address
forall a b. (a -> b) -> a -> b
$ String -> [v]
forall v. ValueRepr v => String -> [v]
E.fromString String
str
loadItem Address
addr ExtType
ty (QBE.DSymOff GlobalIdent
ident Address
off) = do
  Map GlobalIdent Address
globals <- (Env v b -> Map GlobalIdent Address)
-> StateT (Env v b) IO (Map GlobalIdent Address)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Env v b -> Map GlobalIdent Address
forall v b. Env v b -> Map GlobalIdent Address
envSyms
  case GlobalIdent -> Map GlobalIdent Address -> Maybe Address
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup GlobalIdent
ident Map GlobalIdent Address
globals of
    Maybe Address
Nothing -> IO Address -> StateT (Env v b) IO Address
forall a. IO a -> StateT (Env v b) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Address -> StateT (Env v b) IO Address)
-> IO Address -> StateT (Env v b) IO Address
forall a b. (a -> b) -> a -> b
$ EvalError -> IO Address
forall e a. Exception e => e -> IO a
throwIO (String -> EvalError
Err.UnknownVariable (String -> EvalError) -> String -> EvalError
forall a b. (a -> b) -> a -> b
$ GlobalIdent -> String
forall a. Show a => a -> String
show GlobalIdent
ident)
    Just Address
symAddr ->
      Address -> v -> StateT (Env v b) IO Address
forall v b.
Storable v b =>
Address -> v -> StateT (Env v b) IO Address
storeValue Address
addr (v -> StateT (Env v b) IO Address)
-> v -> StateT (Env v b) IO Address
forall a b. (a -> b) -> a -> b
$ forall v. ValueRepr v => ExtType -> Address -> v
E.fromLit @v ExtType
ty (Address
symAddr Address -> Address -> Address
forall a. Num a => a -> a -> a
+ Address
off)
loadItem Address
addr ExtType
ty (QBE.DConst (QBE.Global GlobalIdent
ident)) =
  Address -> ExtType -> DataItem -> StateT (Env v b) IO Address
forall v b.
(Storable v b, ValueRepr v) =>
Address -> ExtType -> DataItem -> StateT (Env v b) IO Address
loadItem Address
addr ExtType
ty (GlobalIdent -> Address -> DataItem
QBE.DSymOff GlobalIdent
ident Address
0)
loadItem Address
addr ExtType
ty (QBE.DConst (QBE.Number Address
num)) =
  Address -> v -> StateT (Env v b) IO Address
forall v b.
Storable v b =>
Address -> v -> StateT (Env v b) IO Address
storeValue Address
addr (v -> StateT (Env v b) IO Address)
-> v -> StateT (Env v b) IO Address
forall a b. (a -> b) -> a -> b
$ forall v. ValueRepr v => ExtType -> Address -> v
E.fromLit @v ExtType
ty Address
num
loadItem Address
addr (QBE.Base BaseType
QBE.Single) (QBE.DConst (QBE.SFP Float
num)) = do
  Address -> v -> StateT (Env v b) IO Address
forall v b.
Storable v b =>
Address -> v -> StateT (Env v b) IO Address
storeValue Address
addr (v -> StateT (Env v b) IO Address)
-> v -> StateT (Env v b) IO Address
forall a b. (a -> b) -> a -> b
$ forall v. ValueRepr v => Float -> v
E.fromFloat @v Float
num
loadItem Address
addr (QBE.Base BaseType
QBE.Double) (QBE.DConst (QBE.DFP Double
num)) = do
  Address -> v -> StateT (Env v b) IO Address
forall v b.
Storable v b =>
Address -> v -> StateT (Env v b) IO Address
storeValue Address
addr (v -> StateT (Env v b) IO Address)
-> v -> StateT (Env v b) IO Address
forall a b. (a -> b) -> a -> b
$ forall v. ValueRepr v => Double -> v
E.fromDouble @v Double
num
loadItem Address
_ ExtType
_ DataItem
item = String -> StateT (Env v b) IO Address
forall a. HasCallStack => String -> a
error (String -> StateT (Env v b) IO Address)
-> String -> StateT (Env v b) IO Address
forall a b. (a -> b) -> a -> b
$ String
"unsupported DataItem: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DataItem -> String
forall a. Show a => a -> String
show DataItem
item
{-# INLINEABLE loadItem #-}

-- Load an object **without** inserting padding for data objects.
-- In QBE, the members of a struct will be packed. The frontend
-- is responsible for inserting padding between them when necessary.
loadObj ::
  forall v b.
  (MEM.Storable v b, E.ValueRepr v) =>
  MEM.Address ->
  QBE.DataObj ->
  StateT (Env v b) IO MEM.Address
loadObj :: forall v b.
(Storable v b, ValueRepr v) =>
Address -> DataObj -> StateT (Env v b) IO Address
loadObj Address
addr (QBE.OZeroFill Address
n) = do
  let zeroByte :: v
zeroByte = forall v. ValueRepr v => ExtType -> Address -> v
E.fromLit @v ExtType
QBE.Byte Address
0
  Address -> [v] -> StateT (Env v b) IO Address
forall v b.
Storable v b =>
Address -> [v] -> StateT (Env v b) IO Address
storeValues Address
addr ([v] -> StateT (Env v b) IO Address)
-> [v] -> StateT (Env v b) IO Address
forall a b. (a -> b) -> a -> b
$ Int -> v -> [v]
forall a. Int -> a -> [a]
replicate (Address -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Address
n) v
zeroByte
loadObj Address
addr (QBE.OItem ExtType
ty [DataItem]
items) = do
  (Address -> DataItem -> StateT (Env v b) IO Address)
-> Address -> [DataItem] -> StateT (Env v b) IO Address
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Address -> ExtType -> DataItem -> StateT (Env v b) IO Address
forall v b.
(Storable v b, ValueRepr v) =>
Address -> ExtType -> DataItem -> StateT (Env v b) IO Address
`loadItem` ExtType
ty) Address
addr [DataItem]
items
{-# INLINEABLE loadObj #-}

loadData ::
  (MEM.Storable v b, E.ValueRepr v) =>
  MEM.Address ->
  QBE.DataDef ->
  StateT (Env v b) IO ()
loadData :: forall v b.
(Storable v b, ValueRepr v) =>
Address -> DataDef -> StateT (Env v b) IO ()
loadData Address
addr DataDef
dataDef = do
  Address
newAddr <- (Address -> DataObj -> StateT (Env v b) IO Address)
-> Address -> [DataObj] -> StateT (Env v b) IO Address
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Address -> DataObj -> StateT (Env v b) IO Address
forall v b.
(Storable v b, ValueRepr v) =>
Address -> DataObj -> StateT (Env v b) IO Address
loadObj Address
addr ([DataObj] -> StateT (Env v b) IO Address)
-> [DataObj] -> StateT (Env v b) IO Address
forall a b. (a -> b) -> a -> b
$ DataDef -> [DataObj]
QBE.objs DataDef
dataDef

  -- The address calculations performed by 'loadObj' must be aligned
  -- with those performed by 'allocData' through 'QBE.dataSize'.
  Bool -> StateT (Env v b) IO () -> StateT (Env v b) IO ()
forall a. HasCallStack => Bool -> a -> a
assert (Address
newAddr Address -> Address -> Bool
forall a. Eq a => a -> a -> Bool
== Address
addr Address -> Address -> Address
forall a. Num a => a -> a -> a
+ Int -> Address
forall a b. (Integral a, Num b) => a -> b
fromIntegral (DataDef -> Int
QBE.dataSize DataDef
dataDef)) (StateT (Env v b) IO () -> StateT (Env v b) IO ())
-> StateT (Env v b) IO () -> StateT (Env v b) IO ()
forall a b. (a -> b) -> a -> b
$
    () -> StateT (Env v b) IO ()
forall a. a -> StateT (Env v b) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
{-# INLINEABLE loadData #-}

initData ::
  (MEM.Storable v b, E.ValueRepr v) =>
  DataMem ->
  StateT (Env v b) IO ()
initData :: forall v b.
(Storable v b, ValueRepr v) =>
DataMem -> StateT (Env v b) IO ()
initData = ((Address, DataDef) -> StateT (Env v b) IO ())
-> DataMem -> StateT (Env v b) IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Address -> DataDef -> StateT (Env v b) IO ())
-> (Address, DataDef) -> StateT (Env v b) IO ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Address -> DataDef -> StateT (Env v b) IO ()
forall v b.
(Storable v b, ValueRepr v) =>
Address -> DataDef -> StateT (Env v b) IO ()
loadData)
{-# SPECIALIZE initData :: DataMem -> StateT (Env D.RegVal Word8) IO () #-}

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

-- This code implements the allocation of memory for 'DataDef's. In this
-- case, allocation means assigning a unique non-overlapping 'MEM.Address'.
-- This is separated from the initialization of the memory, which is
-- performed by 'initData'. Decoupling this enables forwards references.
--
-- For example:
--
--  data $a = { l $b }
--  data $b = { b 0 }

-- Specifies the memory layout of the data memory. That is, for each
-- 'DataDef' defined in QBE, it specifies a start address in memory.
type DataMem = [(MEM.Address, QBE.DataDef)]

allocDataDef ::
  QBE.DataDef ->
  (MEM.Address, DataMem) ->
  (MEM.Address, DataMem)
allocDataDef :: DataDef -> (Address, DataMem) -> (Address, DataMem)
allocDataDef DataDef
dataDef (Address
startAddr, DataMem
memMap) =
  let addr :: Address
addr =
        Address -> Address -> Address
MEM.alignAddr Address
startAddr (Address -> Address) -> Address -> Address
forall a b. (a -> b) -> a -> b
$
          Address -> Maybe Address -> Address
forall a. a -> Maybe a -> a
fromMaybe Address
maxAlign (DataDef -> Maybe Address
QBE.align DataDef
dataDef)
      size :: Address
size = Int -> Address
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Address) -> Int -> Address
forall a b. (a -> b) -> a -> b
$ DataDef -> Int
QBE.dataSize DataDef
dataDef
   in (Address
addr Address -> Address -> Address
forall a. Num a => a -> a -> a
+ Address
size, (Address
addr, DataDef
dataDef) (Address, DataDef) -> DataMem -> DataMem
forall a. a -> [a] -> [a]
: DataMem
memMap)
  where
    -- The alignment of an aggregate type is the maximum alignment the members.
    maxAlign :: Address
maxAlign = [Address] -> Address
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Address] -> Address) -> [Address] -> Address
forall a b. (a -> b) -> a -> b
$ (DataObj -> Address) -> [DataObj] -> [Address]
forall a b. (a -> b) -> [a] -> [b]
map DataObj -> Address
QBE.objAlign (DataDef -> [DataObj]
QBE.objs DataDef
dataDef)

allocData :: MEM.Address -> [QBE.DataDef] -> DataMem
allocData :: Address -> [DataDef] -> DataMem
allocData Address
startAddr [DataDef]
dataDefs =
  (Address, DataMem) -> DataMem
forall a b. (a, b) -> b
snd ((Address, DataMem) -> DataMem) -> (Address, DataMem) -> DataMem
forall a b. (a -> b) -> a -> b
$ (DataDef -> (Address, DataMem) -> (Address, DataMem))
-> (Address, DataMem) -> [DataDef] -> (Address, DataMem)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr DataDef -> (Address, DataMem) -> (Address, DataMem)
allocDataDef (Address
startAddr, []) [DataDef]
dataDefs

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

-- | Unlift 'Control.Exception.IOException' handling into a generic t'StateT' monad.
--
-- See also: <https://hackage.haskell.org/package/unliftio>.
unliftCatch ::
  (Exception t) =>
  StateT s IO a -> (t -> StateT s IO a) -> StateT s IO a
unliftCatch :: forall t s a.
Exception t =>
StateT s IO a -> (t -> StateT s IO a) -> StateT s IO a
unliftCatch StateT s IO a
st t -> StateT s IO a
handler = do
  (s -> IO (a, s)) -> StateT s IO a
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT ((s -> IO (a, s)) -> StateT s IO a)
-> (s -> IO (a, s)) -> StateT s IO a
forall a b. (a -> b) -> a -> b
$ \s
s -> do
    let state :: IO (a, s)
state = StateT s IO a -> s -> IO (a, s)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT s IO a
st s
s
    IO (a, s)
state IO (a, s) -> (t -> IO (a, s)) -> IO (a, s)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\t
e -> StateT s IO a -> s -> IO (a, s)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (t -> StateT s IO a
handler t
e) s
s)
{-# INLINEABLE unliftCatch #-}

-- | Simulator state, parameterized over a value and byte representation.
newtype SimState v b a = SimState {forall v b a. SimState v b a -> StateT (Env v b) IO a
unSimState :: StateT (Env v b) IO a}
  deriving ((forall a b. (a -> b) -> SimState v b a -> SimState v b b)
-> (forall a b. a -> SimState v b b -> SimState v b a)
-> Functor (SimState v b)
forall a b. a -> SimState v b b -> SimState v b a
forall a b. (a -> b) -> SimState v b a -> SimState v b b
forall v b a b. a -> SimState v b b -> SimState v b a
forall v b a b. (a -> b) -> SimState v b a -> SimState v b b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall v b a b. (a -> b) -> SimState v b a -> SimState v b b
fmap :: forall a b. (a -> b) -> SimState v b a -> SimState v b b
$c<$ :: forall v b a b. a -> SimState v b b -> SimState v b a
<$ :: forall a b. a -> SimState v b b -> SimState v b a
Functor, Functor (SimState v b)
Functor (SimState v b) =>
(forall a. a -> SimState v b a)
-> (forall a b.
    SimState v b (a -> b) -> SimState v b a -> SimState v b b)
-> (forall a b c.
    (a -> b -> c)
    -> SimState v b a -> SimState v b b -> SimState v b c)
-> (forall a b. SimState v b a -> SimState v b b -> SimState v b b)
-> (forall a b. SimState v b a -> SimState v b b -> SimState v b a)
-> Applicative (SimState v b)
forall a. a -> SimState v b a
forall v b. Functor (SimState v b)
forall a b. SimState v b a -> SimState v b b -> SimState v b a
forall a b. SimState v b a -> SimState v b b -> SimState v b b
forall a b.
SimState v b (a -> b) -> SimState v b a -> SimState v b b
forall v b a. a -> SimState v b a
forall a b c.
(a -> b -> c) -> SimState v b a -> SimState v b b -> SimState v b c
forall v b a b. SimState v b a -> SimState v b b -> SimState v b a
forall v b a b. SimState v b a -> SimState v b b -> SimState v b b
forall v b a b.
SimState v b (a -> b) -> SimState v b a -> SimState v b b
forall v b a b c.
(a -> b -> c) -> SimState v b a -> SimState v b b -> SimState v b c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall v b a. a -> SimState v b a
pure :: forall a. a -> SimState v b a
$c<*> :: forall v b a b.
SimState v b (a -> b) -> SimState v b a -> SimState v b b
<*> :: forall a b.
SimState v b (a -> b) -> SimState v b a -> SimState v b b
$cliftA2 :: forall v b a b c.
(a -> b -> c) -> SimState v b a -> SimState v b b -> SimState v b c
liftA2 :: forall a b c.
(a -> b -> c) -> SimState v b a -> SimState v b b -> SimState v b c
$c*> :: forall v b a b. SimState v b a -> SimState v b b -> SimState v b b
*> :: forall a b. SimState v b a -> SimState v b b -> SimState v b b
$c<* :: forall v b a b. SimState v b a -> SimState v b b -> SimState v b a
<* :: forall a b. SimState v b a -> SimState v b b -> SimState v b a
Applicative, Applicative (SimState v b)
Applicative (SimState v b) =>
(forall a b.
 SimState v b a -> (a -> SimState v b b) -> SimState v b b)
-> (forall a b. SimState v b a -> SimState v b b -> SimState v b b)
-> (forall a. a -> SimState v b a)
-> Monad (SimState v b)
forall a. a -> SimState v b a
forall v b. Applicative (SimState v b)
forall a b. SimState v b a -> SimState v b b -> SimState v b b
forall a b.
SimState v b a -> (a -> SimState v b b) -> SimState v b b
forall v b a. a -> SimState v b a
forall v b a b. SimState v b a -> SimState v b b -> SimState v b b
forall v b a b.
SimState v b a -> (a -> SimState v b b) -> SimState v b b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall v b a b.
SimState v b a -> (a -> SimState v b b) -> SimState v b b
>>= :: forall a b.
SimState v b a -> (a -> SimState v b b) -> SimState v b b
$c>> :: forall v b a b. SimState v b a -> SimState v b b -> SimState v b b
>> :: forall a b. SimState v b a -> SimState v b b -> SimState v b b
$creturn :: forall v b a. a -> SimState v b a
return :: forall a. a -> SimState v b a
Monad, Monad (SimState v b)
Monad (SimState v b) =>
(forall a. IO a -> SimState v b a) -> MonadIO (SimState v b)
forall a. IO a -> SimState v b a
forall v b. Monad (SimState v b)
forall v b a. IO a -> SimState v b a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall v b a. IO a -> SimState v b a
liftIO :: forall a. IO a -> SimState v b a
MonadIO)

deriving instance MonadState (Env v b) (SimState v b)

-- | Implements 'MonadError' in t'SimState' via 'Control.Exception.IOException's.
-- This should be more performant than using t'Control.Monad.Except.ExceptT'
-- monad transformer in conjunction with t'StateT'.
instance MonadError Err.EvalError (SimState v b) where
  throwError :: forall a. EvalError -> SimState v b a
throwError = IO a -> SimState v b a
forall a. IO a -> SimState v b a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> SimState v b a)
-> (EvalError -> IO a) -> EvalError -> SimState v b a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EvalError -> IO a
forall e a. Exception e => e -> IO a
throwIO
  catchError :: forall a.
SimState v b a -> (EvalError -> SimState v b a) -> SimState v b a
catchError (SimState StateT (Env v b) IO a
st) EvalError -> SimState v b a
handler =
    StateT (Env v b) IO a -> SimState v b a
forall v b a. StateT (Env v b) IO a -> SimState v b a
SimState (StateT (Env v b) IO a -> SimState v b a)
-> StateT (Env v b) IO a -> SimState v b a
forall a b. (a -> b) -> a -> b
$ StateT (Env v b) IO a
-> (EvalError -> StateT (Env v b) IO a) -> StateT (Env v b) IO a
forall t s a.
Exception t =>
StateT s IO a -> (t -> StateT s IO a) -> StateT s IO a
unliftCatch StateT (Env v b) IO a
st (SimState v b a -> StateT (Env v b) IO a
forall v b a. SimState v b a -> StateT (Env v b) IO a
unSimState (SimState v b a -> StateT (Env v b) IO a)
-> (EvalError -> SimState v b a)
-> EvalError
-> StateT (Env v b) IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EvalError -> SimState v b a
handler)

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

-- | Like 'MEM.loadBytes' but receives a 'QBE.LoadType' as an argument, deducing
-- the size from it. Further, also catches any errors potentionally raised by
-- the memory and rethrows them as a 'EvalError'.
safeLoadBytes ::
  (NFData a) =>
  MEM.Memory IOArray a ->
  MEM.Address ->
  QBE.LoadType ->
  SimState v b [a]
safeLoadBytes :: forall a v b.
NFData a =>
Memory IOArray a -> Address -> LoadType -> SimState v b [a]
safeLoadBytes Memory IOArray a
mem Address
addr LoadType
ty = do
  let size :: Address
size = LoadType -> Address
QBE.loadByteSize LoadType
ty
  Either ErrorCall [a]
mayBytes <-
    IO (Either ErrorCall [a]) -> SimState v b (Either ErrorCall [a])
forall a. IO a -> SimState v b a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ErrorCall [a]) -> SimState v b (Either ErrorCall [a]))
-> IO (Either ErrorCall [a]) -> SimState v b (Either ErrorCall [a])
forall a b. (a -> b) -> a -> b
$
      IO [a] -> IO (Either ErrorCall [a])
forall e a. Exception e => IO a -> IO (Either e a)
try (Memory IOArray a -> Address -> Address -> IO [a]
forall (t :: * -> * -> *) a.
MArray t a IO =>
Memory t a -> Address -> Address -> IO [a]
MEM.loadBytes Memory IOArray a
mem Address
addr Address
size IO [a] -> ([a] -> IO [a]) -> IO [a]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [a] -> IO [a]
forall a. a -> IO a
evaluate ([a] -> IO [a]) -> ([a] -> [a]) -> [a] -> IO [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [a]
forall a. NFData a => a -> a
force)

  case Either ErrorCall [a]
mayBytes of
    Left (ErrorCall String
msg) -> EvalError -> SimState v b [a]
forall a. EvalError -> SimState v b a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (EvalError -> SimState v b [a]) -> EvalError -> SimState v b [a]
forall a b. (a -> b) -> a -> b
$ String -> EvalError
Err.MemoryError String
msg
    Right [a]
bytes -> [a] -> SimState v b [a]
forall a. a -> SimState v b a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [a]
bytes
{-# INLINE safeLoadBytes #-}

instance (MEM.Storable v b, E.ValueRepr v, NFData b) => Simulator (SimState v b) v where
  isTrue :: v -> SimState v b Bool
isTrue v
value = Bool -> SimState v b Bool
forall a. a -> SimState v b a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (v -> Address
forall v. ValueRepr v => v -> Address
E.toWord64 v
value Address -> Address -> Bool
forall a. Eq a => a -> a -> Bool
/= Address
0)
  toAddress :: v -> SimState v b Address
toAddress = Address -> SimState v b Address
forall a. a -> SimState v b a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Address -> SimState v b Address)
-> (v -> Address) -> v -> SimState v b Address
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> Address
forall v. ValueRepr v => v -> Address
E.toWord64

  lookupSymbol :: GlobalIdent -> SimState v b (Maybe Address)
lookupSymbol GlobalIdent
ident = (Env v b -> Maybe Address) -> SimState v b (Maybe Address)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (GlobalIdent -> Map GlobalIdent Address -> Maybe Address
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup GlobalIdent
ident (Map GlobalIdent Address -> Maybe Address)
-> (Env v b -> Map GlobalIdent Address) -> Env v b -> Maybe Address
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env v b -> Map GlobalIdent Address
forall v b. Env v b -> Map GlobalIdent Address
envSyms)

  findFunc :: GlobalIdent -> SimState v b (Maybe (SomeFunc (SimState v b) v))
findFunc GlobalIdent
ident = do
    Map GlobalIdent FuncDef
funcs <- (Env v b -> Map GlobalIdent FuncDef)
-> SimState v b (Map GlobalIdent FuncDef)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Env v b -> Map GlobalIdent FuncDef
forall v b. Env v b -> Map GlobalIdent FuncDef
envFuncs
    Maybe (SomeFunc (SimState v b) v)
-> SimState v b (Maybe (SomeFunc (SimState v b) v))
forall a. a -> SimState v b a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (SomeFunc (SimState v b) v)
 -> SimState v b (Maybe (SomeFunc (SimState v b) v)))
-> Maybe (SomeFunc (SimState v b) v)
-> SimState v b (Maybe (SomeFunc (SimState v b) v))
forall a b. (a -> b) -> a -> b
$ case GlobalIdent -> Map GlobalIdent FuncDef -> Maybe FuncDef
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup GlobalIdent
ident Map GlobalIdent FuncDef
funcs of
      Just FuncDef
x -> SomeFunc (SimState v b) v -> Maybe (SomeFunc (SimState v b) v)
forall a. a -> Maybe a
Just (SomeFunc (SimState v b) v -> Maybe (SomeFunc (SimState v b) v))
-> SomeFunc (SimState v b) v -> Maybe (SomeFunc (SimState v b) v)
forall a b. (a -> b) -> a -> b
$ FuncDef -> SomeFunc (SimState v b) v
forall (m :: * -> *) v. FuncDef -> SomeFunc m v
SFuncDef FuncDef
x
      Maybe FuncDef
Nothing -> ([v] -> SimState v b (Maybe v)) -> SomeFunc (SimState v b) v
forall (m :: * -> *) v. ([v] -> m (Maybe v)) -> SomeFunc m v
SSimFunc (([v] -> SimState v b (Maybe v)) -> SomeFunc (SimState v b) v)
-> Maybe ([v] -> SimState v b (Maybe v))
-> Maybe (SomeFunc (SimState v b) v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GlobalIdent -> Maybe ([v] -> SimState v b (Maybe v))
forall (m :: * -> *) v.
(MonadIO m, ValueRepr v, Simulator m v) =>
GlobalIdent -> Maybe ([v] -> m (Maybe v))
lookupSimFunc GlobalIdent
ident
  findFuncByAddr :: Address -> SimState v b (Maybe (SomeFunc (SimState v b) v))
findFuncByAddr Address
addr = do
    Map Address GlobalIdent
fptrs <- (Env v b -> Map Address GlobalIdent)
-> SimState v b (Map Address GlobalIdent)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Env v b -> Map Address GlobalIdent
forall v b. Env v b -> Map Address GlobalIdent
envFuncAddrs
    case Address -> Map Address GlobalIdent -> Maybe GlobalIdent
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Address
addr Map Address GlobalIdent
fptrs of
      Just GlobalIdent
fn -> GlobalIdent -> SimState v b (Maybe (SomeFunc (SimState v b) v))
forall (m :: * -> *) v.
Simulator m v =>
GlobalIdent -> m (Maybe (SomeFunc m v))
findFunc GlobalIdent
fn
      Maybe GlobalIdent
Nothing -> Maybe (SomeFunc (SimState v b) v)
-> SimState v b (Maybe (SomeFunc (SimState v b) v))
forall a. a -> SimState v b a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (SomeFunc (SimState v b) v)
forall a. Maybe a
Nothing

  activeFrame :: SimState v b (StackFrame v)
activeFrame = do
    [StackFrame v]
stk <- (Env v b -> [StackFrame v]) -> SimState v b [StackFrame v]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Env v b -> [StackFrame v]
forall v b. Env v b -> [StackFrame v]
envStk
    case [StackFrame v]
stk of
      (StackFrame v
x : [StackFrame v]
_) -> StackFrame v -> SimState v b (StackFrame v)
forall a. a -> SimState v b a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StackFrame v
x
      [] -> EvalError -> SimState v b (StackFrame v)
forall a. EvalError -> SimState v b a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError EvalError
Err.EmptyStack
  pushStackFrame :: StackFrame v -> SimState v b ()
pushStackFrame StackFrame v
frame =
    (Env v b -> Env v b) -> SimState v b ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\Env v b
s -> Env v b
s {envStk = frame : envStk s})
  popStackFrame :: SimState v b (StackFrame v)
popStackFrame = do
    [StackFrame v]
stk <- (Env v b -> [StackFrame v]) -> SimState v b [StackFrame v]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Env v b -> [StackFrame v]
forall v b. Env v b -> [StackFrame v]
envStk
    case [StackFrame v]
stk of
      (StackFrame v
x : [StackFrame v]
xs) -> (Env v b -> Env v b) -> SimState v b ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\Env v b
s -> Env v b
s {envStk = xs}) SimState v b ()
-> SimState v b (StackFrame v) -> SimState v b (StackFrame v)
forall a b. SimState v b a -> SimState v b b -> SimState v b b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> StackFrame v -> SimState v b (StackFrame v)
forall a. a -> SimState v b a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StackFrame v
x
      [] -> EvalError -> SimState v b (StackFrame v)
forall a. EvalError -> SimState v b a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError EvalError
Err.EmptyStack

  getSP :: SimState v b v
getSP = (Env v b -> v) -> SimState v b v
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Env v b -> v
forall v b. Env v b -> v
envStkPtr
  setSP :: v -> SimState v b ()
setSP v
sp = (Env v b -> Env v b) -> SimState v b ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\Env v b
s -> Env v b
s {envStkPtr = sp})

  writeMemory :: Address -> ExtType -> v -> SimState v b ()
writeMemory Address
addr ExtType
extType v
val = do
    Memory IOArray b
mem <- (Env v b -> Memory IOArray b) -> SimState v b (Memory IOArray b)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Env v b -> Memory IOArray b
forall v b. Env v b -> Memory IOArray b
envMem

    -- Since halfwords and bytes are not first class in the IL, storeh and storeb
    -- take a word as argument. Only the first 16 or 8 bits of this word will be
    -- stored in memory at the address specified in the second argument.
    let bytes :: [b]
bytes = v -> [b]
forall valTy byteTy. Storable valTy byteTy => valTy -> [byteTy]
MEM.toBytes v
val
    IO () -> SimState v b ()
forall a. IO a -> SimState v b a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> SimState v b ()) -> IO () -> SimState v b ()
forall a b. (a -> b) -> a -> b
$
      Memory IOArray b -> Address -> [b] -> IO ()
forall (t :: * -> * -> *) a.
MArray t a IO =>
Memory t a -> Address -> [a] -> IO ()
MEM.storeBytes Memory IOArray b
mem Address
addr ([b] -> IO ()) -> [b] -> IO ()
forall a b. (a -> b) -> a -> b
$
        case ExtType
extType of
          ExtType
QBE.Byte -> Int -> [b] -> [b]
forall a. Int -> [a] -> [a]
take Int
1 [b]
bytes
          ExtType
QBE.HalfWord -> Int -> [b] -> [b]
forall a. Int -> [a] -> [a]
take Int
2 [b]
bytes
          QBE.Base BaseType
_ -> [b]
bytes
  readMemory :: LoadType -> Address -> SimState v b v
readMemory LoadType
ty Address
addr = do
    Memory IOArray b
mem <- (Env v b -> Memory IOArray b) -> SimState v b (Memory IOArray b)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Env v b -> Memory IOArray b
forall v b. Env v b -> Memory IOArray b
envMem
    [b]
bytes <- Memory IOArray b -> Address -> LoadType -> SimState v b [b]
forall a v b.
NFData a =>
Memory IOArray a -> Address -> LoadType -> SimState v b [a]
safeLoadBytes Memory IOArray b
mem Address
addr LoadType
ty

    case LoadType -> [b] -> Maybe v
forall valTy byteTy.
Storable valTy byteTy =>
LoadType -> [byteTy] -> Maybe valTy
MEM.fromBytes LoadType
ty [b]
bytes of
      Just v
x -> v -> SimState v b v
forall a. a -> SimState v b a
forall (f :: * -> *) a. Applicative f => a -> f a
pure v
x
      Maybe v
Nothing -> EvalError -> SimState v b v
forall a. EvalError -> SimState v b a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError EvalError
InvalidMemoryLoad

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

run :: (E.ValueRepr v, MEM.Storable v b) => Env v b -> SimState v b a -> IO a
run :: forall v b a.
(ValueRepr v, Storable v b) =>
Env v b -> SimState v b a -> IO a
run Env v b
env SimState v b a
state = StateT (Env v b) IO a -> Env v b -> IO a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (SimState v b a -> StateT (Env v b) IO a
forall v b a. SimState v b a -> StateT (Env v b) IO a
unSimState SimState v b a
state) Env v b
env
{-# SPECIALIZE run :: Env D.RegVal Word8 -> SimState D.RegVal Word8 a -> IO a #-}