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