qute

  1-- SPDX-FileCopyrightText: 2025-2026 Sören Tempel <soeren+git@soeren-tempel.net>
  2--
  3-- SPDX-License-Identifier: GPL-3.0-only
  4{-# LANGUAGE TypeApplications #-}
  5
  6module Language.QBE.Simulator.Default.State
  7  ( -- * Interpreter State
  8    Env (..),
  9    DataMem, -- XXX: required by initData.
 10    mkEnv,
 11    initData,
 12    loadObj, -- TODO: Don't export this.
 13    storeValues,
 14
 15    -- * State Monad
 16    SimState (..),
 17    unliftCatch, -- TODO: Move this elsewhere.
 18    run,
 19  )
 20where
 21
 22import Control.DeepSeq (NFData, force)
 23import Control.Exception
 24  ( ErrorCall (ErrorCall),
 25    Exception,
 26    assert,
 27    catch,
 28    evaluate,
 29    throwIO,
 30    try,
 31  )
 32import Control.Monad (foldM)
 33import Control.Monad.Error.Class (MonadError, catchError, throwError)
 34import Control.Monad.IO.Class (MonadIO, liftIO)
 35import Control.Monad.State.Strict
 36  ( MonadState,
 37    StateT (StateT),
 38    evalStateT,
 39    execStateT,
 40    gets,
 41    modify,
 42    runStateT,
 43  )
 44import Data.Array.IO (IOArray)
 45import Data.Map qualified as Map
 46import Data.Maybe (fromMaybe, mapMaybe)
 47import Data.Tuple (swap)
 48import Data.Word (Word8)
 49import Language.QBE (Definition (DefData), Program, globalFuncs)
 50import Language.QBE.Simulator.Default.Expression qualified as D
 51import Language.QBE.Simulator.Default.Funcs (lookupSimFunc)
 52import Language.QBE.Simulator.Error as Err
 53import Language.QBE.Simulator.Expression qualified as E
 54import Language.QBE.Simulator.Memory qualified as MEM
 55import Language.QBE.Simulator.State
 56import Language.QBE.Types qualified as QBE
 57
 58data Env v b
 59  = Env
 60  { envSyms :: Map.Map QBE.GlobalIdent MEM.Address,
 61    envFuncs :: Map.Map QBE.GlobalIdent QBE.FuncDef,
 62    envFuncAddrs :: Map.Map MEM.Address QBE.GlobalIdent, -- TODO: IntMap?
 63    envMem :: MEM.Memory IOArray b,
 64    envStk :: [StackFrame v],
 65    envStkPtr :: v,
 66    envDataPtr :: MEM.Address
 67  }
 68
 69allocText :: MEM.Address -> [QBE.FuncDef] -> Map.Map MEM.Address QBE.GlobalIdent
 70allocText _ [] = Map.empty
 71allocText addr (func : rest) =
 72  Map.insert addr (QBE.fName func) $
 73    allocText (addr + pointerSize) rest
 74  where
 75    pointerSize :: MEM.Size
 76    pointerSize = fromIntegral $ QBE.baseTypeByteSize QBE.Long
 77
 78mkEnv ::
 79  (MEM.Storable v b, E.ValueRepr v) =>
 80  Program ->
 81  MEM.Address ->
 82  MEM.Size ->
 83  IO (Env v b)
 84mkEnv prog a s = do
 85  -- Memory Layout: Data memory starts at address zero and grows upward. The
 86  -- stack starts at the maximum address and grows downward towards address
 87  -- zero.
 88  --
 89  -- The """text segment""" is located after the stack memory. So technically,
 90  -- beyond the defined memory range. This is useful because it means that
 91  -- reading/writing that memory errors.
 92  --
 93  -- TODO: Check for stack overflow.
 94  mem <- MEM.mkMemory a s
 95  let dataMem = allocData a (mapMaybe isData prog)
 96      fns = globalFuncs prog
 97      txt = allocText (fromIntegral $ a + s) fns
 98      env =
 99        Env
100          { -- envSyms contains a mapping of function names to addresses
101            -- (defined in envFuncAddrs) and addresses for all data defs.
102            -- The latter is required here to enable forward references.
103            envSyms = Map.union (getFuncPtr txt) (toSyms dataMem),
104            envFuncs = makeFuncs fns,
105            envFuncAddrs = txt,
106            envMem = mem,
107            envStk = [],
108            envStkPtr = E.fromLit (QBE.Base QBE.Long) $ a + s - 1,
109            envDataPtr = a
110          }
111  execStateT (initData dataMem) env
112  where
113    makeFuncs :: [QBE.FuncDef] -> Map.Map QBE.GlobalIdent QBE.FuncDef
114    makeFuncs = Map.fromList . map (\f -> (QBE.fName f, f))
115
116    getFuncPtr ::
117      Map.Map MEM.Address QBE.GlobalIdent ->
118      Map.Map QBE.GlobalIdent MEM.Address
119    getFuncPtr = Map.fromList . map swap . Map.toList
120
121    toSyms :: DataMem -> Map.Map QBE.GlobalIdent MEM.Address
122    toSyms = Map.fromList . map (\(k, v) -> (QBE.name v, k))
123
124    isData :: Definition -> Maybe QBE.DataDef
125    isData (DefData def) = Just def
126    isData _ = Nothing
127
128------------------------------------------------------------------------
129
130-- TODO: Move this to Loader.hs
131
132storeBytes ::
133  (MEM.Storable v b) =>
134  MEM.Address ->
135  [b] ->
136  StateT (Env v b) IO MEM.Address
137storeBytes addr bytes = do
138  mem <- gets envMem
139  liftIO $ MEM.storeBytes mem addr bytes
140  pure $ addr + fromIntegral (length bytes)
141{-# INLINEABLE storeBytes #-}
142
143storeValue ::
144  (MEM.Storable v b) =>
145  MEM.Address ->
146  v ->
147  StateT (Env v b) IO MEM.Address
148storeValue addr = storeBytes addr . MEM.toBytes
149{-# INLINE storeValue #-}
150
151storeValues ::
152  (MEM.Storable v b) =>
153  MEM.Address ->
154  [v] ->
155  StateT (Env v b) IO MEM.Address
156storeValues addr = storeBytes addr . concatMap MEM.toBytes
157{-# INLINE storeValues #-}
158
159loadItem ::
160  forall v b.
161  (MEM.Storable v b, E.ValueRepr v) =>
162  MEM.Address ->
163  QBE.ExtType ->
164  QBE.DataItem ->
165  StateT (Env v b) IO MEM.Address
166loadItem addr QBE.Byte (QBE.DString str) = do
167  storeValues addr $ E.fromString str
168loadItem addr ty (QBE.DSymOff ident off) = do
169  globals <- gets envSyms
170  case Map.lookup ident globals of
171    Nothing -> liftIO $ throwIO (Err.UnknownVariable $ show ident)
172    Just symAddr ->
173      storeValue addr $ E.fromLit @v ty (symAddr + off)
174loadItem addr ty (QBE.DConst (QBE.Global ident)) =
175  loadItem addr ty (QBE.DSymOff ident 0)
176loadItem addr ty (QBE.DConst (QBE.Number num)) =
177  storeValue addr $ E.fromLit @v ty num
178loadItem addr (QBE.Base QBE.Single) (QBE.DConst (QBE.SFP num)) = do
179  storeValue addr $ E.fromFloat @v num
180loadItem addr (QBE.Base QBE.Double) (QBE.DConst (QBE.DFP num)) = do
181  storeValue addr $ E.fromDouble @v num
182loadItem _ _ item = error $ "unsupported DataItem: " ++ show item
183{-# INLINEABLE loadItem #-}
184
185-- Load an object **without** inserting padding for data objects.
186-- In QBE, the members of a struct will be packed. The frontend
187-- is responsible for inserting padding between them when necessary.
188loadObj ::
189  forall v b.
190  (MEM.Storable v b, E.ValueRepr v) =>
191  MEM.Address ->
192  QBE.DataObj ->
193  StateT (Env v b) IO MEM.Address
194loadObj addr (QBE.OZeroFill n) = do
195  let zeroByte = E.fromLit @v QBE.Byte 0
196  storeValues addr $ replicate (fromIntegral n) zeroByte
197loadObj addr (QBE.OItem ty items) = do
198  foldM (`loadItem` ty) addr items
199{-# INLINEABLE loadObj #-}
200
201loadData ::
202  (MEM.Storable v b, E.ValueRepr v) =>
203  MEM.Address ->
204  QBE.DataDef ->
205  StateT (Env v b) IO ()
206loadData addr dataDef = do
207  newAddr <- foldM loadObj addr $ QBE.objs dataDef
208
209  -- The address calculations performed by 'loadObj' must be aligned
210  -- with those performed by 'allocData' through 'QBE.dataSize'.
211  assert (newAddr == addr + fromIntegral (QBE.dataSize dataDef)) $
212    pure ()
213{-# INLINEABLE loadData #-}
214
215initData ::
216  (MEM.Storable v b, E.ValueRepr v) =>
217  DataMem ->
218  StateT (Env v b) IO ()
219initData = mapM_ (uncurry loadData)
220{-# SPECIALIZE initData :: DataMem -> StateT (Env D.RegVal Word8) IO () #-}
221
222------------------------------------------------------------------------
223
224-- This code implements the allocation of memory for 'DataDef's. In this
225-- case, allocation means assigning a unique non-overlapping 'MEM.Address'.
226-- This is separated from the initialization of the memory, which is
227-- performed by 'initData'. Decoupling this enables forwards references.
228--
229-- For example:
230--
231--  data $a = { l $b }
232--  data $b = { b 0 }
233
234-- Specifies the memory layout of the data memory. That is, for each
235-- 'DataDef' defined in QBE, it specifies a start address in memory.
236type DataMem = [(MEM.Address, QBE.DataDef)]
237
238allocDataDef ::
239  QBE.DataDef ->
240  (MEM.Address, DataMem) ->
241  (MEM.Address, DataMem)
242allocDataDef dataDef (startAddr, memMap) =
243  let addr =
244        MEM.alignAddr startAddr $
245          fromMaybe maxAlign (QBE.align dataDef)
246      size = fromIntegral $ QBE.dataSize dataDef
247   in (addr + size, (addr, dataDef) : memMap)
248  where
249    -- The alignment of an aggregate type is the maximum alignment the members.
250    maxAlign = maximum $ map QBE.objAlign (QBE.objs dataDef)
251
252allocData :: MEM.Address -> [QBE.DataDef] -> DataMem
253allocData startAddr dataDefs =
254  snd $ foldr allocDataDef (startAddr, []) dataDefs
255
256------------------------------------------------------------------------
257
258-- | Unlift 'Control.Exception.IOException' handling into a generic t'StateT' monad.
259--
260-- See also: <https://hackage.haskell.org/package/unliftio>.
261unliftCatch ::
262  (Exception t) =>
263  StateT s IO a -> (t -> StateT s IO a) -> StateT s IO a
264unliftCatch st handler = do
265  StateT $ \s -> do
266    let state = runStateT st s
267    state `catch` (\e -> runStateT (handler e) s)
268{-# INLINEABLE unliftCatch #-}
269
270-- | Simulator state, parameterized over a value and byte representation.
271newtype SimState v b a = SimState {unSimState :: StateT (Env v b) IO a}
272  deriving (Functor, Applicative, Monad, MonadIO)
273
274deriving instance MonadState (Env v b) (SimState v b)
275
276-- | Implements 'MonadError' in t'SimState' via 'Control.Exception.IOException's.
277-- This should be more performant than using t'Control.Monad.Except.ExceptT'
278-- monad transformer in conjunction with t'StateT'.
279instance MonadError Err.EvalError (SimState v b) where
280  throwError = liftIO . throwIO
281  catchError (SimState st) handler =
282    SimState $ unliftCatch st (unSimState . handler)
283
284------------------------------------------------------------------------
285
286-- | Like 'MEM.loadBytes' but receives a 'QBE.LoadType' as an argument, deducing
287-- the size from it. Further, also catches any errors potentionally raised by
288-- the memory and rethrows them as a 'EvalError'.
289safeLoadBytes ::
290  (NFData a) =>
291  MEM.Memory IOArray a ->
292  MEM.Address ->
293  QBE.LoadType ->
294  SimState v b [a]
295safeLoadBytes mem addr ty = do
296  let size = QBE.loadByteSize ty
297  mayBytes <-
298    liftIO $
299      try (MEM.loadBytes mem addr size >>= evaluate . force)
300
301  case mayBytes of
302    Left (ErrorCall msg) -> throwError $ Err.MemoryError msg
303    Right bytes -> pure bytes
304{-# INLINE safeLoadBytes #-}
305
306instance (MEM.Storable v b, E.ValueRepr v, NFData b) => Simulator (SimState v b) v where
307  isTrue value = pure (E.toWord64 value /= 0)
308  toAddress = pure . E.toWord64
309
310  lookupSymbol ident = gets (Map.lookup ident . envSyms)
311
312  findFunc ident = do
313    funcs <- gets envFuncs
314    pure $ case Map.lookup ident funcs of
315      Just x -> Just $ SFuncDef x
316      Nothing -> SSimFunc <$> lookupSimFunc ident
317  findFuncByAddr addr = do
318    fptrs <- gets envFuncAddrs
319    case Map.lookup addr fptrs of
320      Just fn -> findFunc fn
321      Nothing -> pure Nothing
322
323  activeFrame = do
324    stk <- gets envStk
325    case stk of
326      (x : _) -> pure x
327      [] -> throwError Err.EmptyStack
328  pushStackFrame frame =
329    modify (\s -> s {envStk = frame : envStk s})
330  popStackFrame = do
331    stk <- gets envStk
332    case stk of
333      (x : xs) -> modify (\s -> s {envStk = xs}) >> pure x
334      [] -> throwError Err.EmptyStack
335
336  getSP = gets envStkPtr
337  setSP sp = modify (\s -> s {envStkPtr = sp})
338
339  writeMemory addr extType val = do
340    mem <- gets envMem
341
342    -- Since halfwords and bytes are not first class in the IL, storeh and storeb
343    -- take a word as argument. Only the first 16 or 8 bits of this word will be
344    -- stored in memory at the address specified in the second argument.
345    let bytes = MEM.toBytes val
346    liftIO $
347      MEM.storeBytes mem addr $
348        case extType of
349          QBE.Byte -> take 1 bytes
350          QBE.HalfWord -> take 2 bytes
351          QBE.Base _ -> bytes
352  readMemory ty addr = do
353    mem <- gets envMem
354    bytes <- safeLoadBytes mem addr ty
355
356    case MEM.fromBytes ty bytes of
357      Just x -> pure x
358      Nothing -> throwError InvalidMemoryLoad
359
360------------------------------------------------------------------------
361
362run :: (E.ValueRepr v, MEM.Storable v b) => Env v b -> SimState v b a -> IO a
363run env state = evalStateT (unSimState state) env
364{-# SPECIALIZE run :: Env D.RegVal Word8 -> SimState D.RegVal Word8 a -> IO a #-}