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 FunctionalDependencies #-}
  5
  6-- | This module defines the abstract 'Simulator' monad and thus provides the primitives
  7-- used by "Language.QBE.Simulator" to describe the semantics of the QBE intermediate
  8-- representation.
  9module Language.QBE.Simulator.State
 10  ( -- * Abstract Monad
 11    Simulator (..),
 12
 13    -- * Name Resolution
 14    SomeFunc (..),
 15    lookupFunc,
 16    lookupArgs,
 17    lookupGlobal,
 18    lookupLocal,
 19    lookupValue,
 20
 21    -- * Helper
 22    liftMaybe,
 23    subType,
 24    runBinary,
 25    returnFromFunc,
 26    readNullArray,
 27
 28    -- * Stack
 29    StackFrame (..),
 30    newStackFrame,
 31    storeLocal,
 32    modifyFrame,
 33    stackAlign,
 34    stackAlloc,
 35    stackSpill,
 36  )
 37where
 38
 39import Control.Monad.Error.Class (MonadError, throwError)
 40import Data.Functor ((<&>))
 41import Data.Map qualified as Map
 42import Data.Maybe (catMaybes)
 43import Data.Word (Word64)
 44import Language.QBE.Simulator.Error
 45import Language.QBE.Simulator.Expression qualified as E
 46import Language.QBE.Simulator.Memory qualified as MEM
 47import Language.QBE.Types qualified as QBE
 48
 49-- | Representation of a stack frame on the function call stack.
 50data StackFrame v
 51  = StackFrame
 52  { stkFunc :: QBE.FuncDef,
 53    stkVars :: Map.Map QBE.LocalIdent v,
 54    stkVarArgs :: [v],
 55    stkFp :: v
 56  }
 57
 58-- | Create a new t'StackFrame' and push it onto the call stack.
 59newStackFrame ::
 60  (Simulator m v) =>
 61  -- | Definition of the functions to which this frame belongs.
 62  QBE.FuncDef ->
 63  -- | Named arguments passed to this function.
 64  Map.Map QBE.LocalIdent v ->
 65  -- | Optional, unnamed variadic arguments.
 66  [v] ->
 67  m (StackFrame v)
 68newStackFrame f args variadicArgs = do
 69  frame <- getSP <&> StackFrame f args variadicArgs
 70  pushStackFrame frame >> pure frame
 71{-# INLINEABLE newStackFrame #-}
 72
 73-- | Store a local variable with a given name and value in the given t'StackFrame'.
 74storeLocal :: QBE.LocalIdent -> v -> StackFrame v -> StackFrame v
 75storeLocal ident value frame@(StackFrame {stkVars = v}) =
 76  frame {stkVars = Map.insert ident value v}
 77
 78-- | Lookup a local variable in the current t'StackFrame'.
 79lookupLocal :: StackFrame v -> QBE.LocalIdent -> Maybe v
 80lookupLocal (StackFrame {stkVars = v}) = flip Map.lookup v
 81{-# INLINEABLE lookupLocal #-}
 82
 83------------------------------------------------------------------------
 84
 85-- | Representation of a function.
 86data SomeFunc m v
 87  = -- | A simulated function whose execution is intercepted by the Simulator.
 88    SSimFunc ([v] -> m (Maybe v))
 89  | -- | A QBE function defined in the input program.
 90    SFuncDef QBE.FuncDef
 91
 92-- | This is an “abstract monad” representing the Simulator and allowing
 93-- interaction with an encapsulated Simulator state @m@. Conceptually,
 94-- this monads describes the primitives based on which the semantics of
 95-- the QBE intermediate representation are abstractly described in
 96-- 'Language.QBE.Simulator'.
 97--
 98-- An instance of this monad then provides concrete semantics for these
 99-- primitives. For example, the module "Language.QBE.Simulator.Default.State"
100-- provides an implementation of a polymorphic Simulator state implement over a
101-- "Control.Monad.State" monad.
102--
103-- The idea is inspired by Bourgeat et al. <https://doi.org/10.1145/3607833>.
104class (E.ValueRepr v, MonadError EvalError m) => Simulator m v | m -> v where
105  -- | Check if a value of type 'E.ValueRepr' evaluates to true. This is used
106  -- within "Language.QBE.Simulator" to implement conditional jumps.
107  isTrue :: v -> m Bool
108
109  -- | Convert a value of type 'E.ValueRepr' to a 'MEM.Address' that can be
110  -- used to index a "Language.QBE.Simulator.Memory".
111  toAddress :: v -> m MEM.Address
112
113  -- | Lookup the address of a data symbol.
114  lookupSymbol :: QBE.GlobalIdent -> m (Maybe MEM.Address)
115
116  -- | Find a function by name, required to implement [call instructions](https://c9x.me/compile/doc/il-v1.2.html#Call).
117  findFunc :: QBE.GlobalIdent -> m (Maybe (SomeFunc m v))
118
119  -- | Find a function by "text segment" address, used for the implementation of function pointers.
120  findFuncByAddr :: MEM.Address -> m (Maybe (SomeFunc m v))
121
122  -- | Return the t'StackFrame' of the currently executed function.
123  activeFrame :: m (StackFrame v)
124
125  -- | Push a new t'StackFrame' onto the function call stack.
126  pushStackFrame :: StackFrame v -> m ()
127
128  -- | Pop the current stack frame from the function call stack.
129  -- Should throw 'EmptyStack' when invoked on an empty function call stack.
130  popStackFrame :: m (StackFrame v)
131
132  -- | Get the current value of the stack pointer.
133  getSP :: m v
134
135  -- | Set the value of the stack pointer.
136  setSP :: v -> m ()
137
138  -- | Write a value to memory.
139  writeMemory :: MEM.Address -> QBE.ExtType -> v -> m () -- TODO: LoadType?
140
141  -- | Read a value from memory.
142  readMemory :: QBE.LoadType -> MEM.Address -> m v
143
144-- | Extracts the element out of a 'Just' or throw the given 'EvalError' if
145-- if its argument is 'Nothing'.
146liftMaybe :: (MonadError EvalError m) => EvalError -> Maybe a -> m a
147liftMaybe e Nothing = throwError e
148liftMaybe _ (Just r) = pure r
149{-# INLINE liftMaybe #-}
150
151-- | Implements the subtyping rules of the QBE intermediate representation.
152--
153-- See <https://c9x.me/compile/doc/il-v1.2.html#Subtyping>.
154subType :: (Simulator m v) => QBE.BaseType -> v -> m v
155subType baseTy v = liftMaybe TypingError $ subType' baseTy (E.getType v)
156  where
157    subType' QBE.Word (QBE.Base QBE.Word) = Just v
158    subType' QBE.Word (QBE.Base QBE.Long) =
159      E.extract (QBE.Base QBE.Word) v
160    subType' QBE.Long (QBE.Base QBE.Long) = Just v
161    subType' QBE.Single (QBE.Base QBE.Single) = Just v
162    subType' QBE.Double (QBE.Base QBE.Double) = Just v
163    subType' _ _ = Nothing
164{-# INLINEABLE subType #-}
165
166-- | Invoke a binary operation and perform subtyping (see 'subType') on its
167-- results for the provided 'QBE.BaseType'. If the operation returns a 'Nothing'
168-- value a 'TypingError' is raised.
169runBinary ::
170  (Simulator m v) =>
171  QBE.BaseType ->
172  (v -> v -> Maybe v) ->
173  v ->
174  v ->
175  m v
176runBinary ty op lhs rhs =
177  liftMaybe TypingError (op lhs rhs) >>= subType ty
178{-# INLINEABLE runBinary #-}
179
180-- | Modify the current t'StackFrame', e.g. to add a new local variable to it.
181-- If the function call stack is currently empty an 'EmptyStack' error is thrown.
182modifyFrame :: (Simulator m v) => (StackFrame v -> StackFrame v) -> m ()
183modifyFrame func = do
184  frame <- popStackFrame
185  pushStackFrame (func frame)
186{-# INLINEABLE modifyFrame #-}
187
188-- | Align a stack address. Contrary to 'MEM.alignAddr', this rounds down to
189-- the nearest aligned addressed (not up) as the stack grows downward. Further,
190-- since the SP representation is presently not fixed, it operates on 'E.ValueRepr'.
191stackAlign :: (E.ValueRepr v) => v -> v -> Maybe v
192stackAlign addr alignment =
193  addr `E.urem` alignment >>= (addr `E.sub`)
194{-# INLINEABLE stackAlign #-}
195
196-- | Allocate a given amount of bytes on the stack with the given alignment.
197-- Advances the stack pointer accordingly.
198stackAlloc :: (Simulator m v) => v -> Word64 -> m v
199stackAlloc size align = do
200  stkPtr <- getSP
201  let newStkPtr = stkPtr `E.sub` size >>= (`stackAlign` E.fromLit (QBE.Base QBE.Long) align)
202  case newStkPtr of
203    Just ptr -> setSP ptr >> pure ptr
204    Nothing -> throwError InvalidAddressType
205{-# INLINEABLE stackAlloc #-}
206
207-- | Allocate space for the given value on the stack and store it there.
208-- Returns a reference (i.e., a memory address) fore the allocated memory.
209stackSpill :: (Simulator m v) => v -> m MEM.Address
210stackSpill val = do
211  let ty = E.getType val
212      size = fromIntegral $ QBE.extTypeByteSize ty
213      sizeVal = E.fromLit (QBE.Base QBE.Long) size
214  ptr <- stackAlloc sizeVal size >>= toAddress
215  writeMemory ptr ty val
216  pure ptr
217{-# INLINEABLE stackSpill #-}
218
219-- | Trigger a function return, popping its t'StackFrame' from the call stack
220-- and updating both the stack and frame pointer.
221returnFromFunc :: (Simulator m v) => m ()
222returnFromFunc = popStackFrame >>= setSP . stkFp
223{-# INLINE returnFromFunc #-}
224
225maybeLookup :: (Simulator m v) => String -> Maybe a -> m a
226maybeLookup name = liftMaybe (UnknownVariable name)
227{-# INLINE maybeLookup #-}
228
229-- | Lookup a global variable, might throw an 'UnknownVariable' error.
230lookupGlobal :: (Simulator m v) => QBE.BaseType -> QBE.GlobalIdent -> m v
231lookupGlobal ty name = do
232  v <- lookupSymbol name >>= maybeLookup (show name)
233  subType ty (E.fromLit (QBE.Base QBE.Long) v)
234{-# INLINEABLE lookupGlobal #-}
235
236-- | Lookup a 'QBE.Value', invoking the correct lookup function. For example,
237-- 'lookupGlobal' for globals or 'lookupLocal' for local variables.
238lookupValue :: (Simulator m v) => QBE.BaseType -> QBE.Value -> m v
239lookupValue ty (QBE.VConst (QBE.Const (QBE.Number v))) =
240  pure $ E.fromLit (QBE.Base ty) v
241lookupValue ty (QBE.VConst (QBE.Const (QBE.SFP v))) =
242  subType ty (E.fromFloat v)
243lookupValue ty (QBE.VConst (QBE.Const (QBE.DFP v))) =
244  subType ty (E.fromDouble v)
245lookupValue ty (QBE.VConst (QBE.Const (QBE.Global k))) = lookupGlobal ty k
246lookupValue ty (QBE.VConst (QBE.Thread k)) = lookupGlobal ty k
247lookupValue ty (QBE.VConst (QBE.Extern k)) = lookupGlobal ty k
248lookupValue ty (QBE.VConst (QBE.ExternThread k)) = lookupGlobal ty k
249lookupValue ty (QBE.VLocal k) = do
250  v <- activeFrame >>= maybeLookup (show k) . flip lookupLocal k
251  subType ty v
252{-# INLINEABLE lookupValue #-}
253
254lookupFuncName :: (Simulator m v) => QBE.GlobalIdent -> m (SomeFunc m v)
255lookupFuncName name = do
256  maybeFunc <- findFunc name
257  case maybeFunc of
258    Just def -> pure def
259    Nothing -> throwError (UnknownFunction name)
260{-# INLINEABLE lookupFuncName #-}
261
262-- | Interpret the given 'QBE.Value' as a function reference, either
263-- looking it up by name or by address. If the function could not be
264-- found by address an 'UnknownFunctionAddr' is thrown, otherwise an
265-- 'UnknownFunction' error is thrown.
266lookupFunc :: (Simulator m v) => QBE.Value -> m (SomeFunc m v)
267lookupFunc (QBE.VConst (QBE.Extern n)) = lookupFuncName n
268lookupFunc (QBE.VConst (QBE.Const (QBE.Global n))) = lookupFuncName n
269lookupFunc value = do
270  addr <- lookupValue QBE.Long value >>= toAddress
271  maybeFunc <- findFuncByAddr addr
272  case maybeFunc of
273    Just def -> pure def
274    Nothing -> throwError (UnknownFunctionAddr addr)
275{-# INLINEABLE lookupFunc #-}
276
277lookupArg :: (Simulator m v) => QBE.FuncArg -> m (Maybe v)
278lookupArg (QBE.ArgReg abity value) =
279  Just <$> lookupValue (QBE.abityToBase abity) value
280lookupArg (QBE.ArgEnv _) = error "env function parameters not supported"
281lookupArg QBE.ArgVar = pure Nothing
282{-# INLINEABLE lookupArg #-}
283
284-- | Lookup the arguments to a function.
285lookupArgs :: (Simulator m v) => [QBE.FuncArg] -> m [v]
286lookupArgs args = catMaybes <$> mapM lookupArg args
287{-# INLINE lookupArgs #-}
288
289-- | Read a null-terminated C string from memory at the given 'MEM.Address'.
290-- The return value is a list of 8-bit values.
291readNullArray :: (Simulator m v) => MEM.Address -> m [v]
292readNullArray addr = go addr []
293  where
294    go a acc = do
295      byte <- readMemory (QBE.LSubWord QBE.SignedByte) a
296      if E.toWord64 byte == 0
297        then pure acc
298        else go (a + 1) (acc ++ [byte])
299{-# INLINE readNullArray #-}