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