qute (empty) → 0.1.0
raw patch · 20 files changed
+4735/−0 lines, 20 filesdep +arraydep +basedep +containers
Dependencies added: array, base, containers, criterion, deepseq, exceptions, filepath, mtl, parsec, qute, qute-syntax, tasty, tasty-hunit, template-haskell
Files
- bench/Main.hs +43/−0
- qute.cabal +125/−0
- src/Language/QBE/Analysis/CDG.hs +128/−0
- src/Language/QBE/Analysis/CFG.hs +154/−0
- src/Language/QBE/Analysis/Graph.hs +727/−0
- src/Language/QBE/Simulator.hs +349/−0
- src/Language/QBE/Simulator/Default/Expression.hs +372/−0
- src/Language/QBE/Simulator/Default/Funcs.hs +29/−0
- src/Language/QBE/Simulator/Default/Generator.hs +141/−0
- src/Language/QBE/Simulator/Default/State.hs +364/−0
- src/Language/QBE/Simulator/Error.hs +53/−0
- src/Language/QBE/Simulator/Expression.hs +184/−0
- src/Language/QBE/Simulator/Memory.hs +121/−0
- src/Language/QBE/Simulator/State.hs +299/−0
- test/Analysis.hs +153/−0
- test/Expression.hs +104/−0
- test/Main.hs +26/−0
- test/Memory.hs +40/−0
- test/Simulator.hs +1281/−0
- test/State.hs +42/−0
+ bench/Main.hs view
@@ -0,0 +1,43 @@+-- SPDX-FileCopyrightText: 2025 Sören Tempel <soeren+git@soeren-tempel.net>+--+-- SPDX-License-Identifier: GPL-3.0-only++module Main (main) where++import Control.Monad (void)+import Criterion.Main (Benchmarkable, bench, bgroup, defaultMain, nfIO)+import Data.Word (Word32, Word64, Word8)+import Language.QBE (parseAndFind)+import Language.QBE.Simulator (execFunc)+import Language.QBE.Simulator.Default.Expression qualified as D+import Language.QBE.Simulator.Default.State (Env, mkEnv, run)+import Language.QBE.Types qualified as QBE++exec :: [D.RegVal] -> String -> IO ()+exec params input = do+ (prog, func) <- parseAndFind entryFunc input++ env <- mkEnv prog 0 memSize :: IO (Env D.RegVal Word8)+ void $ run env (execFunc func params)+ where+ memSize :: Word64+ memSize = 1024 * 1024 * 10++ entryFunc :: QBE.GlobalIdent+ entryFunc = QBE.GlobalIdent "entry"++bubbleSort :: Word32 -> Benchmarkable+bubbleSort inputSize =+ nfIO (readFile "bench/data/bubble-sort.qbe" >>= exec [D.VWord inputSize])++-- Our benchmark harness.+main :: IO ()+main =+ defaultMain+ [ bgroup+ "bubble-sort"+ [ bench "10" $ bubbleSort 25,+ bench "50" $ bubbleSort 50,+ bench "100" $ bubbleSort 100+ ]+ ]
+ qute.cabal view
@@ -0,0 +1,125 @@+cabal-version: 3.4+name: qute+version: 0.1.0+synopsis: A software analysis framework built around the QBE intermediate language.+description:+ This library provides formal semantics for the [QBE intermediate language](https://c9x.me/compile/)+ by providing [modular monadic semantics](https://doi.org/10.1007/3-540-61055-3_39) implemented using+ an [abstract monad](https://doi.org/10.1145/3607833). The package refers to this abstract monad as+ the 'Language.QBE.Simulator.State.Simulator' monad. It provides several primitives that are used by+ the "Language.QBE.Simulator" to /abstractly/ describe the semantics of QBE instructions. The+ 'Language.QBE.Simulator.State.Simulator' can then be instantiated with /concrete/ semantics. For+ example, the "Language.QBE.Simulator.Default.State" module provides an instantiation using a+ 'Control.Monad.State' monad. This instantiation, and the 'Language.QBE.Simulator.State.Simulator'+ itself, are parameterized over the representation of QBE instruction operand values.++ To abstractly describe operations on values passed to QBE instructions, this library additionally+ provides an expression language abstraction in the "Language.QBE.Simulator.Expression" module.+ Further, an implementation of this expression language based on fixed-width integer values is+ available in the "Language.QBE.Simulator.Default.Expression" module.++ A separate [qute-symex](https://hackage.haskell.org/package/qute-symex) package provides an+ implementation of the expression abstraction and the 'Language.QBE.Simulator.State.Simulator'+ monad for formal reasoning about a software under test using+ [symbolic execution](https://en.wikipedia.org/wiki/Symbolic_execution).+ Similar dynamic software testing techniques can be implemented using this library. Additionally,+ there is some preliminary support for static analysis as well through the+ "Language.QBE.Analysis.CFG" module.++ More information on the underlying idea and vision behind Qute is available in a+ [separate paper](https://www.ibr.cs.tu-bs.de/vss/Publications/2026/tempel_26_qute.pdf).+license: GPL-3.0-only AND MIT AND BSD-3-Clause+-- license-file:+author: Sören Tempel+maintainer: soeren+hackage@soeren-tempel.net+-- copyright:+category: Language+build-type: Simple+homepage: https://git.8pit.net/qute+bug-reports: https://github.com/nmeum/qute/issues++source-repository head+ type: git+ location: https://git.8pit.net/qute.git++common warnings+ -- -Wall-missed-specializations can be useful too+ ghc-options: -Wall++common opts+ ghc-options: -fspecialise-aggressively++library+ import: warnings, opts+ -- other-modules:+ hs-source-dirs: src+ default-language: GHC2021++ build-depends:+ base >= 4.16.4.0 && < 4.23,+ array >= 0.5.4.0 && < 0.6,+ deepseq >= 1.4.6.1 && < 1.6,+ template-haskell >= 2.18.0.0 && < 2.25,+ qute-syntax == 0.1.*,+ containers >= 0.6.5.1 && < 0.9,+ exceptions >= 0.10.4 && < 0.11,+ parsec >= 3.1.15 && < 3.19,+ mtl >= 2.2.2 && < 2.4++ other-modules:+ Language.QBE.Simulator.Default.Generator++ exposed-modules:+ Language.QBE.Analysis.CFG,+ Language.QBE.Analysis.CDG,+ Language.QBE.Analysis.Graph,+ Language.QBE.Simulator,+ Language.QBE.Simulator.State,+ Language.QBE.Simulator.Error,+ Language.QBE.Simulator.Memory,+ Language.QBE.Simulator.Expression,+ Language.QBE.Simulator.Default.State,+ Language.QBE.Simulator.Default.Funcs,+ Language.QBE.Simulator.Default.Expression++benchmark qute+ import: warnings, opts+ default-language: GHC2021+ type: exitcode-stdio-1.0+ hs-source-dirs: bench+ main-is: Main.hs++ build-depends:+ base,+ criterion ^>= 1.6.4.0,+ qute,+ qute-syntax++test-suite qute-test+ import: warnings+ default-language: GHC2021+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Main.hs+ -- Prevent GHGC from optimizing float2Double calls.+ ghc-options: -O0++ other-modules:+ Analysis,+ Simulator,+ Expression,+ Memory,+ State++ build-depends:+ base,+ array,+ parsec,+ filepath,+ qute,+ qute-syntax,+ containers,+ exceptions,+ mtl,+ tasty >=1.4.3,+ tasty-hunit >=0.10
+ src/Language/QBE/Analysis/CDG.hs view
@@ -0,0 +1,128 @@+-- SPDX-FileCopyrightText: 2010 Tristan Ravitch <travitch@cs.wisc.edu>+-- SPDX-FileCopyrightText: 2026 Reliable System Software, Technische Universität Braunschweig <vss@ibr.cs.tu-bs.de>+--+-- SPDX-License-Identifier: BSD-3-Clause AND GPL-3.0-only++-- Based on the implementation provided by LLVM.Analysis.CDG from Tristan Ravitch+-- See https://hackage.haskell.org/package/llvm-analysis-0.3.0/docs/src/LLVM-Analysis-CDG.html+--+-- The implementation by Tristan Ravitch mentions a paper by Cytron et al.+-- See: https://doi.org/10.1145/115372.115320+--+-- However, I found that the original paper by Ferrante et al. does a much better job at+-- explaining what was implemented by Tristan Ravitch in llvm-analysis. Hence, the comments+-- below mainly refer to that: https://doi.org/10.1145/24039.24041++-- | This module implements a control dependency analysis, using a+-- /control dependency graph/ (CDG) for more information on the concept+-- refer to <https://doi.org/10.1145/24039.24041>. Roughly speaking, a+-- node /A/ is control dependent on /B/ if there is an edge /B → A/ so+-- that the node is taken, as well as an edge so that it is not taken.+module Language.QBE.Analysis.CDG+ ( CDG (..),+ build,+ edges,+ ctrlDeps,+ )+where++import Data.Bifunctor (second)+import Data.IntMap (IntMap)+import Data.IntMap qualified as M+import Data.IntSet (IntSet)+import Data.IntSet qualified as S+import Data.List (find)+import Data.Maybe (fromMaybe)+import Language.QBE.Analysis.CFG qualified as CFG+import Language.QBE.Analysis.Graph qualified as G++-- | A CDG signifying control-dependence between nodes in the 'CFG.CFG'.+data CDG+ = CDG+ { -- | Underlying 'CFG.CFG' for which the CDG was built.+ cdgCfg :: CFG.CFG,+ -- | Root node of the t'CDG', used for determining post-dominance.+ cdgRoot :: CFG.Label,+ -- | Graph representation of control-dependence.+ cdgGraph :: G.Graph+ }++-- | All edges of the t'CDG', in an unspecified order.+edges :: CDG -> [(CFG.Label, CFG.Label)]+edges cdg = foldl go [] $ M.toList (cdgGraph cdg)+ where+ go acc (p, c) = acc ++ map (p,) (S.toList c)++-- | Returns the control dependencies of a given node in the 'CFG.CFG'.+-- If the node doesn't have any control dependencies, 'Nothing' is+-- returned.+ctrlDeps :: CDG -> CFG.Label -> Maybe IntSet+ctrlDeps CDG {cdgGraph = cDeps} = (`M.lookup` cDeps)++------------------------------------------------------------------------++-- | Construct a new t'CDG' from an existing 'CFG.CFG'. The CDG is build+-- based on the given 'CFG.Label' from the CFG, which is used to as the+-- root of a post-dominator tree to establish a post-dominance+-- relationship between nodes.+build :: CFG.CFG -> CFG.Label -> CDG+build cfg root =+ CDG+ { cdgCfg = cfg,+ cdgRoot = root,+ cdgGraph = build' cfg root+ }++build' :: CFG.CFG -> CFG.Label -> IntMap IntSet+build' cfg label =+ -- From the CFG, generate a post-dominator tree and also convert this tree+ -- to an IntMap representation for efficient successor lookup in 'addCDGEdge'.+ let rooted = (label, CFG.asDomGraph cfg)+ pdTree = G.pdomTree rooted+ pdtMap = M.fromList $ map (second S.fromList) (G.pdom rooted)+ pdtAnc = M.fromList (G.ancestors pdTree)+ in foldr (uncurry $ addCDGEdge pdtMap pdtAnc) M.empty $ CFG.edges cfg++-- This function essentially implements the algorithm described in Section 3.1+-- of the Paper by Ferrante et al., using the algorithm by Cytron et al. may be+-- more efficient and could be considered in the future.+addCDGEdge ::+ IntMap IntSet ->+ IntMap [Int] ->+ CFG.Label ->+ CFG.Label ->+ IntMap IntSet ->+ IntMap IntSet+addCDGEdge pdtMap pdtAnc a b acc+ -- Consider all edges (A, B) in the control flow graph such that B does not+ -- post-dominate M. If it does, we return 'acc' unmodified (insert nothing).+ | postdominates b a = acc+ | otherwise =+ -- Let AC denote the least common ancestor of A and B in the post-dominator tree.+ case commonAncestor b a of+ -- Case 1: All nodes in the post-dominator tree on the path from AC to+ -- B, including B but not AC, should be made control dependent on A.+ Just ac ->+ let cdepsOnA = S.insert b (S.filter (/= ac) $ lookupSucc b)+ in foldr insertEdge acc (S.toList cdepsOnA)+ -- Case 2: All nodes in the post-dominator tree on the path from A to B,+ -- including A and B, should be made control dependent on A.+ Nothing ->+ let deps = S.insert b $ lookupSucc b+ in foldr insertEdge acc (S.toList deps)+ where+ insertEdge :: CFG.Label -> IntMap IntSet -> IntMap IntSet+ insertEdge blk = M.insertWith S.union blk (S.singleton a)++ lookupSucc :: CFG.Label -> IntSet+ lookupSucc l = fromMaybe S.empty $ M.lookup l pdtMap++ -- Returns true if 'x' post-dominates 'y'.+ postdominates :: CFG.Label -> CFG.Label -> Bool+ postdominates x y = maybe False (x `S.member`) $ M.lookup y pdtMap++ commonAncestor :: G.Node -> G.Node -> Maybe G.Node+ commonAncestor n1 n2 = do+ a1 <- M.lookup n1 pdtAnc+ a2 <- M.lookup n2 pdtAnc+ find (`elem` a1) a2
+ src/Language/QBE/Analysis/CFG.hs view
@@ -0,0 +1,154 @@+-- SPDX-FileCopyrightText: 2025 Sören Tempel <soeren+git@soeren-tempel.net>+-- SPDX-FileCopyrightText: 2026 Reliable System Software, Technische Universität Braunschweig <vss@ibr.cs.tu-bs.de>+--+-- SPDX-License-Identifier: GPL-3.0-only++module Language.QBE.Analysis.CFG+ ( -- * Control Flow Graph+ Label,+ CFG (cfgFunction),+ build,+ identToLabel,+ labelToIdent,+ labelToBlock,+ lookupSuccs,++ -- * Graph Representation+ asGraph,+ nodes,+ edges,+ bounds,++ -- * Dominator Analysis+ asDomGraph,+ startNode,+ )+where++import Data.Graph (Bounds, Graph, buildG)+import Data.IntMap (IntMap)+import Data.IntMap qualified as IntMap+import Data.IntSet qualified as IntSet+import Data.Map (Map)+import Data.Map qualified as Map+import Data.Maybe (fromJust)+import Data.Tuple (swap)+import Language.QBE.Analysis.Graph qualified as DG+import Language.QBE.Types qualified as QBE++-- | Representation of a node in the t'CFG'.+type Label = IntMap.Key++-- | A representation of the control-flow within a 'QBE.FuncDef'.+data CFG+ = CFG+ { -- | Function for which this CFG was built.+ cfgFunction :: QBE.FuncDef,+ cfgMaxBound :: Int,+ cfgLabelMap :: Map QBE.BlockIdent Label,+ cfgBlockMap :: IntMap QBE.BlockIdent,+ cfgSuccessors :: IntMap [Label]+ }++-- | Returns a list of all graph nodes in an unspecified order.+nodes :: CFG -> [Label]+nodes = IntMap.keys . cfgBlockMap++-- | Returns a list of graph edges in an unspecified order.+edges :: CFG -> [(Label, Label)]+edges cfg = foldl go [] $ IntMap.toList (cfgSuccessors cfg)+ where+ go acc (p, c) = acc ++ map (p,) c++-- | Returns the bounds of the t'CFG'. This is useful, for example, to+-- build a subgraph using 'Data.Graph.buildG'.+bounds :: CFG -> Bounds+bounds cfg = (0, cfgMaxBound cfg)++-- | Convert a 'QBE.BlockIdent' to a CFG node 'Label'.+--+-- This function is partial, on an invalid 'Label', an error is thrown.+identToLabel :: CFG -> QBE.BlockIdent -> Label+identToLabel CFG {cfgLabelMap = m} blkId =+ fromJust $ Map.lookup blkId m++-- | Convert a CFG node 'Label' to a 'QBE.BlockIdent'.+--+-- This function is partial, on an invalid 'Label', an error is thrown.+labelToIdent :: CFG -> Label -> QBE.BlockIdent+labelToIdent CFG {cfgBlockMap = m} label =+ fromJust $ IntMap.lookup label m++-- | Utility function to convert a node 'Label' to a 'QBE.Block'.+-- Performs two \(O(\log n)\) lookups internally.+--+-- This function is partial, on an invalid 'Label', an error is thrown.+labelToBlock :: CFG -> Label -> QBE.Block+labelToBlock cfg label =+ let blocks = QBE.fBlock $ cfgFunction cfg+ in fromJust $ Map.lookup (labelToIdent cfg label) blocks++-- | Mapping of 'Label' to its successors in the CFG, represented as an+-- ordered list of zero, one, or two elements. A list with two elements+-- represents a conditional jump where the left child is the is the true+-- branch and the right child is the false branch. A list wih a single+-- element signifies an unconditional jump. If the given node does not+-- have any successors an empty list is returned.+--+-- This function is partial, on an invalid 'Label', an error is thrown.+lookupSuccs :: CFG -> Label -> [Label]+lookupSuccs CFG {cfgSuccessors = succs} label =+ fromJust $ IntMap.lookup label succs++------------------------------------------------------------------------++identStart :: Label+identStart = 0++-- | Construct a t'CFG' for a given function.+build :: QBE.FuncDef -> CFG+build func =+ CFG+ { cfgMaxBound = snd $ last blkIdLabels,+ cfgFunction = func,+ cfgLabelMap = labelMap,+ cfgBlockMap = IntMap.fromList $ map swap blkIdLabels,+ cfgSuccessors = IntMap.fromList $ build' labelMap blocks+ }+ where+ labelMap :: Map QBE.BlockIdent Label+ labelMap = Map.fromList blkIdLabels++ blocks :: [QBE.Block]+ blocks = Map.elems $ QBE.fBlock func++ blkIdLabels :: [(QBE.BlockIdent, Label)]+ blkIdLabels = zip (map QBE.label blocks) [identStart ..]++build' :: Map QBE.BlockIdent Label -> [QBE.Block] -> [(IntMap.Key, [Label])]+build' labelMap = foldl go []+ where+ toLabel :: QBE.BlockIdent -> Label+ toLabel ident = fromJust $ Map.lookup ident labelMap++ go acc block@(QBE.Block {QBE.label = ident}) =+ let succs = case QBE.term block of+ QBE.Jump target -> [toLabel target]+ QBE.Jnz _ i1 i2 -> [toLabel i1, toLabel i2]+ QBE.Return _ -> []+ QBE.Halt -> []+ in (toLabel ident, succs) : acc++------------------------------------------------------------------------++asGraph :: CFG -> Graph+asGraph cfg = buildG (identStart, cfgMaxBound cfg) $ edges cfg++asDomGraph :: CFG -> DG.Graph+asDomGraph cfg = IntMap.map IntSet.fromList (cfgSuccessors cfg)++-- | Determine the entry node of the t'CFG'. Useful, for example, to+-- generated a 'DG.Rooted' representation for the control-flow graph.+startNode :: CFG -> Label+startNode cfg@(CFG {cfgFunction = func}) =+ identToLabel cfg (QBE.fStart func)
+ src/Language/QBE/Analysis/Graph.hs view
@@ -0,0 +1,727 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE Strict #-}+-- SPDX-FileCopyrightText: 2009 Matt Morrow <klebinger.andreas@gmx.at>+--+-- SPDX-License-Identifier: BSD-3-Clause+{-# OPTIONS_GHC -Wno-name-shadowing #-}++module Language.QBE.Analysis.Graph+ ( Node,+ Path,+ Edge,+ Graph,+ Rooted,+ idom,+ ipdom,+ domTree,+ pdomTree,+ dom,+ pdom,+ pddfs,+ rpddfs,+ fromAdj,+ fromEdges,+ toAdj,+ toEdges,+ asTree,+ asGraph,+ parents,+ ancestors,+ )+where++import Control.Monad+import Control.Monad.ST.Strict+import Data.Array.Base+ ( unsafeNewArray_,+ unsafeRead,+ unsafeWrite,+ )+import Data.Array.ST+import Data.IntMap (IntMap)+import Data.IntMap.Strict qualified as IM+import Data.IntSet (IntSet)+import Data.IntSet qualified as IS+import Data.Maybe+import Data.Tree+import Data.Tuple (swap)++-- Since GHC 9.10.1, Prelude exports foldl' before that we need 'Data.Foldable'.+--+-- See: https://gitlab.haskell.org/ghc/ghc/-/commit/f1ec362817baa5d440a9f2b3a8b17e5513538119+#if !MIN_VERSION_base(4,20,0)+import Data.Foldable (foldl')+#endif++-----------------------------------------------------------------------------++type Node = Int++type Path = [Node]++type Edge = (Node, Node)++type Graph = IntMap IntSet++type Rooted = (Node, Graph)++-----------------------------------------------------------------------------++-- | /Dominators/.+-- Complexity as for @idom@+dom :: Rooted -> [(Node, Path)]+dom = ancestors . domTree++-- | /Post-dominators/.+-- Complexity as for @idom@.+pdom :: Rooted -> [(Node, Path)]+pdom = ancestors . pdomTree++-- | /Dominator tree/.+-- Complexity as for @idom@.+domTree :: Rooted -> Tree Node+domTree a@(r, _) =+ let is = filter ((/= r) . fst) (idom a)+ tg = fromEdges (fmap swap is)+ in asTree (r, tg)++-- | /Post-dominator tree/.+-- Complexity as for @idom@.+pdomTree :: Rooted -> Tree Node+pdomTree a@(r, _) =+ let is = filter ((/= r) . fst) (ipdom a)+ tg = fromEdges (fmap swap is)+ in asTree (r, tg)++-- | /Immediate dominators/.+-- /O(|E|*alpha(|E|,|V|))/, where /alpha(m,n)/ is+-- \"a functional inverse of Ackermann's function\".+--+-- This Complexity bound assumes /O(1)/ indexing. Since we're+-- using @IntMap@, it has an additional /lg |V|/ factor+-- somewhere in there. I'm not sure where.+idom :: Rooted -> [(Node, Node)]+idom rg = runST (evalS idomM =<< initEnv (pruneReach rg))++-- | /Immediate post-dominators/.+-- Complexity as for @idom@.+ipdom :: Rooted -> [(Node, Node)]+ipdom rg = runST (evalS idomM =<< initEnv (pruneReach (second predG rg)))++-----------------------------------------------------------------------------++-- | /Post-dominated depth-first search/.+pddfs :: Rooted -> [Node]+pddfs = reverse . rpddfs++-- | /Reverse post-dominated depth-first search/.+rpddfs :: Rooted -> [Node]+rpddfs = concat . levels . pdomTree++-----------------------------------------------------------------------------++type Dom s a = S s (Env s) a++type NodeSet = IntSet++type NodeMap a = IntMap a++data Env s = Env+ { succE :: !Graph,+ predE :: !Graph,+ bucketE :: !Graph,+ dfsE :: {-# UNPACK #-} !Int,+ zeroE :: {-# UNPACK #-} !Node,+ rootE :: {-# UNPACK #-} !Node,+ labelE :: {-# UNPACK #-} !(Arr s Node),+ parentE :: {-# UNPACK #-} !(Arr s Node),+ ancestorE :: {-# UNPACK #-} !(Arr s Node),+ childE :: {-# UNPACK #-} !(Arr s Node),+ ndfsE :: {-# UNPACK #-} !(Arr s Node),+ dfnE :: {-# UNPACK #-} !(Arr s Int),+ sdnoE :: {-# UNPACK #-} !(Arr s Int),+ sizeE :: {-# UNPACK #-} !(Arr s Int),+ domE :: {-# UNPACK #-} !(Arr s Node),+ rnE :: {-# UNPACK #-} !(Arr s Node)+ }++-----------------------------------------------------------------------------++idomM :: Dom s [(Node, Node)]+idomM = do+ dfsDom =<< rootM+ n <- gets dfsE+ forM_+ [n, n - 1 .. 1]+ ( \i -> do+ w <- ndfsM i+ ps <- predsM w+ forM_+ ps+ ( \v -> do+ sw <- sdnoM w+ u <- eval v+ su <- sdnoM u+ when+ (su < sw)+ (store sdnoE w su)+ )+ z <- ndfsM =<< sdnoM w+ modify+ ( \e ->+ e+ { bucketE =+ IM.adjust+ (w `IS.insert`)+ z+ (bucketE e)+ }+ )+ pw <- parentM w+ link pw w+ bps <- bucketM pw+ forM_+ bps+ ( \v -> do+ u <- eval v+ su <- sdnoM u+ sv <- sdnoM v+ let dv = case su < sv of+ True -> u+ False -> pw+ store domE v dv+ )+ )+ forM_+ [1 .. n]+ ( \i -> do+ w <- ndfsM i+ j <- sdnoM w+ z <- ndfsM j+ dw <- domM w+ when+ (dw /= z)+ ( do+ ddw <- domM dw+ store domE w ddw+ )+ )+ fromEnv++-----------------------------------------------------------------------------++eval :: Node -> Dom s Node+eval v = do+ n0 <- zeroM+ a <- ancestorM v+ case a == n0 of+ True -> labelM v+ False -> do+ compress v+ a <- ancestorM v+ l <- labelM v+ la <- labelM a+ sl <- sdnoM l+ sla <- sdnoM la+ case sl <= sla of+ True -> return l+ False -> return la++compress :: Node -> Dom s ()+compress v = do+ n0 <- zeroM+ a <- ancestorM v+ aa <- ancestorM a+ when+ (aa /= n0)+ ( do+ compress a+ a <- ancestorM v+ aa <- ancestorM a+ l <- labelM v+ la <- labelM a+ sl <- sdnoM l+ sla <- sdnoM la+ when+ (sla < sl)+ (store labelE v la)+ store ancestorE v aa+ )++-----------------------------------------------------------------------------++link :: Node -> Node -> Dom s ()+link v w = do+ n0 <- zeroM+ lw <- labelM w+ slw <- sdnoM lw+ let balance s = do+ c <- childM s+ lc <- labelM c+ slc <- sdnoM lc+ case slw < slc of+ False -> return s+ True -> do+ zs <- sizeM s+ zc <- sizeM c+ cc <- childM c+ zcc <- sizeM cc+ case 2 * zc <= zs + zcc of+ True -> do+ store ancestorE c s+ store childE s cc+ balance s+ False -> do+ store sizeE c zs+ store ancestorE s c+ balance c+ s <- balance w+ lw <- labelM w+ zw <- sizeM w+ store labelE s lw+ store sizeE v . (+ zw) =<< sizeM v+ let follow s = do+ when+ (s /= n0)+ ( do+ store ancestorE s v+ follow =<< childM s+ )+ zv <- sizeM v+ follow =<< case zv < 2 * zw of+ False -> return s+ True -> do+ cv <- childM v+ store childE v s+ return cv++-----------------------------------------------------------------------------++dfsDom :: Node -> Dom s ()+dfsDom i = do+ _ <- go i+ n0 <- zeroM+ r <- rootM+ store parentE r n0+ where+ go i = do+ n <- nextM+ store dfnE i n+ store sdnoE i n+ store ndfsE n i+ store labelE i i+ ss <- succsM i+ forM_+ ss+ ( \j -> do+ s <- sdnoM j+ case s == 0 of+ False -> return ()+ True -> do+ store parentE j i+ go j+ )++-----------------------------------------------------------------------------++initEnv :: Rooted -> ST s (Env s)+initEnv (r0, g0) = do+ -- Graph renumbered to indices from 1 to |V|+ let (g, rnmap) = renum 1 g0+ pred = predG g -- reverse graph+ root = rnmap IM.! r0 -- renamed root+ n = IM.size g+ ns = [0 .. n]+ m = n + 1++ let bucket =+ IM.fromList+ (map (,mempty) ns)++ rna <- newI m+ writes+ rna+ ( fmap+ swap+ (IM.toList rnmap)+ )++ doms <- newI m+ sdno <- newI m+ size <- newI m+ parent <- newI m+ ancestor <- newI m+ child <- newI m+ label <- newI m+ ndfs <- newI m+ dfn <- newI m++ -- Initialize all arrays+ forM_ [0 .. n] (doms .= 0)+ forM_ [0 .. n] (sdno .= 0)+ forM_ [1 .. n] (size .= 1)+ forM_ [0 .. n] (ancestor .= 0)+ forM_ [0 .. n] (child .= 0)++ (doms .= root) root+ (size .= 0) 0+ (label .= 0) 0++ return+ ( Env+ { rnE = rna,+ dfsE = 0,+ zeroE = 0,+ rootE = root,+ labelE = label,+ parentE = parent,+ ancestorE = ancestor,+ childE = child,+ ndfsE = ndfs,+ dfnE = dfn,+ sdnoE = sdno,+ sizeE = size,+ succE = g,+ predE = pred,+ bucketE = bucket,+ domE = doms+ }+ )++fromEnv :: Dom s [(Node, Node)]+fromEnv = do+ dom <- gets domE+ rn <- gets rnE+ -- r <- gets rootE+ (_, n) <- st (getBounds dom)+ forM+ [1 .. n]+ ( \i -> do+ j <- st (rn !: i)+ d <- st (dom !: i)+ k <- st (rn !: d)+ return (j, k)+ )++-----------------------------------------------------------------------------++zeroM :: Dom s Node+zeroM = gets zeroE++domM :: Node -> Dom s Node+domM = fetch domE++rootM :: Dom s Node+rootM = gets rootE++succsM :: Node -> Dom s [Node]+succsM i = gets (IS.toList . (! i) . succE)++predsM :: Node -> Dom s [Node]+predsM i = gets (IS.toList . (! i) . predE)++bucketM :: Node -> Dom s [Node]+bucketM i = gets (IS.toList . (! i) . bucketE)++sizeM :: Node -> Dom s Int+sizeM = fetch sizeE++sdnoM :: Node -> Dom s Int+sdnoM = fetch sdnoE++-- dfnM :: Node -> Dom s Int+-- dfnM = fetch dfnE+ndfsM :: Int -> Dom s Node+ndfsM = fetch ndfsE++childM :: Node -> Dom s Node+childM = fetch childE++ancestorM :: Node -> Dom s Node+ancestorM = fetch ancestorE++parentM :: Node -> Dom s Node+parentM = fetch parentE++labelM :: Node -> Dom s Node+labelM = fetch labelE++nextM :: Dom s Int+nextM = do+ n <- gets dfsE+ let n' = n + 1+ modify (\e -> e {dfsE = n'})+ return n'++-----------------------------------------------------------------------------++type A = STUArray++type Arr s a = A s Int a++infixl 9 !:++infixr 2 .=++-- | arr .= x idx => write x to index+(.=) ::+ (MArray (A s) a (ST s)) =>+ Arr s a -> a -> Int -> ST s ()+(v .= x) i = unsafeWrite v i x++(!:) ::+ (MArray (A s) a (ST s)) =>+ A s Int a -> Int -> ST s a+a !: i = do+ o <- unsafeRead a i+ return $! o++new ::+ (MArray (A s) a (ST s)) =>+ Int -> ST s (Arr s a)+new n = unsafeNewArray_ (0, n - 1)++newI :: Int -> ST s (Arr s Int)+newI = new++-- newD :: Int -> ST s (Arr s Double)+-- newD = new++-- dump :: (MArray (A s) a (ST s)) => Arr s a -> ST s [a]+-- dump a = do+-- (m,n) <- getBounds a+-- forM [m..n] (\i -> a!:i)++writes ::+ (MArray (A s) a (ST s)) =>+ Arr s a -> [(Int, a)] -> ST s ()+writes a xs = forM_ xs (\(i, x) -> (a .= x) i)++-- arr :: (MArray (A s) a (ST s)) => [a] -> ST s (Arr s a)+-- arr xs = do+-- let n = length xs+-- a <- new n+-- go a n 0 xs+-- return a+-- where go _ _ _ [] = return ()+-- go a n i (x:xs)+-- | i <= n = (a.=x) i >> go a n (i+1) xs+-- | otherwise = return ()++-----------------------------------------------------------------------------++(!) :: (Monoid a) => IntMap a -> Int -> a+(!) g n = fromMaybe mempty (IM.lookup n g)++fromAdj :: [(Node, [Node])] -> Graph+fromAdj = IM.fromList . fmap (second IS.fromList)++fromEdges :: [Edge] -> Graph+fromEdges = collectI IS.union fst (IS.singleton . snd)++toAdj :: Graph -> [(Node, [Node])]+toAdj = fmap (second IS.toList) . IM.toList++toEdges :: Graph -> [Edge]+toEdges = concatMap (uncurry (fmap . (,))) . toAdj++predG :: Graph -> Graph+predG g = IM.unionWith IS.union (go g) g0+ where+ g0 = fmap (const mempty) g+ go =+ IM.foldrWithKey+ ( \i a m ->+ foldl'+ ( \m p ->+ IM.insertWith+ mappend+ p+ (IS.singleton i)+ m+ )+ m+ (IS.toList a)+ )+ mempty++-- predG :: Graph -> Graph+-- predG g = IM.unionWith IS.union (go g) g0+-- where g0 = fmap (const mempty) g+-- f :: IntMap IntSet -> Int -> IntSet -> IntMap IntSet+-- f m i a = foldl' (\m p -> IM.insertWith mappend p+-- (IS.singleton i) m)+-- m+-- (IS.toList a)+-- go :: IntMap IntSet -> IntMap IntSet+-- go = flip IM.foldlWithKey' mempty f++pruneReach :: Rooted -> Rooted+pruneReach (r, g) = (r, g2)+ where+ is =+ reachable+ ( fromMaybe mempty+ . flip IM.lookup g+ )+ r+ g2 =+ IM.map (IS.filter (`IS.member` is))+ . IM.filterWithKey (\node _targets -> IS.member node is)+ $ g++tip :: Tree a -> (a, [Tree a])+tip (Node a ts) = (a, ts)++parents :: Tree a -> [(a, a)]+parents (Node i xs) =+ p i xs+ ++ concatMap parents xs+ where+ p i = fmap ((,i) . rootLabel)++ancestors :: Tree a -> [(a, [a])]+ancestors = go []+ where+ go acc (Node i xs) =+ let acc' = i : acc+ in p acc' xs ++ concatMap (go acc') xs+ p is = fmap ((,is) . rootLabel)++asGraph :: Tree Node -> Rooted+asGraph t@(Node a _) = let g = go t in (a, fromAdj g)+ where+ go (Node a ts) =+ let as = (map fst . fmap tip) ts+ in (a, as) : concatMap go ts++asTree :: Rooted -> Tree Node+asTree (r, g) =+ let go a = Node a (fmap go ((IS.toList . f) a))+ f = (g !)+ in go r++reachable :: (Node -> NodeSet) -> (Node -> NodeSet)+reachable f a = go (IS.singleton a) a+ where+ go seen a =+ let s = f a+ as = IS.toList (s `IS.difference` seen)+ in foldl' go (s `IS.union` seen) as++collectI ::+ (c -> c -> c) ->+ (a -> Int) ->+ (a -> c) ->+ [a] ->+ IntMap c+collectI (<>) f g =+ foldl'+ ( \m a ->+ IM.insertWith+ (<>)+ (f a)+ (g a)+ m+ )+ mempty++-- collect :: (Ord b) => (c -> c -> c)+-- -> (a -> b) -> (a -> c) -> [a] -> Map b c+-- collect (<>) f g+-- = foldl' (\m a -> SM.insertWith (<>)+-- (f a)+-- (g a) m) mempty++-- | renum n g: Rename all nodes+--+-- Gives nodes sequential names starting at n.+-- Returns the new graph and a mapping.+-- (renamed, old -> new)+renum :: Int -> Graph -> (Graph, NodeMap Node)+renum from =+ (\(_, m, g) -> (g, m))+ . IM.foldrWithKey+ ( \i ss (!n, !env, !new) ->+ let (j, n2, env2) = go n env i+ (n3, env3, ss2) =+ IS.fold+ ( \k (!n, !env, !new) ->+ case go n env k of+ (l, n2, env2) -> (n2, env2, l `IS.insert` new)+ )+ (n2, env2, mempty)+ ss+ new2 = IM.insertWith IS.union j ss2 new+ in (n3, env3, new2)+ )+ (from, mempty, mempty)+ where+ go ::+ Int ->+ NodeMap Node ->+ Node ->+ (Node, Int, NodeMap Node)+ go !n !env i =+ case IM.lookup i env of+ Just j -> (j, n, env)+ Nothing -> (n, n + 1, IM.insert i n env)++-----------------------------------------------------------------------------++-- Nothing better than reinvinting the state monad.+newtype S z s a = S {unS :: forall o. (a -> s -> ST z o) -> s -> ST z o}++instance Functor (S z s) where+ fmap f (S g) = S (\k -> g (k . f))++instance Monad (S z s) where+ return = pure+ S g >>= f = S (\k -> g (\a -> unS (f a) k))++instance Applicative (S z s) where+ pure a = S (\k -> k a)+ (<*>) = ap++-- get :: S z s s+-- get = S (\k s -> k s s)+gets :: (s -> a) -> S z s a+gets f = S (\k s -> k (f s) s)++-- set :: s -> S z s ()+-- set s = S (\k _ -> k () s)+modify :: (s -> s) -> S z s ()+modify f = S (\k -> k () . f)++-- runS :: S z s a -> s -> ST z (a, s)+-- runS (S g) = g (\a s -> return (a,s))+evalS :: S z s a -> s -> ST z a+evalS (S g) = g ((return .) . const)++-- execS :: S z s a -> s -> ST z s+-- execS (S g) = g ((return .) . flip const)+st :: ST z a -> S z s a+st m =+ S+ ( \k s -> do+ a <- m+ k a s+ )++store ::+ (MArray (A z) a (ST z)) =>+ (s -> Arr z a) -> Int -> a -> S z s ()+store f i x = do+ a <- gets f+ st ((a .= x) i)++fetch ::+ (MArray (A z) a (ST z)) =>+ (s -> Arr z a) -> Int -> S z s a+fetch f i = do+ a <- gets f+ st (a !: i)++-- Redefine Data.Bifunctor.second for GHC 7 compatibility+second :: (b -> c) -> (a, b) -> (a, c)+second f (a, b) = (a, f b)
+ src/Language/QBE/Simulator.hs view
@@ -0,0 +1,349 @@+-- SPDX-FileCopyrightText: 2025-2026 Sören Tempel <soeren+git@soeren-tempel.net>+--+-- SPDX-License-Identifier: GPL-3.0-only++-- | This module describes the semantics of the [QBE](https://c9x.me/compile/)+-- intermediate representation using an abstract 'Simulator' monad.+-- Specifically, it abstractly describes the semantics of QBE's control-flow+-- constructs (such as functions, statements, and blocks) and instructions+-- using the primitives of this monad. The semantics can then be concretely+-- instantiated (refer to the instance of the 'Simulator' monad). This idea+-- is inspired by the paper [Flexible Instruction-Set Semantics via Abstract Monads]+-- (https://dl.acm.org/doi/10.1145/3607833).+module Language.QBE.Simulator+ ( BlockResult,+ execInstr,+ execStmt,+ execBlock,+ execFunc,+ )+where++import Control.Monad (unless, void, when)+import Control.Monad.Error.Class (throwError)+import Data.Functor ((<&>))+import Data.List (elemIndex, uncons)+import Data.Map qualified as Map+import Data.Maybe (fromMaybe, isJust, isNothing)+import Data.Word (Word8)+import Language.QBE.Simulator.Default.Expression qualified as DE+import Language.QBE.Simulator.Default.State+import Language.QBE.Simulator.Error+import Language.QBE.Simulator.Expression qualified as E+import Language.QBE.Simulator.Memory (addrOverlap)+import Language.QBE.Simulator.State+import Language.QBE.Types qualified as QBE++-- | Execution of a 'QBE.Block' can either return (with an optional return+-- value) or it can jump to another 'QBE.Block' which will then be executed.+type BlockResult v = (Either (Maybe v) QBE.Block)++------------------------------------------------------------------------++execVolatile :: (Simulator m v) => QBE.VolatileInstr -> m ()+execVolatile (QBE.Store valTy valReg addrReg) = do+ -- Since byte and half are not first-class types in the IL, they are+ -- stored as words and have to be looked up as such.+ val <- case valTy of+ QBE.Byte -> lookupValue QBE.Word valReg+ QBE.HalfWord -> lookupValue QBE.Word valReg+ (QBE.Base bt) -> lookupValue bt valReg++ addr <- lookupValue QBE.Long addrReg >>= toAddress+ writeMemory addr valTy val+execVolatile (QBE.Blit src dst toCopy) = do+ srcAddrVal <- lookupValue QBE.Long src+ dstAddrVal <- lookupValue QBE.Long dst++ -- TODO: Check for invalid BLITs+ srcAddr <- toAddress srcAddrVal+ dstAddr <- toAddress dstAddrVal+ when (srcAddr /= dstAddr && addrOverlap srcAddr dstAddr toCopy) $+ throwError $+ OverlappingBlit srcAddr dstAddr++ -- Somehow allow specialization of memory copies, e.g. for qute-symex.+ when (toCopy > 0) $+ mapM_+ ( \off -> do+ srcByte <- readMemory (QBE.LSubWord QBE.UnsignedByte) (srcAddr + off)+ writeMemory (dstAddr + off) QBE.Byte srcByte+ )+ [0 .. toCopy - 1]+execVolatile (QBE.VAStart val) = do+ ptr <- lookupValue QBE.Long val >>= toAddress+ stk <- activeFrame++ addrs <- mapM (\v -> (v,) <$> stackSpill v) (stkVarArgs stk)+ case uncons addrs of+ Just ((firstValue, firstAddr), _) -> do+ let valType = E.getType firstValue+ valSize = fromIntegral $ QBE.extTypeByteSize valType++ -- Initially, the pointer stored in our representation of the “variable+ -- argument list” points one element beyond the argument list. This+ -- allows us to determine the element pointer in `vaarg` by always+ -- substracting the size of the requested element from the pointer.+ writeMemory ptr (QBE.Base QBE.Long) $+ E.fromLit (QBE.Base QBE.Long) (firstAddr + valSize)+ Nothing -> pure ()+execVolatile (QBE.DBGLoc {}) = pure ()+{-# INLINEABLE execVolatile #-}++execBinaryTy ::+ (Simulator m v) =>+ QBE.BaseType ->+ (v -> v -> Maybe v) ->+ (QBE.BaseType, QBE.Value) ->+ (QBE.BaseType, QBE.Value) ->+ m v+execBinaryTy retTy op (lty, lhs) (rty, rhs) = do+ v1 <- lookupValue lty lhs+ v2 <- lookupValue rty rhs+ runBinary retTy op v1 v2++execBinary ::+ (Simulator m v) =>+ QBE.BaseType ->+ (v -> v -> Maybe v) ->+ QBE.Value ->+ QBE.Value ->+ m v+execBinary retTy op lhs rhs =+ execBinaryTy retTy op (retTy, lhs) (retTy, rhs)+{-# INLINE execBinary #-}++execShift ::+ (Simulator m v) =>+ QBE.BaseType ->+ (v -> v -> Maybe v) ->+ QBE.Value ->+ QBE.Value ->+ m v+execShift retTy op lhs amount =+ execBinaryTy retTy op (retTy, lhs) (QBE.Word, amount)+{-# INLINE execShift #-}++-- | Execute a single 'QBE.Instr'. The 'QBE.BaseType' denotes the return value type.+-- For example, as provided in the enclosing 'QBE.Assign'.+execInstr :: (Simulator m v) => QBE.BaseType -> QBE.Instr -> m v+execInstr retTy (QBE.Neg op) = do+ v <- lookupValue retTy op+ liftMaybe TypingError (E.neg v)+execInstr retTy (QBE.Add lhs rhs) = execBinary retTy E.add lhs rhs+execInstr retTy (QBE.Sub lhs rhs) = execBinary retTy E.sub lhs rhs+execInstr retTy (QBE.Mul lhs rhs) = execBinary retTy E.mul lhs rhs+execInstr retTy (QBE.Div lhs rhs) = execBinary retTy E.div lhs rhs+execInstr retTy (QBE.Or lhs rhs) = execBinary retTy E.or lhs rhs+execInstr retTy (QBE.Xor lhs rhs) = execBinary retTy E.xor lhs rhs+execInstr retTy (QBE.And lhs rhs) = execBinary retTy E.and lhs rhs+execInstr retTy (QBE.URem lhs rhs) = execBinary retTy E.urem lhs rhs+execInstr retTy (QBE.Rem lhs rhs) = execBinary retTy E.srem lhs rhs+execInstr retTy (QBE.UDiv lhs rhs) = execBinary retTy E.udiv lhs rhs+execInstr retTy (QBE.Sar lhs rhs) = execShift retTy E.sar lhs rhs+execInstr retTy (QBE.Shr lhs rhs) = execShift retTy E.shr lhs rhs+execInstr retTy (QBE.Shl lhs rhs) = execShift retTy E.shl lhs rhs+execInstr retTy (QBE.Load ty addrVal) = do+ addr <- lookupValue QBE.Long addrVal >>= toAddress+ val <- readMemory ty addr+ subType retTy val+execInstr QBE.Long (QBE.Alloc align sizeValue) = do+ size <- lookupValue QBE.Long sizeValue+ stackAlloc size (fromIntegral $ QBE.getSize align)+execInstr _ QBE.Alloc {} = throwError InvalidAddressType+execInstr retTy (QBE.CompareInt intArg cmpOp lhs rhs) = do+ let cmpTy = QBE.i2BaseType intArg+ v1 <- lookupValue cmpTy lhs+ v2 <- lookupValue cmpTy rhs++ let exprOp = E.compareIntExpr cmpOp+ runBinary retTy exprOp v1 v2+execInstr retTy (QBE.CompareFloat floatArg cmpOp lhs rhs) = do+ let cmpTy = QBE.f2BaseType floatArg+ v1 <- lookupValue cmpTy lhs+ v2 <- lookupValue cmpTy rhs++ let exprOp = E.compareFloatExpr cmpOp+ runBinary retTy exprOp v1 v2+-- exts is only valid with a double return type.+execInstr QBE.Double (QBE.Ext QBE.ExtSingle value) = do+ v <- lookupValue QBE.Single value+ liftMaybe TypingError $ E.extendFloat v+execInstr retTy (QBE.Ext extArg value) = do+ v <- lookupValue QBE.Word value+ let (isSigned, extTy) = QBE.toExtType extArg+ liftMaybe+ TypingError+ (E.extract extTy v >>= E.extend (QBE.Base retTy) isSigned)+execInstr QBE.Single (QBE.TruncDouble value) = do+ v <- lookupValue QBE.Double value+ liftMaybe TypingError $ E.truncFloat v+-- truncd is only valid with a single return type.+execInstr _ (QBE.TruncDouble _) = throwError TypingError+execInstr retTy (QBE.Copy value) = lookupValue retTy value+execInstr retTy (QBE.FloatToInt floatArg isSigned value) = do+ v <- lookupValue (QBE.f2BaseType floatArg) value+ liftMaybe TypingError $ E.floatToInt (QBE.Base retTy) isSigned v+execInstr retTy (QBE.IntToFloat intArg isSigned value) = do+ v <- lookupValue (QBE.i2BaseType intArg) value+ liftMaybe TypingError $ E.intToFloat (QBE.Base retTy) isSigned v+execInstr retTy (QBE.Cast value) = do+ -- We must deduce the value type to use for lookup from+ -- the return type as manadated by the cast type string.+ let valueType =+ case retTy of+ QBE.Word -> QBE.Single+ QBE.Long -> QBE.Double+ QBE.Single -> QBE.Word+ QBE.Double -> QBE.Long++ -- TODO: Consider adding an explicit operation for casting+ -- of floating points to the expression language abstraction.+ v <- lookupValue valueType value+ pure (E.fromLit (QBE.Base retTy) $ E.toWord64 v)+execInstr retTy (QBE.VAArg argLst) = do+ -- 'argsCtx' represents the “variable argument list”. Currently,+ -- it is not modeled after a specific ABI but simply contains a+ -- pointer to the previous argument. This pointer is updated by+ -- each invocation of the `vaarg` instruction.+ argsCtx <- lookupValue QBE.Long argLst >>= toAddress++ prevPtr <- readMemory (QBE.LBase QBE.Long) argsCtx+ let retTySize =+ E.fromLit+ (QBE.Base QBE.Long)+ (fromIntegral $ QBE.baseTypeByteSize retTy)++ -- Obtain current pointer by subtracting size from 'prevPtr'+ -- and align the pointer down to the nearest aligned address.+ ptrAligned <-+ liftMaybe InvalidAddressType $+ (prevPtr `E.sub` retTySize) >>= (`stackAlign` retTySize)++ val <- toAddress ptrAligned >>= readMemory (QBE.LBase retTy)+ writeMemory argsCtx (QBE.Base QBE.Long) ptrAligned+ pure val+{-# INLINEABLE execInstr #-}++-- | Execute a 'QBE.Statement', usually a sequence of 'QBE.Instruction'.+-- Therefore, this function iteratively calls 'execInstr' in the common case.+execStmt :: (Simulator m v) => QBE.Statement -> m ()+execStmt (QBE.Assign name ty inst) = do+ newVal <- execInstr ty inst+ modifyFrame (storeLocal name newVal)+execStmt (QBE.Volatile v) = execVolatile v+execStmt (QBE.Call ret toCall params) = do+ function <- lookupFunc toCall+ funcArgs <- lookupArgs params+ -- Sanity chekcs on funcArgs are performed by execFunc.++ mayRetVal <- case function of+ SFuncDef funcDef -> execFunc funcDef funcArgs+ SSimFunc simFunc -> simFunc funcArgs++ case mayRetVal of+ Nothing ->+ -- XXX: Could also check funcDef for the return value.+ if isNothing ret+ then pure ()+ else throwError FunctionReturnIgnored+ Just retVal ->+ case ret of+ Nothing -> throwError AssignedVoidReturnValue+ Just (ident, abity) -> do+ let baseTy = QBE.abityToBase abity+ subTyped <- subType baseTy retVal+ modifyFrame (storeLocal ident subTyped)+{-# INLINEABLE execStmt #-}++execJump :: (Simulator m v) => QBE.JumpInstr -> m (BlockResult v)+execJump QBE.Halt = throwError EncounteredHalt+execJump (QBE.Jump ident) = do+ blocks <- QBE.fBlock <$> (activeFrame <&> stkFunc)+ case Map.lookup ident blocks of+ Just bl -> pure $ Right bl+ Nothing -> throwError (UnknownBlock ident)+execJump (QBE.Jnz cond ifT ifF) = do+ condValue <- lookupValue QBE.Word cond+ condResult <- isTrue condValue+ execJump $ QBE.Jump (if condResult then ifT else ifF)+execJump (QBE.Return v) = do+ func <- activeFrame <&> stkFunc+ case QBE.fAbity func of+ Just abity -> do+ retVal <-+ case v of+ Nothing -> throwError InvalidReturnValue+ Just x -> pure x+ lookupValue (QBE.abityToBase abity) retVal <&> (Left . Just)+ Nothing ->+ if isNothing v+ then pure (Left Nothing)+ else throwError InvalidReturnValue+{-# INLINEABLE execJump #-}++execPhi :: (Simulator m v) => Maybe QBE.BlockIdent -> QBE.Phi -> m ()+execPhi Nothing _ = throwError InvalidPhiPosition+execPhi (Just prevIdent) (QBE.Phi name ty labels) =+ case Map.lookup prevIdent labels of+ Nothing -> throwError (UnknownBlock prevIdent)+ Just v -> do+ retVal <- lookupValue ty v+ modifyFrame (storeLocal name retVal)+{-# INLINEABLE execPhi #-}++-- | Execute a BasicBlock, as represented by 'QBE.Block', by iteratively+-- invoking 'execStmt'. If this isn't the first executed BasicBlock within a a+-- 'QBE.Function', then the 'QBE.BlockIdent' of the previously executed+-- BasicBlock should be provided. This is required to properly execute [phi+-- instructions](https://c9x.me/compile/doc/il-v1.2.html#Phi).+execBlock :: (Simulator m v) => Maybe QBE.BlockIdent -> QBE.Block -> m (BlockResult v)+execBlock prevIdent block = do+ mapM_ (execPhi prevIdent) (QBE.phi block)+ mapM_ execStmt (QBE.stmt block)+ execJump (QBE.term block)+{-# INLINEABLE execBlock #-}++execTilRet :: (Simulator m v) => Maybe QBE.BlockIdent -> QBE.Block -> m (BlockResult v)+execTilRet prevIdent block = go prevIdent (Right block)+ where+ go _ retValue@(Left _) = pure retValue+ go prevIdent' (Right nextBlock) =+ execBlock prevIdent' nextBlock >>= go (Just $ QBE.label nextBlock)+{-# INLINEABLE execTilRet #-}++-- | Execute a 'QBE.FuncDef' until function return. If the function requires arguments to+-- be passed to it, these must be provided as a list. Limited sanity checking is performed+-- to ensure that the provided arguments match the declared function parameters. The return+-- value of 'execFunc' is the return value of the executed 'QBE.FuncDef'. If the function+-- has no return value, 'Nothing' is returned here.+execFunc :: (Simulator m v) => QBE.FuncDef -> [v] -> m (Maybe v)+execFunc func@(QBE.FuncDef {QBE.fParams = params}) args = do+ -- Assumption: Variadic argument has been filtered from args (see lookupArgs).+ let varIdxMay = elemIndex QBE.Variadic params+ numNamed = fromMaybe (length args) varIdxMay+ argsSane =+ if isJust varIdxMay+ then length args + 1 >= length params -- +1 for filtered '...'+ else length params == length args+ unless argsSane $+ throwError (FuncArgsMismatch $ QBE.fName func)++ -- Separate name and unnamed variadic arguments using 'numNamed'+ -- and create a 'StackFrame' for 'func' that captures both.+ let vars =+ Map.fromList $+ zip (map paramName $ take numNamed params) args+ void $ newStackFrame func vars (drop numNamed args)++ blockResult <- execTilRet Nothing (QBE.fEntry func) <* returnFromFunc+ case blockResult of+ Right _block -> throwError MissingFunctionReturn+ Left maybeValue -> pure maybeValue+ where+ paramName :: QBE.FuncParam -> QBE.LocalIdent+ paramName (QBE.Regular _ n) = n+ paramName (QBE.Env n) = n+ paramName QBE.Variadic = error "unreachable"+{-# SPECIALIZE execFunc :: QBE.FuncDef -> [DE.RegVal] -> SimState DE.RegVal Word8 (Maybe DE.RegVal) #-}+{-# INLINEABLE execFunc #-}
+ src/Language/QBE/Simulator/Default/Expression.hs view
@@ -0,0 +1,372 @@+-- SPDX-FileCopyrightText: 2025 Sören Tempel <soeren+git@soeren-tempel.net>+--+-- SPDX-License-Identifier: GPL-3.0-only+{-# LANGUAGE TemplateHaskell #-}+-- The code generated by template-haskell does not have type signatures.+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++-- | This module provides an implementation of the expression abstract from+-- 'Language.QBE.Simulator.Expression' which uses concrete fixed-width integer+-- values from "Data.Word" internally.+module Language.QBE.Simulator.Default.Expression+ ( RegVal (..),+ bitSize,+ fromBits,+ )+where++import Control.Exception (assert)+import Data.Bits+ ( FiniteBits,+ finiteBitSize,+ shift,+ shiftR,+ unsafeShiftL,+ unsafeShiftR,+ xor,+ (.&.),+ (.|.),+ )+import Data.Int (Int16, Int32, Int64, Int8)+import Data.Word (Word16, Word32, Word64, Word8)+import GHC.Float+ ( castDoubleToWord64,+ castFloatToWord32,+ castWord32ToFloat,+ castWord64ToDouble,+ double2Float,+ float2Double,+ )+import Language.QBE.Simulator.Default.Generator (generateOperators)+import Language.QBE.Simulator.Expression qualified as E+import Language.QBE.Simulator.Memory qualified as MEM+import Language.QBE.Types qualified as QBE++-- TODO: Can we just wrap base type here?+-- TODO: Do not export the constructors+data RegVal+ = VByte Word8+ | VHalf Word16+ | VWord Word32+ | VLong Word64+ | VSingle Float+ | VDouble Double+ deriving (Show, Eq)++-- | Size of the value in bits.+bitSize :: RegVal -> Int+bitSize (VByte _) = 8+bitSize (VHalf _) = 16+bitSize (VWord _) = 32+bitSize (VLong _) = 64+bitSize (VSingle _) = 32+bitSize (VDouble _) = 64++-- | Create a a 'RegVal' from an 'Integer' inferring the type from a given+-- amount of bits instead of requiring the user to provide a 'QBE.ExtType',+-- as required by 'Language.QBE.Simulator.Expression.fromLit'.+fromBits :: Int -> Integer -> Maybe RegVal+fromBits 08 = Just . VHalf . fromIntegral+fromBits 16 = Just . VHalf . fromIntegral+fromBits 32 = Just . VWord . fromIntegral+fromBits 64 = Just . VLong . fromIntegral+fromBits _ = const Nothing++fromBool :: Bool -> RegVal+fromBool True = VLong 1+fromBool False = VLong 0++------------------------------------------------------------------------++shiftInstr ::+ (RegVal -> Word32 -> Maybe RegVal) ->+ RegVal ->+ RegVal ->+ Maybe RegVal+shiftInstr shiftOp val (VWord amount) = val `shiftOp` amount+shiftInstr _ _ _ = Nothing++toShiftAmount :: Word32 -> Word32 -> Int+toShiftAmount valBitSize amount =+ -- From the QBE specification: "The shifting amount+ -- is taken modulo the size of the result type."+ let s = fromIntegral $ amount `mod` valBitSize+ in assert (s > 0) s++shiftSar :: RegVal -> Word32 -> Maybe RegVal+shiftSar (VWord val) amount =+ (Just . VWord . fromIntegral) $+ (fromIntegral val :: Int32) `unsafeShiftR` toShiftAmount 32 amount+shiftSar (VLong val) amount =+ (Just . VLong . fromIntegral) $+ (fromIntegral val :: Int64) `unsafeShiftR` toShiftAmount 64 amount+shiftSar _ _ = Nothing++shiftShr :: RegVal -> Word32 -> Maybe RegVal+shiftShr (VWord val) amount =+ (Just . VWord) $ val `unsafeShiftR` toShiftAmount 32 amount+shiftShr (VLong val) amount =+ (Just . VLong) $ val `unsafeShiftR` toShiftAmount 64 amount+shiftShr _ _ = Nothing++shiftShl :: RegVal -> Word32 -> Maybe RegVal+shiftShl (VWord val) amount =+ (Just . VWord) $ val `unsafeShiftL` toShiftAmount 32 amount+shiftShl (VLong val) amount =+ (Just . VLong) $ val `unsafeShiftL` toShiftAmount 64 amount+shiftShl _ _ = Nothing++------------------------------------------------------------------------++regToBytes :: RegVal -> [Word8]+regToBytes val =+ let f w =+ map+ (\off -> fromIntegral $ shiftR w off .&. 0xff)+ (take (bytesize w) $ iterate (+ 8) 0)+ in case val of+ (VByte v) -> [v]+ (VWord v) -> f v+ (VHalf v) -> f v+ (VLong v) -> f v+ (VSingle v) -> MEM.toBytes (VWord $ castFloatToWord32 v)+ (VDouble v) -> MEM.toBytes (VLong $ castDoubleToWord64 v)+ where+ bytesize :: (FiniteBits a) => a -> Int+ bytesize v = finiteBitSize v `div` 8++regFromBytes :: QBE.LoadType -> [Word8] -> Maybe RegVal+regFromBytes ty lst =+ let f a =+ foldl+ (\acc (byte, idx) -> (fromIntegral byte `shift` (idx * 8)) .|. acc)+ 0+ $ zip a [0 ..]+ in case (ty, lst) of+ (QBE.LSubWord QBE.UnsignedByte, [byte]) -> Just (VWord (fromIntegral byte))+ (QBE.LSubWord QBE.SignedByte, [byte]) -> Just (VWord $ fromIntegral (fromIntegral byte :: Int8))+ (QBE.LSubWord QBE.SignedHalf, bytes@[_, _]) -> Just (VWord $ fromIntegral (f bytes :: Int16))+ (QBE.LSubWord QBE.UnsignedHalf, bytes@[_, _]) -> Just (VWord $ fromIntegral (f bytes :: Word16))+ (QBE.LBase QBE.Word, bytes@[_, _, _, _]) -> Just (VWord $ f bytes)+ (QBE.LBase QBE.Long, bytes@[_, _, _, _, _, _, _, _]) -> Just (VLong $ f bytes)+ (QBE.LBase QBE.Single, bytes@[_, _, _, _]) ->+ Just (VSingle $ castWord32ToFloat (f bytes))+ (QBE.LBase QBE.Double, bytes@[_, _, _, _, _, _, _, _]) ->+ Just (VDouble $ castWord64ToDouble (f bytes))+ _ -> Nothing++instance MEM.Storable RegVal Word8 where+ toBytes = regToBytes+ fromBytes = regFromBytes++------------------------------------------------------------------------++-- TODO: Insert the generated code directly into the instance declaration.+generateOperators++maxValue :: RegVal -> Maybe RegVal+maxValue val =+ let bitSiz = bitSize val+ maxVal = (2 ^ bitSiz) - 1+ in fromBits bitSiz maxVal++withZeroDiv ::+ Maybe RegVal ->+ (RegVal -> RegVal -> Maybe RegVal) ->+ RegVal ->+ RegVal ->+ Maybe RegVal+withZeroDiv defVal op lhs rhs+ | E.toWord64 rhs == 0 = defVal+ | otherwise = op lhs rhs++-- Signed division overflow occurs when the most-negative integer is divided by -1.+withSDivOverflow ::+ Maybe RegVal ->+ (RegVal -> RegVal -> Maybe RegVal) ->+ RegVal ->+ RegVal ->+ Maybe RegVal+withSDivOverflow defVal op lhs rhs+ | E.toWord64 lhs == mostNeg && E.toWord64 rhs == minusOne = defVal+ | otherwise = op lhs rhs+ where+ numBits :: Int+ numBits =+ assert (bitSize lhs == bitSize rhs) $+ bitSize lhs++ minusOne :: Word64+ minusOne = (2 ^ numBits) - 1++ mostNeg :: Word64+ mostNeg = 2 ^ (numBits - 1)++-- We could also add support for unary operators to the generator. However,+-- presently there is only one unary operator so it isn't worth it.+neg' :: RegVal -> Maybe RegVal+neg' (VWord v) = Just . VWord $ negate v+neg' (VLong v) = Just . VLong $ negate v+neg' (VSingle v) = Just . VSingle $ negate v+neg' (VDouble v) = Just . VDouble $ negate v+neg' _ = Nothing++-- This can't be easily auto generated because the operation differs+-- based on the type.+div' :: RegVal -> RegVal -> Maybe RegVal+div' (VWord lhs) (VWord rhs) =+ (Just . VWord . fromIntegral) $+ (fromIntegral lhs :: Int32) `quot` (fromIntegral rhs :: Int32)+div' (VLong lhs) (VLong rhs) =+ (Just . VLong . fromIntegral) $+ (fromIntegral lhs :: Int64) `quot` (fromIntegral rhs :: Int64)+div' (VSingle lhs) (VSingle rhs) = (Just . VSingle) $ lhs / rhs+div' (VDouble lhs) (VDouble rhs) = (Just . VDouble) $ lhs / rhs+div' _ _ = Nothing++instance E.ValueRepr RegVal where+ fromLit QBE.Byte n = VByte $ fromIntegral n+ fromLit QBE.HalfWord n = VHalf $ fromIntegral n+ fromLit (QBE.Base QBE.Long) n = VLong n+ fromLit (QBE.Base QBE.Word) n = VWord $ fromIntegral n+ fromLit (QBE.Base QBE.Single) n = VSingle $ castWord32ToFloat (fromIntegral n)+ fromLit (QBE.Base QBE.Double) n = VDouble $ castWord64ToDouble n++ toWord64 (VByte v) = fromIntegral v+ toWord64 (VHalf v) = fromIntegral v+ toWord64 (VWord v) = fromIntegral v+ toWord64 (VLong v) = v+ toWord64 (VSingle v) = fromIntegral $ castFloatToWord32 v+ toWord64 (VDouble v) = castDoubleToWord64 v++ fromFloat = VSingle+ fromDouble = VDouble++ -- stosi+ floatToInt ty@(QBE.Base QBE.Word) True (VSingle v) =+ Just $ E.fromLit ty (fromIntegral (truncate v :: Int32))+ floatToInt ty@(QBE.Base QBE.Long) True (VSingle v) =+ Just $ E.fromLit ty (fromIntegral (truncate v :: Int64))+ -- stoui+ floatToInt ty@(QBE.Base QBE.Word) False (VSingle v) =+ Just $ E.fromLit ty (fromIntegral (truncate v :: Word32))+ floatToInt ty@(QBE.Base QBE.Long) False (VSingle v) =+ Just $ E.fromLit ty (truncate v :: Word64)+ -- dtosi+ floatToInt ty@(QBE.Base QBE.Word) True (VDouble v) =+ Just $ E.fromLit ty (fromIntegral (truncate v :: Int32))+ floatToInt ty@(QBE.Base QBE.Long) True (VDouble v) =+ Just $ E.fromLit ty (fromIntegral (truncate v :: Int64))+ -- dtoui+ floatToInt ty@(QBE.Base QBE.Word) False (VDouble v) =+ Just $ E.fromLit ty (fromIntegral (truncate v :: Word32))+ floatToInt ty@(QBE.Base QBE.Long) False (VDouble v) =+ Just $ E.fromLit ty (truncate v :: Word64)+ -- rest+ floatToInt _ _ _ = Nothing++ -- swtof+ intToFloat ty@(QBE.Base QBE.Single) True (VWord v) =+ Just $ E.fromLit ty (fromIntegral (fromIntegral v :: Int32))+ intToFloat ty@(QBE.Base QBE.Double) True (VWord v) =+ Just $ E.fromLit ty (fromIntegral (fromIntegral v :: Int32))+ -- uwtof+ intToFloat ty@(QBE.Base QBE.Single) False (VWord v) =+ Just $ E.fromLit ty (fromIntegral (fromIntegral v :: Word32))+ intToFloat ty@(QBE.Base QBE.Double) False (VWord v) =+ Just $ E.fromLit ty (fromIntegral (fromIntegral v :: Word32))+ -- sltof+ intToFloat ty@(QBE.Base QBE.Single) True (VLong v) =+ Just $ E.fromLit ty (fromIntegral (fromIntegral v :: Int64))+ intToFloat ty@(QBE.Base QBE.Double) True (VLong v) =+ Just $ E.fromLit ty (fromIntegral (fromIntegral v :: Int64))+ -- ultof+ intToFloat ty@(QBE.Base QBE.Single) False (VLong v) =+ Just $ E.fromLit ty (fromIntegral (fromIntegral v :: Word64))+ intToFloat ty@(QBE.Base QBE.Double) False (VLong v) =+ Just $ E.fromLit ty (fromIntegral (fromIntegral v :: Word64))+ -- rest+ intToFloat _ _ _ = Nothing++ extendFloat (VSingle v) = Just $ VDouble (float2Double v)+ extendFloat _ = Nothing++ truncFloat (VDouble v) = Just $ VSingle (double2Float v)+ truncFloat _ = Nothing++ getType (VByte _) = QBE.Byte+ getType (VHalf _) = QBE.HalfWord+ getType (VWord _) = QBE.Base QBE.Word+ getType (VLong _) = QBE.Base QBE.Long+ getType (VSingle _) = QBE.Base QBE.Single+ getType (VDouble _) = QBE.Base QBE.Double++ -- TODO: Consider replacing Nothing cases with assert as this on the hot path.+ extend extTy isSigned val+ | QBE.extTypeBitSize extTy <= bitSize val = Nothing+ | otherwise =+ E.fromLit extTy+ <$> case (isSigned, val) of+ (True, VByte v) -> Just $ fromIntegral (fromIntegral v :: Int8)+ (True, VHalf v) -> Just $ fromIntegral (fromIntegral v :: Int16)+ (True, VWord v) -> Just $ fromIntegral (fromIntegral v :: Int32)+ (True, VLong v) -> Just $ fromIntegral (fromIntegral v :: Int64)+ (False, VByte v) -> Just $ fromIntegral (fromIntegral v :: Word8)+ (False, VHalf v) -> Just $ fromIntegral (fromIntegral v :: Word16)+ (False, VWord v) -> Just $ fromIntegral (fromIntegral v :: Word32)+ (False, VLong v) -> Just $ fromIntegral (fromIntegral v :: Word64)+ _ -> Nothing++ -- TODO: Consider replacing Nothing cases with assert as this on the hot path.+ extract (QBE.Base QBE.Single) _ = Nothing+ extract (QBE.Base QBE.Double) _ = Nothing+ extract _ (VSingle _) = Nothing+ extract _ (VDouble _) = Nothing+ extract extTy v+ | QBE.extTypeBitSize extTy > bitSize v = Nothing+ | otherwise =+ let word = E.toWord64 v+ mask = (2 `unsafeShiftL` (QBE.extTypeBitSize extTy - 1)) - 1+ in Just $ E.fromLit extTy (word .&. mask)++ -- This is needed to align the behavior of qute/ and qute-symex/ on+ -- division-by-zero. QBE does not explicitly mandate a specific behavior+ -- for this edge case. Therefore, in order to avoid extra branches in the+ -- symbolic executor, we use the behavior mandated by SMT-LIB here.+ --+ -- TODO: Move this into the Expression abstraction (just like overshift handling).+ div lhs = withZeroDiv (maxValue lhs) (withSDivOverflow (Just lhs) div') lhs+ udiv lhs = withZeroDiv (maxValue lhs) udiv' lhs+ urem lhs = withZeroDiv (Just lhs) urem' lhs+ srem lhs = withZeroDiv (Just lhs) (withSDivOverflow (fromBits (bitSize lhs) 0) srem') lhs++ add = add'+ sub = sub'+ mul = mul'+ or = or'+ xor = xor'+ and = and'++ neg = neg'++ sar = shiftInstr shiftSar+ shr = shiftInstr shiftShr+ shl = shiftInstr shiftShl++ -- TODO: Provide default implementations+ eq = eq'+ ne = ne'+ sle = sle'+ slt = slt'+ sge = sge'+ sgt = sgt'+ ule = ule'+ ult = ult'+ uge = uge'+ ugt = ugt'++ ord (VSingle lhs) (VSingle rhs) =+ Just . fromBool $ not (isNaN lhs || isNaN rhs)+ ord (VDouble lhs) (VDouble rhs) =+ Just . fromBool $ not (isNaN lhs || isNaN rhs)+ ord _ _ = Nothing
+ src/Language/QBE/Simulator/Default/Funcs.hs view
@@ -0,0 +1,29 @@+-- SPDX-FileCopyrightText: 2025 Sören Tempel <soeren+git@soeren-tempel.net>+--+-- SPDX-License-Identifier: GPL-3.0-only++module Language.QBE.Simulator.Default.Funcs (lookupSimFunc) where++import Control.Monad.Error.Class (throwError)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Language.QBE.Simulator.Error (EvalError (FuncArgsMismatch))+import Language.QBE.Simulator.Expression qualified as E+import Language.QBE.Simulator.State (Simulator, readNullArray, toAddress)+import Language.QBE.Types qualified as QBE++puts :: (MonadIO m, E.ValueRepr v, Simulator m v) => QBE.GlobalIdent -> [v] -> m (Maybe v)+puts _ [strPtr] = do+ bytes <- toAddress strPtr >>= readNullArray+ liftIO $ putStrLn (E.toString bytes)+ pure (Just $ E.fromLit (QBE.Base QBE.Word) 0)+puts ident _ = throwError $ FuncArgsMismatch ident++------------------------------------------------------------------------++-- TODO: Register functions dynamically.+lookupSimFunc ::+ (MonadIO m, E.ValueRepr v, Simulator m v) =>+ QBE.GlobalIdent ->+ Maybe ([v] -> m (Maybe v))+lookupSimFunc i@(QBE.GlobalIdent "puts") = Just (puts i)+lookupSimFunc _ = Nothing
+ src/Language/QBE/Simulator/Default/Generator.hs view
@@ -0,0 +1,141 @@+-- SPDX-FileCopyrightText: 2025 Sören Tempel <soeren+git@soeren-tempel.net>+--+-- SPDX-License-Identifier: GPL-3.0-only++module Language.QBE.Simulator.Default.Generator (generateOperators) where++import Language.Haskell.TH++data ValueCons+ = VWord+ | VLong+ | VSingle+ | VDouble+ deriving (Show)++toSigned :: ValueCons -> Maybe String+toSigned VWord = Just "Int32"+toSigned VLong = Just "Int64"+toSigned VSingle = Nothing+toSigned VDouble = Nothing++toSignedExp :: ValueCons -> Exp -> Exp+toSignedExp vCons expr =+ case toSigned vCons of+ Nothing -> expr+ Just st ->+ let cast = AppE (VarE $ mkName "fromIntegral") expr+ in SigE cast (ConT $ mkName st)++------------------------------------------------------------------------++thBinaryFunc :: Exp -> Exp -> Exp -> Exp+thBinaryFunc func lhs = AppE (AppE func lhs)++thBinaryOp :: Exp -> Exp -> Exp -> Exp+thBinaryOp op = thBinaryFunc (ParensE op)++------------------------------------------------------------------------++-- Takes an lhs and rhs value and transform it to some 'Exp'.+type Transformer = ValueCons -> Exp -> Exp -> Exp++applyFunc :: Exp -> ValueCons -> Exp -> Exp -> Exp+applyFunc func vCon lhs rhs =+ AppE (ConE $ mkName (show vCon)) (thBinaryFunc func lhs rhs)++applyOp :: Name -> ValueCons -> Exp -> Exp -> Exp+applyOp opName =+ applyFunc (ParensE (VarE opName))++applySignedOp :: Name -> ValueCons -> Exp -> Exp -> Exp+applySignedOp opName vCon lhs rhs =+ let lhs' = toSignedExp vCon lhs+ rhs' = toSignedExp vCon rhs+ cast = AppE (VarE $ mkName "fromIntegral")+ in -- TODO: Code duplication with applyFunc+ AppE (ConE $ mkName (show vCon)) (cast $ thBinaryFunc (VarE opName) lhs' rhs')++applyBoolOp :: Name -> ValueCons -> Exp -> Exp -> Exp+applyBoolOp opName _vCons lhs rhs =+ let res = thBinaryOp (VarE opName) lhs rhs+ toL = AppE (AppE (VarE $ mkName "E.fromLit") (AppE (ConE $ mkName "QBE.Base") (ConE $ mkName "QBE.Long")))+ in toL $ CondE res (LitE $ IntegerL 1) (LitE $ IntegerL 0)++applySignedBoolOp :: Name -> ValueCons -> Exp -> Exp -> Exp+applySignedBoolOp opName vCons lhs rhs =+ applyBoolOp opName vCons (toSignedExp vCons lhs) (toSignedExp vCons rhs)++------------------------------------------------------------------------++operators :: [(Name, Transformer)]+operators =+ [ (mkName "add'", applyOp (mkName "+")),+ (mkName "sub'", applyOp (mkName "-")),+ (mkName "mul'", applyOp (mkName "*")),+ (mkName "eq'", applyBoolOp (mkName "==")),+ (mkName "ne'", applyBoolOp (mkName "/=")),+ (mkName "sle'", applySignedBoolOp (mkName "<=")),+ (mkName "slt'", applySignedBoolOp (mkName "<")),+ (mkName "sge'", applySignedBoolOp (mkName ">=")),+ (mkName "sgt'", applySignedBoolOp (mkName ">")),+ (mkName "ule'", applyBoolOp (mkName "<=")),+ (mkName "ult'", applyBoolOp (mkName "<")),+ (mkName "uge'", applyBoolOp (mkName ">=")),+ (mkName "ugt'", applyBoolOp (mkName ">"))+ ]++decOperators :: [(Name, Transformer)]+decOperators =+ [ (mkName "srem'", applySignedOp (mkName "rem")),+ (mkName "urem'", applyOp (mkName "rem")),+ (mkName "udiv'", applyOp (mkName "quot")),+ (mkName "or'", applyOp (mkName ".|.")),+ (mkName "xor'", applyOp (mkName "Data.Bits.xor")),+ (mkName "and'", applyOp (mkName ".&."))+ ]++------------------------------------------------------------------------++decCons :: [ValueCons]+decCons = [VWord, VLong]++cons :: [ValueCons]+cons = decCons ++ [VSingle, VDouble]++makeClause :: Transformer -> ValueCons -> Q Clause+makeClause trans vCon = do+ lhs <- newName "lhs"+ rhs <- newName "rhs"++ let res = trans vCon (VarE lhs) (VarE rhs)+ let body = AppE (ConE (mkName "Just")) res++ let con = mkName (show vCon)+ return $+ Clause+ [ ConP con [] [VarP lhs],+ ConP con [] [VarP rhs]+ ]+ (NormalB body)+ []++typingErrorClause :: Clause+typingErrorClause =+ Clause+ [WildP, WildP]+ (NormalB (ConE $ mkName "Nothing"))+ []++------------------------------------------------------------------------++genOp :: [ValueCons] -> (Name, Transformer) -> Q Dec+genOp opLst (name, trans) = do+ valDefs <- mapM (makeClause trans) opLst+ return $ FunD name (valDefs ++ [typingErrorClause])++generateOperators :: Q [Dec]+generateOperators = do+ o1 <- mapM (genOp cons) operators+ o2 <- mapM (genOp decCons) decOperators+ pure $ o1 ++ o2
+ src/Language/QBE/Simulator/Default/State.hs view
@@ -0,0 +1,364 @@+-- 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+ { envSyms :: Map.Map QBE.GlobalIdent MEM.Address,+ envFuncs :: Map.Map QBE.GlobalIdent QBE.FuncDef,+ envFuncAddrs :: Map.Map MEM.Address QBE.GlobalIdent, -- TODO: IntMap?+ envMem :: MEM.Memory IOArray b,+ envStk :: [StackFrame v],+ envStkPtr :: v,+ envDataPtr :: MEM.Address+ }++allocText :: MEM.Address -> [QBE.FuncDef] -> Map.Map MEM.Address QBE.GlobalIdent+allocText _ [] = Map.empty+allocText addr (func : rest) =+ Map.insert addr (QBE.fName func) $+ allocText (addr + pointerSize) rest+ where+ pointerSize :: MEM.Size+ pointerSize = fromIntegral $ QBE.baseTypeByteSize QBE.Long++mkEnv ::+ (MEM.Storable v b, E.ValueRepr v) =>+ Program ->+ MEM.Address ->+ MEM.Size ->+ IO (Env v b)+mkEnv prog a 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.+ mem <- MEM.mkMemory a s+ let dataMem = allocData a (mapMaybe isData prog)+ fns = globalFuncs prog+ txt = allocText (fromIntegral $ a + s) fns+ 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.union (getFuncPtr txt) (toSyms dataMem),+ envFuncs = makeFuncs fns,+ envFuncAddrs = txt,+ envMem = mem,+ envStk = [],+ envStkPtr = E.fromLit (QBE.Base QBE.Long) $ a + s - 1,+ envDataPtr = a+ }+ execStateT (initData dataMem) env+ where+ makeFuncs :: [QBE.FuncDef] -> Map.Map QBE.GlobalIdent QBE.FuncDef+ makeFuncs = Map.fromList . map (\f -> (QBE.fName f, f))++ getFuncPtr ::+ Map.Map MEM.Address QBE.GlobalIdent ->+ Map.Map QBE.GlobalIdent MEM.Address+ getFuncPtr = Map.fromList . map swap . Map.toList++ toSyms :: DataMem -> Map.Map QBE.GlobalIdent MEM.Address+ toSyms = Map.fromList . map (\(k, v) -> (QBE.name v, k))++ isData :: Definition -> Maybe QBE.DataDef+ isData (DefData def) = Just def+ isData _ = Nothing++------------------------------------------------------------------------++-- TODO: Move this to Loader.hs++storeBytes ::+ (MEM.Storable v b) =>+ MEM.Address ->+ [b] ->+ StateT (Env v b) IO MEM.Address+storeBytes addr bytes = do+ mem <- gets envMem+ liftIO $ MEM.storeBytes mem addr bytes+ pure $ addr + fromIntegral (length bytes)+{-# INLINEABLE storeBytes #-}++storeValue ::+ (MEM.Storable v b) =>+ MEM.Address ->+ v ->+ StateT (Env v b) IO MEM.Address+storeValue addr = storeBytes addr . MEM.toBytes+{-# INLINE storeValue #-}++storeValues ::+ (MEM.Storable v b) =>+ MEM.Address ->+ [v] ->+ StateT (Env v b) IO MEM.Address+storeValues addr = storeBytes addr . concatMap 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 addr QBE.Byte (QBE.DString str) = do+ storeValues addr $ E.fromString str+loadItem addr ty (QBE.DSymOff ident off) = do+ globals <- gets envSyms+ case Map.lookup ident globals of+ Nothing -> liftIO $ throwIO (Err.UnknownVariable $ show ident)+ Just symAddr ->+ storeValue addr $ E.fromLit @v ty (symAddr + off)+loadItem addr ty (QBE.DConst (QBE.Global ident)) =+ loadItem addr ty (QBE.DSymOff ident 0)+loadItem addr ty (QBE.DConst (QBE.Number num)) =+ storeValue addr $ E.fromLit @v ty num+loadItem addr (QBE.Base QBE.Single) (QBE.DConst (QBE.SFP num)) = do+ storeValue addr $ E.fromFloat @v num+loadItem addr (QBE.Base QBE.Double) (QBE.DConst (QBE.DFP num)) = do+ storeValue addr $ E.fromDouble @v num+loadItem _ _ item = error $ "unsupported DataItem: " ++ show 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 addr (QBE.OZeroFill n) = do+ let zeroByte = E.fromLit @v QBE.Byte 0+ storeValues addr $ replicate (fromIntegral n) zeroByte+loadObj addr (QBE.OItem ty items) = do+ foldM (`loadItem` ty) addr items+{-# INLINEABLE loadObj #-}++loadData ::+ (MEM.Storable v b, E.ValueRepr v) =>+ MEM.Address ->+ QBE.DataDef ->+ StateT (Env v b) IO ()+loadData addr dataDef = do+ newAddr <- foldM loadObj addr $ QBE.objs dataDef++ -- The address calculations performed by 'loadObj' must be aligned+ -- with those performed by 'allocData' through 'QBE.dataSize'.+ assert (newAddr == addr + fromIntegral (QBE.dataSize dataDef)) $+ pure ()+{-# INLINEABLE loadData #-}++initData ::+ (MEM.Storable v b, E.ValueRepr v) =>+ DataMem ->+ StateT (Env v b) IO ()+initData = mapM_ (uncurry 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 (startAddr, memMap) =+ let addr =+ MEM.alignAddr startAddr $+ fromMaybe maxAlign (QBE.align dataDef)+ size = fromIntegral $ QBE.dataSize dataDef+ in (addr + size, (addr, dataDef) : memMap)+ where+ -- The alignment of an aggregate type is the maximum alignment the members.+ maxAlign = maximum $ map QBE.objAlign (QBE.objs dataDef)++allocData :: MEM.Address -> [QBE.DataDef] -> DataMem+allocData startAddr dataDefs =+ snd $ foldr allocDataDef (startAddr, []) 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 st handler = do+ StateT $ \s -> do+ let state = runStateT st s+ state `catch` (\e -> runStateT (handler e) s)+{-# INLINEABLE unliftCatch #-}++-- | Simulator state, parameterized over a value and byte representation.+newtype SimState v b a = SimState {unSimState :: StateT (Env v b) IO a}+ deriving (Functor, Applicative, Monad, 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 = liftIO . throwIO+ catchError (SimState st) handler =+ SimState $ unliftCatch st (unSimState . 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 mem addr ty = do+ let size = QBE.loadByteSize ty+ mayBytes <-+ liftIO $+ try (MEM.loadBytes mem addr size >>= evaluate . force)++ case mayBytes of+ Left (ErrorCall msg) -> throwError $ Err.MemoryError msg+ Right bytes -> pure bytes+{-# INLINE safeLoadBytes #-}++instance (MEM.Storable v b, E.ValueRepr v, NFData b) => Simulator (SimState v b) v where+ isTrue value = pure (E.toWord64 value /= 0)+ toAddress = pure . E.toWord64++ lookupSymbol ident = gets (Map.lookup ident . envSyms)++ findFunc ident = do+ funcs <- gets envFuncs+ pure $ case Map.lookup ident funcs of+ Just x -> Just $ SFuncDef x+ Nothing -> SSimFunc <$> lookupSimFunc ident+ findFuncByAddr addr = do+ fptrs <- gets envFuncAddrs+ case Map.lookup addr fptrs of+ Just fn -> findFunc fn+ Nothing -> pure Nothing++ activeFrame = do+ stk <- gets envStk+ case stk of+ (x : _) -> pure x+ [] -> throwError Err.EmptyStack+ pushStackFrame frame =+ modify (\s -> s {envStk = frame : envStk s})+ popStackFrame = do+ stk <- gets envStk+ case stk of+ (x : xs) -> modify (\s -> s {envStk = xs}) >> pure x+ [] -> throwError Err.EmptyStack++ getSP = gets envStkPtr+ setSP sp = modify (\s -> s {envStkPtr = sp})++ writeMemory addr extType val = do+ mem <- gets 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 = MEM.toBytes val+ liftIO $+ MEM.storeBytes mem addr $+ case extType of+ QBE.Byte -> take 1 bytes+ QBE.HalfWord -> take 2 bytes+ QBE.Base _ -> bytes+ readMemory ty addr = do+ mem <- gets envMem+ bytes <- safeLoadBytes mem addr ty++ case MEM.fromBytes ty bytes of+ Just x -> pure x+ Nothing -> throwError InvalidMemoryLoad++------------------------------------------------------------------------++run :: (E.ValueRepr v, MEM.Storable v b) => Env v b -> SimState v b a -> IO a+run env state = evalStateT (unSimState state) env+{-# SPECIALIZE run :: Env D.RegVal Word8 -> SimState D.RegVal Word8 a -> IO a #-}
+ src/Language/QBE/Simulator/Error.hs view
@@ -0,0 +1,53 @@+-- SPDX-FileCopyrightText: 2025 Sören Tempel <soeren+git@soeren-tempel.net>+--+-- SPDX-License-Identifier: GPL-3.0-only++module Language.QBE.Simulator.Error (EvalError (..)) where++import Control.Monad.Catch (Exception)+import Language.QBE.Simulator.Memory (Address, showAddr)+import Language.QBE.Types qualified as QBE++-- TODO: Differentiate different typing errors.+data EvalError+ = TypingError+ | UnknownVariable String+ | EmptyStack+ | EncounteredHalt+ | InvalidReturnValue+ | UnknownBlock QBE.BlockIdent+ | InvalidMemoryLoad+ | UnknownFunction QBE.GlobalIdent+ | UnknownFunctionAddr Address+ | MissingFunctionReturn+ | FunctionReturnIgnored+ | AssignedVoidReturnValue+ | InvaldSubWordExtension+ | InvalidAddressType+ | OverlappingBlit Address Address+ | FuncArgsMismatch QBE.GlobalIdent+ | InvalidPhiPosition+ | MemoryError String+ deriving (Eq)++instance Show EvalError where+ show TypingError = "TypingError"+ show (UnknownVariable s) = "UnknownVariable: '" ++ show s ++ "'"+ show EmptyStack = "EmptyStack"+ show EncounteredHalt = "EncounteredHalt"+ show InvalidReturnValue = "InvalidReturnValue"+ show (UnknownBlock block) = "UnknownBlock: '" ++ show block ++ "'"+ show InvalidMemoryLoad = "InvalidMemoryLoad"+ show (UnknownFunction ident) = "UnknownFunction: '" ++ show ident ++ "'"+ show (UnknownFunctionAddr addr) = "UnknownFunctionAddr: '" ++ showAddr addr ++ "'"+ show MissingFunctionReturn = "MissingFunctionReturn"+ show FunctionReturnIgnored = "FunctionReturnIgnored"+ show AssignedVoidReturnValue = "AssignedVoidReturnValue"+ show InvaldSubWordExtension = "InvaldSubWordExtension"+ show InvalidAddressType = "InvalidAddressType"+ show (OverlappingBlit a1 a2) = "Addresses for Blit instruction overlap: " ++ show a1 ++ " and " ++ show a2+ show (FuncArgsMismatch ident) = "FuncArgsMismatch: '" ++ show ident ++ "'"+ show InvalidPhiPosition = "InvalidPhiPosition"+ show (MemoryError msg) = "MemoryError: " ++ show msg++instance Exception EvalError
+ src/Language/QBE/Simulator/Expression.hs view
@@ -0,0 +1,184 @@+-- SPDX-FileCopyrightText: 2025 Sören Tempel <soeren+git@soeren-tempel.net>+--+-- SPDX-License-Identifier: GPL-3.0-only++-- | This module provides a generic expression language used to describe+-- arithmetic and logic operations on instruction operands in the abstract+-- 'Language.QBE.Simulator' description of QBE semantics. Therefore, in+-- addition to the 'Language.QBE.Simulator.State.Simulator' monad, it is the+-- central component for the abstract description of QBE's semantics.+module Language.QBE.Simulator.Expression+ ( -- * Expression Abstraction+ ValueRepr (..),++ -- * Conversion Functions,+ fromString,+ toString,+ boolToValue,++ -- * Comparision+ compareIntExpr,+ compareFloatExpr,+ )+where++import Data.Char qualified as C+import Data.Word (Word64)+import Language.QBE.Types qualified as QBE++-- | Generic expression abstraction operating on values of type 'QBE.ExtType'.+-- Values are either fixed-size bitvectors (8-, 16, 32-, or 64-bit) or+-- single-precision or double-precision floating point values. The value type+-- must be tracked internally by the 'ValueRepr' instance. Operations on the+-- value must return 'Nothing' if the operation is performed on values of+-- different types.+class ValueRepr v where+ -- | Create a 'ValueRepr' from an integer literal.+ --+ -- TODO: rename fromLit to fromInt+ fromLit :: QBE.ExtType -> Word64 -> v++ fromFloat :: Float -> v+ fromDouble :: Double -> v+ toWord64 :: v -> Word64+ getType :: v -> QBE.ExtType++ floatToInt :: QBE.ExtType -> Bool -> v -> Maybe v+ intToFloat :: QBE.ExtType -> Bool -> v -> Maybe v+ extendFloat :: v -> Maybe v+ truncFloat :: v -> Maybe v++ -- | Extend a value to the given 'QBE.ExtType'. The 'Bool' is true if+ -- the value should be sign-extended, otherwise it is zero-extended.+ -- If the @v@ is a float or if the current size exceeds (or is equal to)+ -- the size of 'QBE.ExtType', then 'Nothing' is returned.+ extend :: QBE.ExtType -> Bool -> v -> Maybe v++ -- | Extract the least significant bits of a @v@. The bits to extract+ -- are deduced from the given 'QBE.ExtType'. Returns 'Nothing' if the+ -- 'QBE.ExtType' is a float type, if the value is a float, or if the size+ -- of 'QBE.ExtType' exceeds the size of @v@.+ extract :: QBE.ExtType -> v -> Maybe v++ -- | Addition.+ add :: v -> v -> Maybe v++ -- | Subtraction.+ sub :: v -> v -> Maybe v++ -- | Multiplication.+ mul :: v -> v -> Maybe v++ -- | Unsigned division.+ div :: v -> v -> Maybe v++ -- | Unsigned remainder.+ urem :: v -> v -> Maybe v++ -- | Signed remainder.+ srem :: v -> v -> Maybe v++ -- | Unsigned division.+ udiv :: v -> v -> Maybe v++ -- | Bitwise or.+ or :: v -> v -> Maybe v++ -- | Bitwise xor.+ xor :: v -> v -> Maybe v++ -- | Bitwise and.+ and :: v -> v -> Maybe v++ -- | Unary negation.+ neg :: v -> Maybe v++ -- | Arithmetic right shift, preserving the sign bit of the shifted value.+ -- Shift amount must always be a 32-bit value, the shifted value must be 32- or 64-bit.+ sar :: v -> v -> Maybe v++ -- | Logical shift right, filling the newly freed bits with zeroes.+ -- Shift amount must always be a 32-bit value, the shifted value must be 32- or 64-bit.+ shr :: v -> v -> Maybe v++ -- | Logical shift left, always fills the freed bits with zeroes.+ -- Shift amount must always be a 32-bit value, the shifted value must be 32- or 64-bit.+ shl :: v -> v -> Maybe v++ -- | Check for equality.+ eq :: v -> v -> Maybe v++ -- | Check if two values are not equal.+ ne :: v -> v -> Maybe v++ -- | Signed less than or equal to.+ sle :: v -> v -> Maybe v++ -- | Signed less than.+ slt :: v -> v -> Maybe v++ -- | Signed greater than or equal to.+ sge :: v -> v -> Maybe v++ -- | Signed greater than.+ sgt :: v -> v -> Maybe v++ -- | Unsigned less than or equal to.+ ule :: v -> v -> Maybe v++ -- | Unsigned less than.+ ult :: v -> v -> Maybe v++ -- | Unsigned greater than or equal to.+ uge :: v -> v -> Maybe v++ -- | Unsigned greater then.+ ugt :: v -> v -> Maybe v++ -- | Ordered, no operand is a NaN.+ -- Only defined for floating points, must return 'Nothing' otherwise.+ ord :: v -> v -> Maybe v++ -- | Unordered, at least one operand is a NaN.+ -- Only defined for floating points, must return 'Nothing' otherwise.+ unord :: v -> v -> Maybe v+ unord lhs rhs = ord lhs rhs >>= neg++-- | Convert a string to a list of 8-bit values represented through 'ValueRepr'.+fromString :: (ValueRepr v) => String -> [v]+fromString = map (\c -> fromLit QBE.Byte (fromIntegral $ C.ord c))++-- | Inverse of 'fromString'.+toString :: (ValueRepr v) => [v] -> String+toString = map (\b -> C.chr (fromIntegral $ toWord64 b))++-- | Convert a Boolean value to a 64-bit value in 'ValueRepr'.+boolToValue :: (ValueRepr v) => Bool -> v+boolToValue True = fromLit (QBE.Base QBE.Long) 1+boolToValue False = fromLit (QBE.Base QBE.Long) 0++-- | Map a 'QBE.IntCmpOp' to the corresponding function from 'ValueRepr'.+compareIntExpr :: (ValueRepr v) => QBE.IntCmpOp -> (v -> v -> Maybe v)+compareIntExpr QBE.IEq = eq+compareIntExpr QBE.INe = ne+compareIntExpr QBE.ISle = sle+compareIntExpr QBE.ISlt = slt+compareIntExpr QBE.ISge = sge+compareIntExpr QBE.ISgt = sgt+compareIntExpr QBE.IUle = ule+compareIntExpr QBE.IUlt = ult+compareIntExpr QBE.IUge = uge+compareIntExpr QBE.IUgt = ugt+{-# INLINE compareIntExpr #-}++-- | Map a 'QBE.FloatCmpOp' to the corresponding function from 'ValueRepr'.+compareFloatExpr :: (ValueRepr v) => QBE.FloatCmpOp -> (v -> v -> Maybe v)+compareFloatExpr QBE.FEq = eq+compareFloatExpr QBE.FNe = ne+compareFloatExpr QBE.FLe = sle+compareFloatExpr QBE.FLt = slt+compareFloatExpr QBE.FGe = sge+compareFloatExpr QBE.FGt = sgt+compareFloatExpr QBE.FOrd = ord+compareFloatExpr QBE.FUnord = unord+{-# INLINE compareFloatExpr #-}
+ src/Language/QBE/Simulator/Memory.hs view
@@ -0,0 +1,121 @@+-- SPDX-FileCopyrightText: 2023-2024 University of Bremen+-- SPDX-FileCopyrightText: 2025 Sören Tempel <soeren+git@soeren-tempel.net>+--+-- SPDX-License-Identifier: MIT AND GPL-3.0-only++-- | This module provides an implementation of a simple byte-addressable memory+-- based on "Data.Array".+module Language.QBE.Simulator.Memory+ ( -- * Type Aliases+ Address,+ Size,+ showAddr,++ -- * Value Representation+ Storable (toBytes, fromBytes),++ -- * Memory Representation+ Memory,+ mkMemory,+ memSize,+ loadBytes,+ storeBytes,++ -- * Memory Address+ toMemAddr,+ addrOverlap,+ alignAddr,+ )+where++import Data.Array.IO+ ( MArray,+ getBounds,+ newArray_,+ readArray,+ writeArray,+ )+import Data.Bits (complement, (.&.))+import Data.Word (Word64)+import Language.QBE.Types qualified as QBE+import Numeric (showHex)++-- | Type used to represent an address in memory.+type Address = Word64++-- | Type used to represent the memory's size.+type Size = Word64++-- | Represent an address as a hexadecimal string.+showAddr :: Address -> String+showAddr addr = "0x" ++ showHex addr ""++------------------------------------------------------------------------++-- | Type class for types that can be stored in memory. That is, types whose+-- values can be converted to the given byte representation and vice versa.+class Storable valTy byteTy where+ -- | Convert a value type to a list of byte types.+ toBytes :: valTy -> [byteTy]++ -- | Convert a list of bytes to a value type of 'QBE.LoadType'. Returns+ -- 'Nothing' if the length of the list is incompatible with the given+ -- 'QBE.LoadType'.+ fromBytes :: QBE.LoadType -> [byteTy] -> Maybe valTy++-- | Memory parameterized over the Array type (e.g. 'Data.Array.IO.IOUArray')+-- and a byte polymorphic representation (e.g. 'Data.Word.Word8').+data Memory a v = Memory+ { memStart :: Address,+ memBytes :: a Address v+ }++-- | Create a new t'Memory' which starts at the given base address and+-- has a maximum capacity (i.e., can store up to the given amount of bytes).+-- The memory is not initialized, reading an uninitialized values results+-- in an error.+mkMemory :: (MArray t a IO) => Address -> Size -> IO (Memory t a)+mkMemory startAddr size = do+ ary <- newArray_ (0, size - 1)+ return $ Memory startAddr ary++-- | Translate global address to a memory-local address. That is, performs+-- address translation relative to the base address of the t'Memory'.+toMemAddr :: Memory t a -> Address -> Address+toMemAddr mem addr = addr - memStart mem++-- | Returns true if the given addresses, passed in the first and second+-- argument, overlap in the given range (i.e., the given amount of bytes).+addrOverlap :: Address -> Address -> Size -> Bool+addrOverlap addr1 addr2 range =+ addr1 < endAddr addr2 && endAddr addr1 > addr2+ where+ endAddr :: Address -> Address+ endAddr a = a + range++-- | Align an address upwards for the given alignment.+alignAddr :: Address -> Size -> Address+alignAddr addr align = (addr + (align - 1)) .&. complement (align - 1)++-- | Returns the size of the memory in bytes.+memSize :: (MArray t a IO) => Memory t a -> IO Size+memSize = fmap ((+ 1) . snd) . getBounds . memBytes++-- | Write the list of bytes to memory at the given address.+storeBytes :: (MArray t a IO) => Memory t a -> Address -> [a] -> IO ()+storeBytes mem addr bytes =+ mapM_ (\(off, val) -> storeByte mem (addr + off) val) $+ zip [0 ..] bytes+ where+ storeByte :: (MArray t a IO) => Memory t a -> Address -> a -> IO ()+ storeByte m a = writeArray (memBytes m) $ toMemAddr mem a+{-# INLINEABLE storeBytes #-}++-- | Load the given amount of bytes at the given address.+loadBytes :: (MArray t a IO) => Memory t a -> Address -> Size -> IO [a]+loadBytes mem addr byteSize =+ mapM (\off -> loadByte mem (addr + off)) [0 .. byteSize - 1]+ where+ loadByte :: (MArray t a IO) => Memory t a -> Address -> IO a+ loadByte m = readArray (memBytes m) . toMemAddr m+{-# INLINEABLE loadBytes #-}
+ src/Language/QBE/Simulator/State.hs view
@@ -0,0 +1,299 @@+-- SPDX-FileCopyrightText: 2025-2026 Sören Tempel <soeren+git@soeren-tempel.net>+--+-- SPDX-License-Identifier: GPL-3.0-only+{-# LANGUAGE FunctionalDependencies #-}++-- | This module defines the abstract 'Simulator' monad and thus provides the primitives+-- used by "Language.QBE.Simulator" to describe the semantics of the QBE intermediate+-- representation.+module Language.QBE.Simulator.State+ ( -- * Abstract Monad+ Simulator (..),++ -- * Name Resolution+ SomeFunc (..),+ lookupFunc,+ lookupArgs,+ lookupGlobal,+ lookupLocal,+ lookupValue,++ -- * Helper+ liftMaybe,+ subType,+ runBinary,+ returnFromFunc,+ readNullArray,++ -- * Stack+ StackFrame (..),+ newStackFrame,+ storeLocal,+ modifyFrame,+ stackAlign,+ stackAlloc,+ stackSpill,+ )+where++import Control.Monad.Error.Class (MonadError, throwError)+import Data.Functor ((<&>))+import Data.Map qualified as Map+import Data.Maybe (catMaybes)+import Data.Word (Word64)+import Language.QBE.Simulator.Error+import Language.QBE.Simulator.Expression qualified as E+import Language.QBE.Simulator.Memory qualified as MEM+import Language.QBE.Types qualified as QBE++-- | Representation of a stack frame on the function call stack.+data StackFrame v+ = StackFrame+ { stkFunc :: QBE.FuncDef,+ stkVars :: Map.Map QBE.LocalIdent v,+ stkVarArgs :: [v],+ stkFp :: v+ }++-- | Create a new t'StackFrame' and push it onto the call stack.+newStackFrame ::+ (Simulator m v) =>+ -- | Definition of the functions to which this frame belongs.+ QBE.FuncDef ->+ -- | Named arguments passed to this function.+ Map.Map QBE.LocalIdent v ->+ -- | Optional, unnamed variadic arguments.+ [v] ->+ m (StackFrame v)+newStackFrame f args variadicArgs = do+ frame <- getSP <&> StackFrame f args variadicArgs+ pushStackFrame frame >> pure frame+{-# INLINEABLE newStackFrame #-}++-- | Store a local variable with a given name and value in the given t'StackFrame'.+storeLocal :: QBE.LocalIdent -> v -> StackFrame v -> StackFrame v+storeLocal ident value frame@(StackFrame {stkVars = v}) =+ frame {stkVars = Map.insert ident value v}++-- | Lookup a local variable in the current t'StackFrame'.+lookupLocal :: StackFrame v -> QBE.LocalIdent -> Maybe v+lookupLocal (StackFrame {stkVars = v}) = flip Map.lookup v+{-# INLINEABLE lookupLocal #-}++------------------------------------------------------------------------++-- | Representation of a function.+data SomeFunc m v+ = -- | A simulated function whose execution is intercepted by the Simulator.+ SSimFunc ([v] -> m (Maybe v))+ | -- | A QBE function defined in the input program.+ SFuncDef QBE.FuncDef++-- | This is an “abstract monad” representing the Simulator and allowing+-- interaction with an encapsulated Simulator state @m@. Conceptually,+-- this monads describes the primitives based on which the semantics of+-- the QBE intermediate representation are abstractly described in+-- 'Language.QBE.Simulator'.+--+-- An instance of this monad then provides concrete semantics for these+-- primitives. For example, the module "Language.QBE.Simulator.Default.State"+-- provides an implementation of a polymorphic Simulator state implement over a+-- "Control.Monad.State" monad.+--+-- The idea is inspired by Bourgeat et al. <https://doi.org/10.1145/3607833>.+class (E.ValueRepr v, MonadError EvalError m) => Simulator m v | m -> v where+ -- | Check if a value of type 'E.ValueRepr' evaluates to true. This is used+ -- within "Language.QBE.Simulator" to implement conditional jumps.+ isTrue :: v -> m Bool++ -- | Convert a value of type 'E.ValueRepr' to a 'MEM.Address' that can be+ -- used to index a "Language.QBE.Simulator.Memory".+ toAddress :: v -> m MEM.Address++ -- | Lookup the address of a data symbol.+ lookupSymbol :: QBE.GlobalIdent -> m (Maybe MEM.Address)++ -- | Find a function by name, required to implement [call instructions](https://c9x.me/compile/doc/il-v1.2.html#Call).+ findFunc :: QBE.GlobalIdent -> m (Maybe (SomeFunc m v))++ -- | Find a function by "text segment" address, used for the implementation of function pointers.+ findFuncByAddr :: MEM.Address -> m (Maybe (SomeFunc m v))++ -- | Return the t'StackFrame' of the currently executed function.+ activeFrame :: m (StackFrame v)++ -- | Push a new t'StackFrame' onto the function call stack.+ pushStackFrame :: StackFrame v -> m ()++ -- | Pop the current stack frame from the function call stack.+ -- Should throw 'EmptyStack' when invoked on an empty function call stack.+ popStackFrame :: m (StackFrame v)++ -- | Get the current value of the stack pointer.+ getSP :: m v++ -- | Set the value of the stack pointer.+ setSP :: v -> m ()++ -- | Write a value to memory.+ writeMemory :: MEM.Address -> QBE.ExtType -> v -> m () -- TODO: LoadType?++ -- | Read a value from memory.+ readMemory :: QBE.LoadType -> MEM.Address -> m v++-- | Extracts the element out of a 'Just' or throw the given 'EvalError' if+-- if its argument is 'Nothing'.+liftMaybe :: (MonadError EvalError m) => EvalError -> Maybe a -> m a+liftMaybe e Nothing = throwError e+liftMaybe _ (Just r) = pure r+{-# INLINE liftMaybe #-}++-- | Implements the subtyping rules of the QBE intermediate representation.+--+-- See <https://c9x.me/compile/doc/il-v1.2.html#Subtyping>.+subType :: (Simulator m v) => QBE.BaseType -> v -> m v+subType baseTy v = liftMaybe TypingError $ subType' baseTy (E.getType v)+ where+ subType' QBE.Word (QBE.Base QBE.Word) = Just v+ subType' QBE.Word (QBE.Base QBE.Long) =+ E.extract (QBE.Base QBE.Word) v+ subType' QBE.Long (QBE.Base QBE.Long) = Just v+ subType' QBE.Single (QBE.Base QBE.Single) = Just v+ subType' QBE.Double (QBE.Base QBE.Double) = Just v+ subType' _ _ = Nothing+{-# INLINEABLE subType #-}++-- | Invoke a binary operation and perform subtyping (see 'subType') on its+-- results for the provided 'QBE.BaseType'. If the operation returns a 'Nothing'+-- value a 'TypingError' is raised.+runBinary ::+ (Simulator m v) =>+ QBE.BaseType ->+ (v -> v -> Maybe v) ->+ v ->+ v ->+ m v+runBinary ty op lhs rhs =+ liftMaybe TypingError (op lhs rhs) >>= subType ty+{-# INLINEABLE runBinary #-}++-- | Modify the current t'StackFrame', e.g. to add a new local variable to it.+-- If the function call stack is currently empty an 'EmptyStack' error is thrown.+modifyFrame :: (Simulator m v) => (StackFrame v -> StackFrame v) -> m ()+modifyFrame func = do+ frame <- popStackFrame+ pushStackFrame (func frame)+{-# INLINEABLE modifyFrame #-}++-- | Align a stack address. Contrary to 'MEM.alignAddr', this rounds down to+-- the nearest aligned addressed (not up) as the stack grows downward. Further,+-- since the SP representation is presently not fixed, it operates on 'E.ValueRepr'.+stackAlign :: (E.ValueRepr v) => v -> v -> Maybe v+stackAlign addr alignment =+ addr `E.urem` alignment >>= (addr `E.sub`)+{-# INLINEABLE stackAlign #-}++-- | Allocate a given amount of bytes on the stack with the given alignment.+-- Advances the stack pointer accordingly.+stackAlloc :: (Simulator m v) => v -> Word64 -> m v+stackAlloc size align = do+ stkPtr <- getSP+ let newStkPtr = stkPtr `E.sub` size >>= (`stackAlign` E.fromLit (QBE.Base QBE.Long) align)+ case newStkPtr of+ Just ptr -> setSP ptr >> pure ptr+ Nothing -> throwError InvalidAddressType+{-# INLINEABLE stackAlloc #-}++-- | Allocate space for the given value on the stack and store it there.+-- Returns a reference (i.e., a memory address) fore the allocated memory.+stackSpill :: (Simulator m v) => v -> m MEM.Address+stackSpill val = do+ let ty = E.getType val+ size = fromIntegral $ QBE.extTypeByteSize ty+ sizeVal = E.fromLit (QBE.Base QBE.Long) size+ ptr <- stackAlloc sizeVal size >>= toAddress+ writeMemory ptr ty val+ pure ptr+{-# INLINEABLE stackSpill #-}++-- | Trigger a function return, popping its t'StackFrame' from the call stack+-- and updating both the stack and frame pointer.+returnFromFunc :: (Simulator m v) => m ()+returnFromFunc = popStackFrame >>= setSP . stkFp+{-# INLINE returnFromFunc #-}++maybeLookup :: (Simulator m v) => String -> Maybe a -> m a+maybeLookup name = liftMaybe (UnknownVariable name)+{-# INLINE maybeLookup #-}++-- | Lookup a global variable, might throw an 'UnknownVariable' error.+lookupGlobal :: (Simulator m v) => QBE.BaseType -> QBE.GlobalIdent -> m v+lookupGlobal ty name = do+ v <- lookupSymbol name >>= maybeLookup (show name)+ subType ty (E.fromLit (QBE.Base QBE.Long) v)+{-# INLINEABLE lookupGlobal #-}++-- | Lookup a 'QBE.Value', invoking the correct lookup function. For example,+-- 'lookupGlobal' for globals or 'lookupLocal' for local variables.+lookupValue :: (Simulator m v) => QBE.BaseType -> QBE.Value -> m v+lookupValue ty (QBE.VConst (QBE.Const (QBE.Number v))) =+ pure $ E.fromLit (QBE.Base ty) v+lookupValue ty (QBE.VConst (QBE.Const (QBE.SFP v))) =+ subType ty (E.fromFloat v)+lookupValue ty (QBE.VConst (QBE.Const (QBE.DFP v))) =+ subType ty (E.fromDouble v)+lookupValue ty (QBE.VConst (QBE.Const (QBE.Global k))) = lookupGlobal ty k+lookupValue ty (QBE.VConst (QBE.Thread k)) = lookupGlobal ty k+lookupValue ty (QBE.VConst (QBE.Extern k)) = lookupGlobal ty k+lookupValue ty (QBE.VConst (QBE.ExternThread k)) = lookupGlobal ty k+lookupValue ty (QBE.VLocal k) = do+ v <- activeFrame >>= maybeLookup (show k) . flip lookupLocal k+ subType ty v+{-# INLINEABLE lookupValue #-}++lookupFuncName :: (Simulator m v) => QBE.GlobalIdent -> m (SomeFunc m v)+lookupFuncName name = do+ maybeFunc <- findFunc name+ case maybeFunc of+ Just def -> pure def+ Nothing -> throwError (UnknownFunction name)+{-# INLINEABLE lookupFuncName #-}++-- | Interpret the given 'QBE.Value' as a function reference, either+-- looking it up by name or by address. If the function could not be+-- found by address an 'UnknownFunctionAddr' is thrown, otherwise an+-- 'UnknownFunction' error is thrown.+lookupFunc :: (Simulator m v) => QBE.Value -> m (SomeFunc m v)+lookupFunc (QBE.VConst (QBE.Extern n)) = lookupFuncName n+lookupFunc (QBE.VConst (QBE.Const (QBE.Global n))) = lookupFuncName n+lookupFunc value = do+ addr <- lookupValue QBE.Long value >>= toAddress+ maybeFunc <- findFuncByAddr addr+ case maybeFunc of+ Just def -> pure def+ Nothing -> throwError (UnknownFunctionAddr addr)+{-# INLINEABLE lookupFunc #-}++lookupArg :: (Simulator m v) => QBE.FuncArg -> m (Maybe v)+lookupArg (QBE.ArgReg abity value) =+ Just <$> lookupValue (QBE.abityToBase abity) value+lookupArg (QBE.ArgEnv _) = error "env function parameters not supported"+lookupArg QBE.ArgVar = pure Nothing+{-# INLINEABLE lookupArg #-}++-- | Lookup the arguments to a function.+lookupArgs :: (Simulator m v) => [QBE.FuncArg] -> m [v]+lookupArgs args = catMaybes <$> mapM lookupArg args+{-# INLINE lookupArgs #-}++-- | Read a null-terminated C string from memory at the given 'MEM.Address'.+-- The return value is a list of 8-bit values.+readNullArray :: (Simulator m v) => MEM.Address -> m [v]+readNullArray addr = go addr []+ where+ go a acc = do+ byte <- readMemory (QBE.LSubWord QBE.SignedByte) a+ if E.toWord64 byte == 0+ then pure acc+ else go (a + 1) (acc ++ [byte])+{-# INLINE readNullArray #-}
+ test/Analysis.hs view
@@ -0,0 +1,153 @@+-- SPDX-FileCopyrightText: 2025 Sören Tempel <soeren+git@soeren-tempel.net>+-- SPDX-FileCopyrightText: 2026 Reliable System Software, Technische Universität Braunschweig <vss@ibr.cs.tu-bs.de>+--+-- SPDX-License-Identifier: GPL-3.0-only++module Analysis (analTests) where++import Data.Bifunctor (bimap)+import Data.List (sort)+import Language.QBE (parseAndFind)+import Language.QBE.Analysis.CDG qualified as CDG+import Language.QBE.Analysis.CFG qualified as CFG+import Language.QBE.Types qualified as QBE+import System.FilePath ((</>))+import Test.Tasty+import Test.Tasty.HUnit++getFunction :: QBE.GlobalIdent -> String -> IO QBE.FuncDef+getFunction funcName input = snd <$> parseAndFind funcName input++getFuncAndProg :: FilePath -> QBE.GlobalIdent -> IO QBE.FuncDef+getFuncAndProg fileName funcName =+ let filePath = "test" </> "testdata" </> fileName+ in readFile filePath >>= getFunction funcName++toBlkName :: CFG.CFG -> CFG.Label -> String+toBlkName cfg = show . CFG.labelToIdent cfg++cdgEdges :: CFG.CFG -> CDG.CDG -> [(String, String)]+cdgEdges cfg = map go . CDG.edges+ where+ go (f, t) = (toBlkName cfg f, toBlkName cfg t)++cfgEdges :: CFG.CFG -> [(String, String)]+cfgEdges cfg =+ let toBlk = toBlkName cfg+ in sort $ map (bimap toBlk toBlk) (CFG.edges cfg)++------------------------------------------------------------------------++analTests :: TestTree+analTests =+ testGroup+ "Analysis tests"+ [ testCase "Simple CFG without any loops" $+ do+ func <-+ getFunction+ (QBE.GlobalIdent "foo")+ "function w $foo() {\n\+ \@start\n\+ \%val =w add 0, 1\n\+ \jmp @next\n\+ \@next\n\+ \ret\n\+ \}\n"++ let cfg = CFG.build func+ let startLabel = CFG.identToLabel cfg $ QBE.BlockIdent "start"+ map (CFG.labelToIdent cfg) (CFG.lookupSuccs cfg startLabel)+ @?= [QBE.BlockIdent "next"]++ cfgEdges cfg+ @?= [("@start", "@next")]++ -- “If Y is control dependent on X then X must have two exits.“, in+ -- this CFG there are no nodes with two exits: The CDG must be emtpy.+ let ret = CFG.identToLabel cfg $ QBE.BlockIdent "next"+ cdg = CDG.build cfg ret+ cdgEdges cfg cdg @?= []+ CDG.ctrlDeps cdg ret @?= Nothing,+ testCase "Generate CDG for code with single branch" $+ do+ func <-+ getFunction+ (QBE.GlobalIdent "foo")+ "function w $foo() {\n\+ \@start\n\+ \%val =w add 0, 1\n\+ \jnz %val, @ifT, @ifF\n\+ \@ifT\n\+ \%ret =w copy 1\n\+ \jmp @return\n\+ \@ifF\n\+ \%ret =w copy 0\n\+ \jmp @return\n\+ \@return\n\+ \ret %ret\n\+ \}\n"++ let cfg = CFG.build func+ ret = CFG.identToLabel cfg (QBE.BlockIdent "return")+ cdg = CDG.build cfg ret++ cdgEdges cfg cdg+ @?= [ ("@ifF", "@start"),+ ("@ifT", "@start")+ ],+ testCase "Compute CDG for code with loop" $+ do+ func <-+ getFunction+ (QBE.GlobalIdent "main")+ "function w $main() {\n\+ \@start\n\+ \%.1 =w copy 0\n\+ \%.2 =w copy 42\n\+ \%.3 =w copy 0\n\+ \@for_cond\n\+ \%.6 =w csltw %.3, %.2\n\+ \jnz %.6, @for_body, @for_join\n\+ \@for_body\n\+ \%.1 =w add %.1, 1\n\+ \@for_cont\n\+ \%.3 =w add %.3, 1\n\+ \jmp @for_cond\n\+ \@for_join\n\+ \ret %.11\n\+ \}\n"++ let cfg = CFG.build func+ ret = CFG.identToLabel cfg (QBE.BlockIdent "for_join")+ cdg = CDG.build cfg ret++ cdgEdges cfg cdg+ @?= [ ("@for_body", "@for_cond"),+ ("@for_cond", "@for_cond"),+ ("@for_cont", "@for_cond")+ ],+ testCase "Compute CDG for code with two paths to node" $+ do+ func <- getFuncAndProg "disjunction.qbe" (QBE.GlobalIdent "main")++ let cfg = CFG.build func+ ret = CFG.identToLabel cfg (QBE.BlockIdent "return")+ cdg = CDG.build cfg ret++ cdgEdges cfg cdg+ @?= [ ("@if_false.4", "@body.2"),+ ("@if_false.4", "@if_true.3"),+ ("@if_false.6", "@if_true.3"),+ ("@if_join.7", "@if_true.3"),+ ("@if_true.3", "@body.2"),+ ("@if_true.5", "@if_true.3")+ ],+ testCase "Compute dominators for a simple-cc representation" $+ do+ func <- getFuncAndProg "simple-cc-branches.qbe" (QBE.GlobalIdent "myfunc")++ let cfg = CFG.build func+ CFG.labelToIdent cfg (CFG.startNode cfg)+ @?= QBE.BlockIdent ".L9"+ ]
+ test/Expression.hs view
@@ -0,0 +1,104 @@+-- SPDX-FileCopyrightText: 2025 Sören Tempel <soeren+git@soeren-tempel.net>+--+-- SPDX-License-Identifier: GPL-3.0-only++module Expression (exprTests) where++import Data.Int (Int64)+import Data.Maybe (fromJust)+import Language.QBE.Simulator.Default.Expression qualified as DE+import Language.QBE.Simulator.Expression qualified as E+import Language.QBE.Types qualified as Q+import Test.Tasty+import Test.Tasty.HUnit++exprTests :: TestTree+exprTests =+ testGroup+ "Expression Tests"+ [ testCase "Test equality" $+ do+ let lhs = E.fromLit (Q.Base Q.Word) 23 :: DE.RegVal+ let rhs = E.fromLit (Q.Base Q.Word) 42 :: DE.RegVal++ lhs `E.eq` lhs @?= truthValue+ lhs `E.ne` lhs @?= falseValue++ lhs `E.eq` rhs @?= falseValue+ lhs `E.ne` rhs @?= truthValue,+ testCase "Test unsigned comparison" $+ do+ let lhs = E.fromLit (Q.Base Q.Word) 23 :: DE.RegVal+ let rhs = E.fromLit (Q.Base Q.Word) 42 :: DE.RegVal++ lhs `E.ule` rhs @?= truthValue+ lhs `E.ule` lhs @?= truthValue+ lhs `E.ult` lhs @?= falseValue,+ testCase "Test signed comparision" $+ do+ let lhs = E.fromLit (Q.Base Q.Word) (fromIntegral (-1 :: Int64)) :: DE.RegVal+ let rhs = E.fromLit (Q.Base Q.Word) 0 :: DE.RegVal++ lhs `E.slt` rhs @?= truthValue+ lhs `E.sle` lhs @?= truthValue+ lhs `E.ult` rhs @?= falseValue,+ testCase "sar preserves sign bit" $+ do+ let v = E.fromLit (Q.Base Q.Word) (fromIntegral (-256 :: Int64)) :: DE.RegVal+ let r = fromJust $ v `E.sar` E.fromLit (Q.Base Q.Word) 1+ r @?= E.fromLit (Q.Base Q.Word) (fromIntegral (-128 :: Int64)),+ testCase "shr does not preserve sign bit" $+ do+ let v = E.fromLit (Q.Base Q.Word) (fromIntegral (-0x80000000 :: Int64)) :: DE.RegVal+ let r = fromJust $ v `E.shr` E.fromLit (Q.Base Q.Word) 8+ r @?= E.fromLit (Q.Base Q.Word) 0x800000,+ testCase "extend byte to word" $+ do+ let v = E.fromLit Q.Byte 128 :: DE.RegVal++ let signExt = E.fromLit (Q.Base Q.Word) 0xffffff80 :: DE.RegVal+ E.extend (Q.Base Q.Word) True v @?= Just signExt++ let zeroExt = E.fromLit (Q.Base Q.Word) 128 :: DE.RegVal+ E.extend (Q.Base Q.Word) False v @?= Just zeroExt,+ testCase "extend float" $+ do+ let s = E.fromLit (Q.Base Q.Single) 2342 :: DE.RegVal+ E.extend (Q.Base Q.Long) False s @?= Nothing++ let d = E.fromLit (Q.Base Q.Double) 2342 :: DE.RegVal+ E.extend (Q.Base Q.Long) False d @?= Nothing,+ testCase "current size exceeds extend" $+ do+ let s = E.fromLit (Q.Base Q.Word) 2342 :: DE.RegVal+ E.extend Q.Byte False s @?= Nothing,+ testCase "current size equals extend" $+ do+ let s = E.fromLit (Q.Base Q.Word) 2342 :: DE.RegVal+ E.extend (Q.Base Q.Word) True s @?= Nothing,+ testCase "extract from word" $+ do+ let v = E.fromLit (Q.Base Q.Word) 0xdeadbeef :: DE.RegVal++ let e1 = E.fromLit Q.Byte 0xef :: DE.RegVal+ E.extract Q.Byte v @?= Just e1++ let e2 = E.fromLit Q.HalfWord 0xbeef :: DE.RegVal+ E.extract Q.HalfWord v @?= Just e2,+ testCase "extract from float" $+ do+ let d = E.fromLit (Q.Base Q.Double) 2342 :: DE.RegVal+ E.extract Q.Byte d @?= Nothing+ E.extract (Q.Base Q.Single) d @?= Nothing++ let s = E.fromLit (Q.Base Q.Single) 2342 :: DE.RegVal+ E.extract Q.Byte s @?= Nothing+ E.extract (Q.Base Q.Single) s @?= Nothing,+ testCase "extract exceeds size" $+ do+ let v = E.fromLit (Q.Base Q.Word) 0xdeadbeef :: DE.RegVal+ E.extract (Q.Base Q.Long) v @?= Nothing+ ]+ where+ falseValue = Just (E.fromLit (Q.Base Q.Long) 0 :: DE.RegVal)+ truthValue = Just (E.fromLit (Q.Base Q.Long) 1 :: DE.RegVal)
+ test/Main.hs view
@@ -0,0 +1,26 @@+-- SPDX-FileCopyrightText: 2025 Sören Tempel <soeren+git@soeren-tempel.net>+--+-- SPDX-License-Identifier: GPL-3.0-only++module Main (main) where++import Analysis+import Expression+import Memory+import Simulator+import State+import Test.Tasty++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests =+ testGroup+ "Tests"+ [ simTests,+ memTests,+ analTests,+ exprTests,+ stateTests+ ]
+ test/Memory.hs view
@@ -0,0 +1,40 @@+-- SPDX-FileCopyrightText: 2025 Sören Tempel <soeren+git@soeren-tempel.net>+--+-- SPDX-License-Identifier: GPL-3.0-only++module Memory (memTests) where++import Data.Array.IO (IOUArray)+import Data.Word (Word8)+import Language.QBE.Simulator.Memory+import Test.Tasty+import Test.Tasty.HUnit++memTests :: TestTree+memTests =+ testGroup+ "Memory tests"+ [ testCase "Create memory and extract its size" $ do+ mem <- mkMemory 0x0 512 :: IO (Memory IOUArray Word8)+ memSize mem >>= assertEqual "" 512,+ testCase "Store and read byte" $ do+ m <- mkMemory 0 64 :: IO (Memory IOUArray Word8)+ storeBytes m 0x0 [0xff]+ loadBytes m 0x0 1 >>= assertEqual "" [0xff],+ testCase "Store and read bytes" $ do+ m <- mkMemory 0 32 :: IO (Memory IOUArray Word8)+ storeBytes m 0x0 [0xde, 0xad, 0xbe, 0xef]+ loadBytes m 0x0 4 >>= assertEqual "" [0xde, 0xad, 0xbe, 0xef],+ testCase "Store and read multiple bytes" $ do+ m <- mkMemory 0 4 :: IO (Memory IOUArray Word8)+ storeBytes m 0x0 [0xde, 0xad]+ storeBytes m 0x2 [0xbe, 0xef]+ loadBytes m 0x0 2 >>= assertEqual "" [0xde, 0xad]+ loadBytes m 0x2 2 >>= assertEqual "" [0xbe, 0xef]+ loadBytes m 0x0 4 >>= assertEqual "" [0xde, 0xad, 0xbe, 0xef],+ testCase "Overlapping memory address" $ do+ addrOverlap 0x100 0x100 1 @?= True+ addrOverlap 100 200 50 @?= False+ addrOverlap 116 120 4 @?= False+ addrOverlap 100 100 0 @?= False+ ]
+ test/Simulator.hs view
@@ -0,0 +1,1281 @@+-- SPDX-FileCopyrightText: 2025 Sören Tempel <soeren+git@soeren-tempel.net>+--+-- SPDX-License-Identifier: GPL-3.0-only++module Simulator (simTests) where++import Control.Monad.Catch (try)+import Data.Int (Int32)+import Data.Word (Word8)+import GHC.Float (castDoubleToWord64, castFloatToWord32, double2Float, float2Double)+import Language.QBE (parseAndFind)+import Language.QBE.Simulator+import Language.QBE.Simulator.Default.Expression qualified as D+import Language.QBE.Simulator.Default.State (Env, mkEnv, run)+import Language.QBE.Simulator.Error+import Language.QBE.Types qualified as QBE+import System.FilePath ((</>))+import Test.Tasty+import Test.Tasty.HUnit++parseAndExec' ::+ QBE.GlobalIdent ->+ [D.RegVal] ->+ String ->+ IO (Either EvalError (Maybe D.RegVal))+parseAndExec' funcName params input = do+ (prog, entry) <- parseAndFind funcName input++ env <- mkEnv prog 0 128 :: IO (Env D.RegVal Word8)+ try $ run env (execFunc entry params)++parseAndExec :: QBE.GlobalIdent -> [D.RegVal] -> String -> IO (Maybe D.RegVal)+parseAndExec funcName params input = do+ evalRes <- parseAndExec' funcName params input+ case evalRes of+ Left e -> fail $ "Unexpected evaluation error: " ++ show e+ Right r -> pure r++parseAndExecFile :: QBE.GlobalIdent -> [D.RegVal] -> FilePath -> IO (Maybe D.RegVal)+parseAndExecFile funcName params fileName = do+ let filePath = "test" </> "testdata" </> fileName+ input <- readFile filePath+ parseAndExec funcName params input++------------------------------------------------------------------------++blockTests :: TestTree+blockTests =+ testGroup+ "Evaluation of Basic Blocks"+ [ testCase "Evaluate single basic block with single instruction" $+ do+ res <-+ parseAndExec+ (QBE.GlobalIdent "addNumbers")+ []+ "function w $addNumbers() {\n\+ \@start\n\+ \%c =w add 1, 2\n\+ \ret %c\n\+ \}"++ res @?= Just (D.VWord 3),+ testCase "Evaluate single basic block with multiple instructions" $+ do+ res <-+ parseAndExec+ (QBE.GlobalIdent "addMultiple")+ []+ "function w $addMultiple() {\n\+ \@begin\n\+ \%val =w add 1, 2\n\+ \%foo =w add %val, 2\n\+ \ret %foo\n\+ \}"++ res @?= Just (D.VWord 5),+ testCase "Evaluate expression with subtyping" $+ do+ res <-+ -- 16045690984835251117 == 0xdeadbeefdecafbad+ parseAndExec+ (QBE.GlobalIdent "subtyping")+ []+ "function w $subtyping() {\n\+ \@go\n\+ \%val =l add 16045690984835251117, 0\n\+ \%foo =w add %val, 0\n\+ \ret %foo\n\+ \}"++ res @?= Just (D.VWord 0xdecafbad),+ testCase "Subtyping in function return value" $+ do+ res <-+ -- 16045690984835251117 == 0xdeadbeefdecafbad+ parseAndExec+ (QBE.GlobalIdent "subtyp")+ []+ "function w $subtyp() {\n\+ \@start\n\+ \%v =l add 0, 16045690984835251117\n\+ \ret %v\n\+ \}"++ res @?= Just (D.VWord 0xdecafbad),+ testCase "Evaluate function without return value" $+ do+ res <-+ parseAndExec+ (QBE.GlobalIdent "noRet")+ []+ "function $noRet() {\n\+ \@start\n\+ \ret\n\+ \}"++ res @?= Nothing,+ testCase "Evaluate two basic blocks with unconditional jump" $+ do+ res <-+ parseAndExec+ (QBE.GlobalIdent "unconditionalJump")+ []+ "function w $unconditionalJump() {\n\+ \@start\n\+ \%val =w add 0, 1\n\+ \jmp @next\n\+ \@next\n\+ \%val =w add %val, 1\n\+ \ret %val\n\+ \}"++ res @?= Just (D.VWord 2),+ testCase "Evalute basic blocks with fallthrough jump" $+ do+ res <-+ parseAndExec+ (QBE.GlobalIdent "unconditionalJump")+ []+ "function w $unconditionalJump() {\n\+ \@start\n\+ \%val =w add 0, 1\n\+ \@next\n\+ \%val =w add %val, 1\n\+ \ret %val\n\+ \}"++ res @?= Just (D.VWord 2),+ testCase "Conditional jump with zero value" $+ do+ res <-+ parseAndExec+ (QBE.GlobalIdent "conditionalJumpTaken")+ []+ "function l $conditionalJumpTaken() {\n\+ \@start\n\+ \%zero =w add 0, 0\n\+ \jnz %zero, @nonZero, @zero\n\+ \@nonZero\n\+ \%val =l add 0, 42\n\+ \ret %val\n\+ \@zero\n\+ \%val =l add 0, 23\n\+ \ret %val\n\+ \}"++ res @?= Just (D.VLong 23),+ testCase "Conditional jump with non-zero value" $+ do+ res <-+ parseAndExec+ (QBE.GlobalIdent "conditionalJumpTaken")+ []+ "function l $conditionalJumpTaken() {\n\+ \@start\n\+ \%zero =w add 1, 0\n\+ \jnz %zero, @nonZero, @zero\n\+ \@nonZero\n\+ \%val =l add 0, 42\n\+ \ret %val\n\+ \@zero\n\+ \%val =l add 0, 23\n\+ \ret %val\n\+ \}"++ res @?= Just (D.VLong 42),+ testCase "Execute a function with parameters" $+ do+ res <-+ parseAndExec+ (QBE.GlobalIdent "funcWithParam")+ [D.VWord 41]+ "function w $funcWithParam(w %x) {\n\+ \@go\n\+ \%y =w add 1, %x\n\+ \ret %y\n\+ \}"++ res @?= Just (D.VWord 42),+ testCase "Function call instruction without return value" $+ do+ res <-+ parseAndExec+ (QBE.GlobalIdent "main")+ []+ "function $foo(w %x) {\n\+ \@start\n\+ \%y =w sub 42, 0\n\+ \ret\n\+ \}\n\+ \function w $main() {\n\+ \@start\n\+ \%y =w sub 0, 0\n\+ \call $foo(w %y)\n\+ \ret %y\n\+ \}"++ res @?= Just (D.VWord 0),+ testCase "Function call with return value" $+ do+ res <-+ parseAndExec+ (QBE.GlobalIdent "main")+ []+ "function w $foo(w %x) {\n\+ \@start\n\+ \%y =w sub %x, 19\n\+ \ret %y\n\+ \}\n\+ \function w $main() {\n\+ \@start\n\+ \%x =w add 0, 42\n\+ \%ret =w call $foo(w %x)\n\+ \ret %ret\n\+ \}"++ res @?= Just (D.VWord 23),+ testCase "Allocate, store and load value in memory" $+ do+ res <-+ parseAndExec+ (QBE.GlobalIdent "allocate")+ []+ "function w $allocate() {\n\+ \@start\n\+ \%addr =l alloc4 4\n\+ \storew 2342, %addr\n\+ \%v =w loadw %addr\n\+ \ret %v\n\+ \}"++ res @?= Just (D.VWord 2342),+ testCase "Load with sub word type" $+ do+ res <-+ parseAndExec+ (QBE.GlobalIdent "allocate")+ []+ "function w $allocate() {\n\+ \@start\n\+ \%addr =l alloc4 4\n\+ \storeb 249, %addr\n\+ \%v =w loadsb %addr\n\+ \ret %v\n\+ \}"++ -- 249 (0xf9) sign extended to 32-bit.+ res @?= Just (D.VWord 0xfffffff9),+ testCase "Store subword in memory" $+ do+ res <-+ -- 2863311530 == 0xaaaaaaaa+ parseAndExec+ (QBE.GlobalIdent "storeByte")+ []+ "function w $storeByte() {\n\+ \@start\n\+ \%addr =l alloc4 4\n\+ \storew 2863311530, %addr\n\+ \storeb 255, %addr\n\+ \%v =w loadw %addr\n\+ \ret %v\n\+ \}"++ res @?= Just (D.VWord 0xaaaaaaff),+ testCase "Function with user-defined type as function parameter" $+ do+ res <-+ parseAndExec+ (QBE.GlobalIdent "main")+ []+ "type :one = { w }\n\+ \function w $getone(:one %ptr) {\n\+ \@start\n\+ \%val =w loadw %ptr\n\+ \ret %val\n\+ \}\n\+ \function w $main() {\n\+ \@entry\n\+ \%addr =l alloc4 4\n\+ \storew 3735928559, %addr\n\+ \%ret =w call $getone(l %addr)\n\+ \ret %ret\n\+ \}"++ res @?= Just (D.VWord 0xdeadbeef),+ testCase "Pointer arithmetic on user-defined type" $+ do+ res <-+ parseAndExec+ (QBE.GlobalIdent "main")+ []+ "type :abyteandmanywords = { w, b 100 }\n\+ \function w $main() {\n\+ \@start.1\n\+ \%addr.0 =l alloc4 104\n\+ \%addr.1 =l add %addr.0, 4\n\+ \storeb 255, %addr.1\n\+ \%addr.2 =l sub %addr.1, 4\n\+ \storew 3735928304, %addr.2\n\+ \%word =w loaduw %addr.0\n\+ \%byte =w loadub %addr.1\n\+ \%res =w add %word, %byte\n\+ \ret %res\n\+ \}"++ res @?= Just (D.VWord 0xdeadbeef),+ testCase "Subtyping with subword function parameters" $+ do+ res <-+ parseAndExec'+ (QBE.GlobalIdent "subword")+ [D.VWord 0xff]+ "function $subword(ub %val) {\n\+ \@start\n\+ \%val =w add %val, 1\n\+ \ret\n\+ \}"++ res @?= Right Nothing,+ testCase "Jump to unknown block within function" $+ do+ res <-+ parseAndExec'+ (QBE.GlobalIdent "main")+ []+ "function $main() {\n\+ \@start\n\+ \jmp @foo\n\+ \@bar\n\+ \ret\n\+ \}"++ res @?= Left (UnknownBlock $ QBE.BlockIdent "foo"),+ testCase "Call undefined function" $+ do+ res <-+ parseAndExec'+ (QBE.GlobalIdent "main")+ []+ "function $main() {\n\+ \@start\n\+ \call $bar()\n\+ \ret\n\+ \}"++ res @?= Left (UnknownFunction $ QBE.GlobalIdent "bar"),+ testCase "Arithmetic with single-precision float" $+ do+ res <-+ parseAndExec+ (QBE.GlobalIdent "addFloats")+ [D.VSingle 2.0, D.VSingle 0.3]+ "function s $addFloats(s %f1, s %f2) {\n\+ \@start\n\+ \%val =s add %f1, %f2\n\+ \ret %val\n\+ \}"++ res @?= Just (D.VSingle 2.3),+ testCase "Arithmetic with double-precision float" $+ do+ res <-+ parseAndExec+ (QBE.GlobalIdent "addFloats")+ [D.VDouble 2.0, D.VDouble 0.3]+ "function d $addFloats(d %f1, d %f2) {\n\+ \@start\n\+ \%val =d add %f1, %f2\n\+ \ret %val\n\+ \}"++ res @?= Just (D.VDouble 2.3),+ testCase "Arithmetic with float literal" $+ do+ res1 <-+ parseAndExec+ (QBE.GlobalIdent "addFloatAndLit")+ [D.VSingle 4.2]+ "function s $addFloatAndLit(s %f) {\n\+ \@start\n\+ \%v =s add %f, 1\n\+ \ret %v\n\+ \}"++ -- This returns 4.2, not 5.2 because the 1 is interpreted+ -- as a bitwise representation of an IEEE floating point.+ --+ -- QBE itself also treats it in this way.+ res1 @?= Just (D.VSingle 4.2)++ -- The following works because it uses the single literal.+ res2 <-+ parseAndExec+ (QBE.GlobalIdent "addFloatAndLit")+ [D.VSingle 4.2]+ "function s $addFloatAndLit(s %f) {\n\+ \@start\n\+ \%v =s add %f, s_1.0\n\+ \ret %v\n\+ \}"++ res2 @?= Just (D.VSingle 5.2),+ testCase "Invalid mixed float arithmetic" $+ do+ res <-+ parseAndExec'+ (QBE.GlobalIdent "addFloatAndLong")+ [D.VSingle 4.2, D.VLong 42]+ "function s $addFloatAndLong(s %f, l %l) {\n\+ \@start\n\+ \%v =s add %f, %l\n\+ \ret %v\n\+ \}"++ res @?= Left TypingError,+ testCase "Store float in memory and load it again" $+ do+ res <-+ parseAndExec+ (QBE.GlobalIdent "storeAndLoadFloat")+ [D.VSingle 0.333333333]+ "function s $storeAndLoadFloat(s %f) {\n\+ \@start.1\n\+ \%addr =l alloc4 4\n\+ \stores %f, %addr\n\+ \%loaded =s loads %addr\n\+ \ret %loaded\n\+ \}"++ res @?= Just (D.VSingle 0.333333333),+ testCase "Store double in memory and load it again" $+ do+ res <-+ parseAndExec+ (QBE.GlobalIdent "storeAndLoadDouble")+ [D.VDouble 0.3333333331111]+ "function d $storeAndLoadDouble(d %f) {\n\+ \@start.1\n\+ \%addr =l alloc4 8\n\+ \stored %f, %addr\n\+ \%loaded =d loadd %addr\n\+ \ret %loaded\n\+ \}"++ res @?= Just (D.VDouble 0.3333333331111),+ testCase "Load data object from memory" $+ do+ res <-+ parseAndExec+ (QBE.GlobalIdent "main")+ []+ "data $a = { b \"ABCD\" }\n\+ \function w $main() {\n\+ \@start\n\+ \%w =w loadw $a\n\+ \ret %w\n\+ \}"++ res @?= Just (D.VWord 0x44434241),+ testCase "Data definition with symbol reference" $+ do+ res <-+ parseAndExec+ (QBE.GlobalIdent "main")+ []+ "data $a = { b \"ABCD\" }\n\+ \data $p = { l $a }\n\+ \function w $main() {\n\+ \@start\n\+ \%ptr =l loadl $p\n\+ \%res =w loadw %ptr\n\+ \ret %res\n\+ \}"++ res @?= Just (D.VWord 0x44434241),+ testCase "Data definition with symbol offset" $+ do+ res <-+ parseAndExec+ (QBE.GlobalIdent "main")+ []+ "data $a = align 1 { b \"ABCDE\" }\n\+ \data $p = align 8 { l $a + 1 }\n\+ \function w $main() {\n\+ \@start\n\+ \%ptr =l loadl $p\n\+ \%res =w loadw %ptr\n\+ \ret %res\n\+ \}"++ res @?= Just (D.VWord 0x45444342),+ testCase "Data definition with constant number" $+ do+ res <-+ parseAndExec+ (QBE.GlobalIdent "main")+ []+ "data $a = align 4 { l 42 }\n\+ \function l $main() {\n\+ \@start\n\+ \%l =l loadl $a\n\+ \ret %l\n\+ \}"++ res @?= Just (D.VLong 42),+ testCase "Data definition with multiple fields" $+ do+ res <-+ parseAndExec+ (QBE.GlobalIdent "main")+ []+ "data $a = align 1 { b \"ABCD\", w 42 }\n\+ \data $p = align 8 { l $a + 4 }\n\+ \function w $main() {\n\+ \@start\n\+ \%ptr =l loadl $p\n\+ \%res =w loadw %ptr\n\+ \ret %res\n\+ \}"++ res @?= Just (D.VWord 42),+ testCase "Data definition with zero fill" $+ do+ res <-+ parseAndExec+ (QBE.GlobalIdent "main")+ []+ "data $a = align 1 { w 4294967295, z 4, w 4294967295 }\n\+ \data $p = align 8 { l $a }\n\+ \function w $main() {\n\+ \@start\n\+ \%ptr =l loadl $p\n\+ \%ptr =l add %ptr, 4\n\+ \%res =w loadw %ptr\n\+ \ret %res\n\+ \}"++ res @?= Just (D.VWord 0),+ testCase "Data definition with single" $+ do+ res <-+ parseAndExec+ (QBE.GlobalIdent "main")+ []+ "data $a = align 1 { s s_2.3, s s_4.2 }\n\+ \data $p = align 8 { l $a }\n\+ \function s $main() {\n\+ \@start\n\+ \%ptr.1 =l loadl $p\n\+ \%ptr.2 =l add %ptr.1, 4\n\+ \%val.1 =s loads %ptr.1\n\+ \%val.2 =s loads %ptr.2\n\+ \%res =s add %val.1, %val.2\n\+ \ret %res\n\+ \}"+ res @?= Just (D.VSingle $ 2.3 + 4.2),+ testCase "Recursive data definition" $+ do+ res <-+ parseAndExec+ (QBE.GlobalIdent "main")+ []+ "data $c = { l -1, l $c }\n\+ \function w $main() {\n\+ \@start\n\+ \%ptr.1 =l add $c, 0\n\+ \%ptr.2 =l add $c, 8\n\+ \%field =l loadl %ptr.2\n\+ \%ptrEq =w ceql %field, %ptr.1\n\+ \ret %ptrEq\n\+ \}"++ res @?= Just (D.VWord 1),+ testCase "Data definition with maximum struct member alignment" $+ do+ res <-+ -- The maximum alignment of a struct member for the struct+ -- referenced by `$ptr` is 8 (the long member). Therefore,+ -- the struct must be allocated on a 8-Byte-aligned address.+ parseAndExec+ (QBE.GlobalIdent "main")+ []+ "data $fill = { w 0 }\n\+ \data $ptr = { b 255, w 2342, l 1337, b 255 }\n\+ \function w $main() {\n\+ \@start\n\+ \%p =l urem $ptr, 8\n\+ \%correctAlign =w ceql %p, 0\n\+ \ret %correctAlign\n\+ \}"++ res @?= Just (D.VWord 1),+ testCase "Data definition with forward reference to other definition" $+ do+ res <-+ parseAndExec+ (QBE.GlobalIdent "main")+ []+ "data $a = { l $b }\n\+ \data $b = { b 0 }\n\+ \function w $main() {\n\+ \@start\n\+ \%isGt =w cugtl $a, $b\n\+ \%ptrB =l loadl $a\n\+ \%isEq =w ceql %ptrB, $b\n\+ \%ret =w and %isEq, %isGt\n\+ \ret %ret\n\+ \}"++ res @?= Just (D.VWord 1),+ testCase "Access memory of data definition with forward reference" $+ do+ res <-+ parseAndExec+ (QBE.GlobalIdent "main")+ []+ "data $a = { l $b }\n\+ \data $b = { b 99 }\n\+ \function w $main() {\n\+ \@start\n\+ \%pb =l loadl $a\n\+ \%vb =w loadub %pb\n\+ \%rt =w extub %vb\n\+ \ret %rt\n\+ \}"++ res @?= Just (D.VWord 99),+ testCase "Subtyping with load instruction" $+ do+ res <-+ -- 16045690984835251117 == 0xdeadbeefdecafbad+ parseAndExec+ (QBE.GlobalIdent "allocate")+ []+ "function w $allocate() {\n\+ \@start\n\+ \%addr =l alloc4 4\n\+ \storel 16045690984835251117, %addr\n\+ \%v =w loadl %addr\n\+ \ret %v\n\+ \}"++ res @?= Just (D.VWord 0xdecafbad),+ testCase "Subtyped branch condition" $+ do+ res <-+ parseAndExec+ (QBE.GlobalIdent "condJump")+ []+ "function w $condJump() {\n\+ \@start\n\+ \%zero =l add 0, 0\n\+ \jnz %zero, @nonZero, @zero\n\+ \@nonZero\n\+ \%val =w add 0, 42\n\+ \ret %val\n\+ \@zero\n\+ \%val =w add 0, 23\n\+ \ret %val\n\+ \}"++ res @?= Just (D.VWord 23),+ testCase "Multiple jumps" $+ do+ res <-+ parseAndExec+ (QBE.GlobalIdent "branchOnInput")+ [D.VWord 0, D.VWord 0]+ "function w $branchOnInput(w %cond1, w %cond2) {\n\+ \@jump.1\n\+ \jnz %cond1, @branch.1, @branch.2\n\+ \@branch.1\n\+ \jmp @jump.2\n\+ \@branch.2\n\+ \jmp @jump.2\n\+ \@jump.2\n\+ \jnz %cond2, @branch.3, @branch.4\n\+ \@branch.3\n\+ \ret 3\n\+ \@branch.4\n\+ \ret 4\n\+ \}"++ res @?= Just (D.VWord 4),+ testCase "Blit instruction w/o overlaps" $+ do+ res <-+ parseAndExec+ (QBE.GlobalIdent "main")+ [D.VWord 0xdeadbeef]+ "function w $main(w %word) {\n\+ \@start\n\+ \%src =l alloc4 4\n\+ \%dst =l alloc4 4\n\+ \storew %word, %src\n\+ \blit %src, %dst, 4\n\+ \%ret =w loadw %dst\n\+ \ret %ret\n\+ \}"++ res @?= Just (D.VWord 0xdeadbeef),+ testCase "Blit instruction with no bytes to copy" $+ do+ res <-+ parseAndExec+ (QBE.GlobalIdent "main")+ [D.VWord 0xdeadbeef]+ "function w $main(w %word) {\n\+ \@start\n\+ \%src =l alloc4 4\n\+ \%dst =l alloc4 4\n\+ \storew %word, %src\n\+ \storew 42, %dst\n\+ \blit %src, %dst, 0\n\+ \%ret =w loadw %dst\n\+ \ret %ret\n\+ \}"++ res @?= Just (D.VWord 42),+ testCase "Comparision instruction" $+ do+ let prog =+ "function w $main(w %lhs, w %rhs) {\n\+ \@start\n\+ \%r =w csltw %lhs, %rhs\n\+ \ret %r\n\+ \}"++ resLarger <-+ parseAndExec+ (QBE.GlobalIdent "main")+ [D.VWord 0, D.VWord 1]+ prog+ resLarger @?= Just (D.VWord 1)++ resSmaller <-+ parseAndExec+ (QBE.GlobalIdent "main")+ [D.VWord 1, D.VWord 0]+ prog+ resSmaller @?= Just (D.VWord 0),+ testCase "Compare with subtyping" $+ do+ res <-+ parseAndExec+ (QBE.GlobalIdent "main")+ [D.VWord 1, D.VLong 0]+ "function w $main(w %lhs, l %rhs) {\n\+ \@start\n\+ \%r =w csltw %lhs, %rhs\n\+ \ret %r\n\+ \}"++ res @?= Just (D.VWord 0),+ testCase "Compare with long exceeding 32-bit" $+ do+ res <-+ parseAndExec+ (QBE.GlobalIdent "main")+ []+ "function w $main() {\n\+ \@start\n\+ \%r =w cultl 4294967296, 20\n\+ \ret %r\n\+ \}"++ res @?= Just (D.VWord 0),+ testCase "Phi instruction" $+ do+ res <-+ parseAndExec+ (QBE.GlobalIdent "f")+ []+ "function w $f() {\n\+ \@begin\n\+ \jmp @start2\n\+ \@start1\n\+ \jmp @phi\n\+ \@start2\n\+ \jmp @phi\n\+ \@phi\n\+ \%v =w phi @start1 23, @start2 42\n\+ \ret %v\n\+ \}"++ res @?= Just (D.VWord 42),+ testCase "Sign extend subword" $+ do+ res <-+ parseAndExec+ (QBE.GlobalIdent "ext")+ [D.VWord 128]+ "function w $ext(w %word) {\n\+ \@start\n\+ \%r =w extsb %word\n\+ \ret %r\n\+ \}"++ res @?= Just (D.VWord 0xffffff80),+ testCase "Zero extend subword" $+ do+ res <-+ parseAndExec+ (QBE.GlobalIdent "ext")+ [D.VWord 128]+ "function w $ext(w %word) {\n\+ \@start\n\+ \%r =w extub %word\n\+ \ret %r\n\+ \}"++ res @?= Just (D.VWord 0x00000080),+ testCase "Shift instructions" $+ do+ res <-+ parseAndExec+ (QBE.GlobalIdent "shift")+ [D.VWord 0xdeadbeef]+ "function w $shift(w %word) {\n\+ \@start\n\+ \%r =w shr 3735928559, 4\n\+ \%r =w shl %r, 4\n\+ \ret %r\n\+ \}"++ res @?= Just (D.VWord 0xdeadbee0),+ testCase "Shift with long amount" $+ do+ res <-+ parseAndExec+ (QBE.GlobalIdent "shift")+ []+ "function l $shift() {\n\+ \@start\n\+ \%r =l shl 2, 4294967300\n\+ \ret %r\n\+ \}"++ -- 4294967300 overflows to 4 so this is: 2 << 4.+ res @?= Just (D.VLong 32),+ testCase "Div instruction with single" $+ do+ res <-+ parseAndExec+ (QBE.GlobalIdent "div")+ []+ "function s $div() {\n\+ \@start\n\+ \%r =s div s_5.0, s_2.0\n\+ \ret %r\n\+ \}"++ res @?= Just (D.VSingle 2.5),+ testCase "Div instruction with double" $+ do+ res <-+ parseAndExec+ (QBE.GlobalIdent "div")+ []+ "function d $div() {\n\+ \@start\n\+ \%r =d div d_5.0, d_2.0\n\+ \ret %r\n\+ \}"++ res @?= Just (D.VDouble 2.5),+ testCase "Div instruction with word" $+ do+ res <-+ parseAndExec+ (QBE.GlobalIdent "div")+ []+ "function w $div() {\n\+ \@start\n\+ \%r =w div 5, 2\n\+ \ret %r\n\+ \}"++ res @?= Just (D.VWord 2),+ testCase "Copy instruction with subtyping" $+ do+ res <-+ parseAndExec+ (QBE.GlobalIdent "main")+ []+ "function w $main() {\n\+ \@start\n\+ \%l =l copy 42\n\+ \%w =w copy %l\n\+ \ret %w\n\+ \}"++ res @?= Just (D.VWord 42),+ testCase "Cast from single to word" $+ do+ res <-+ parseAndExec+ (QBE.GlobalIdent "main")+ []+ "function w $main() {\n\+ \@start\n\+ \%s =s add s_0.0, s_4.2\n\+ \%w =w cast %s\n\+ \ret %w\n\+ \}"++ let ftow = castFloatToWord32 4.2+ res @?= Just (D.VWord ftow),+ testCase "Cast from double to long" $+ do+ res <-+ parseAndExec+ (QBE.GlobalIdent "main")+ []+ "function l $main() {\n\+ \@start\n\+ \%d =d add d_0.0, d_4.2\n\+ \%l =l cast %d\n\+ \ret %l\n\+ \}"++ let dtol = castDoubleToWord64 4.2+ res @?= Just (D.VLong dtol),+ testCase "Cast from word to single" $+ do+ let ftow = castFloatToWord32 4.2+ res <-+ parseAndExec+ (QBE.GlobalIdent "cast")+ [D.VWord ftow]+ "function s $cast(w %w) {\n\+ \@start\n\+ \%s =s cast %w\n\+ \ret %s\n\+ \}"++ res @?= Just (D.VSingle 4.2),+ testCase "Cast from long to double" $+ do+ let dtol = castDoubleToWord64 4.2342+ res <-+ parseAndExec+ (QBE.GlobalIdent "cast")+ [D.VLong dtol]+ "function d $cast(l %l) {\n\+ \@start\n\+ \%d =d cast %l\n\+ \ret %d\n\+ \}"++ res @?= Just (D.VDouble 4.2342),+ testCase "Trunc double to single" $+ do+ let f = 4.293170199018932489308403284024098032+ res <-+ parseAndExec+ (QBE.GlobalIdent "trunc")+ [D.VDouble f]+ "function s $trunc(d %d) {\n\+ \@start\n\+ \%s =s truncd %d\n\+ \ret %s\n\+ \}"++ let d2f = D.VSingle $ double2Float f+ res @?= Just d2f,+ testCase "Extend float to double" $+ do+ let f = 23.42+ res <-+ parseAndExec+ (QBE.GlobalIdent "ext")+ [D.VSingle f]+ "function d $ext(s %s) {\n\+ \@start\n\+ \%d =d exts %s\n\+ \ret %d\n\+ \}"++ let f2d = D.VDouble $ float2Double f+ res @?= Just f2d,+ testCase "Invalid exts" $+ do+ res <-+ parseAndExec'+ (QBE.GlobalIdent "ext")+ [D.VSingle 23.42]+ "function s $ext(s %s) {\n\+ \@start\n\+ \%s =s exts %s\n\+ \ret %s\n\+ \}"++ res @?= Left TypingError,+ testCase "Convert single to unsigned long" $+ do+ let f = 4.2+ res <-+ parseAndExec+ (QBE.GlobalIdent "fcon")+ [D.VSingle f]+ "function l $fcon(s %s) {\n\+ \@start\n\+ \%ret =l stoui %s\n\+ \ret %ret\n\+ \}"++ res @?= Just (D.VLong 4),+ testCase "Convert single to signed word" $+ do+ let f = -3.99+ res <-+ parseAndExec+ (QBE.GlobalIdent "fcon")+ [D.VSingle f]+ "function w $fcon(s %s) {\n\+ \@start\n\+ \%ret =w stosi %s\n\+ \ret %ret\n\+ \}"++ res @?= Just (D.VWord $ fromIntegral (-3 :: Int32)),+ testCase "Convert double to unsigned int" $+ do+ let f = 4.9+ res <-+ parseAndExec+ (QBE.GlobalIdent "fcon")+ [D.VDouble f]+ "function l $fcon(d %d) {\n\+ \@start\n\+ \%ret =l dtoui %d\n\+ \ret %ret\n\+ \}"++ res @?= Just (D.VLong 4),+ testCase "Compare double to NaN" $+ do+ let exec lhs rhs =+ parseAndExec+ (QBE.GlobalIdent "isNaN")+ [D.VDouble lhs, D.VDouble rhs]+ "function w $isNaN(d %lhs, d %rhs) {\n\+ \@start\n\+ \%ret =w cod %lhs, %rhs\n\+ \ret %ret\n\+ \}"++ res0 <- exec 0 0+ res0 @?= Just (D.VWord 1)++ res1 <- exec 0 (read "NaN")+ res1 @?= Just (D.VWord 0)++ res2 <- exec (read "NaN") 0+ res2 @?= Just (D.VWord 0),+ testCase "Compare single equality" $+ do+ let exec lhs rhs =+ parseAndExec+ (QBE.GlobalIdent "eq")+ [D.VSingle lhs, D.VSingle rhs]+ "function w $eq(s %lhs, s %rhs) {\n\+ \@start\n\+ \%ret =w ceqs %lhs, %rhs\n\+ \ret %ret\n\+ \}"++ res0 <- exec 0 0+ res0 @?= Just (D.VWord 1)++ res1 <- exec 0 23.42+ res1 @?= Just (D.VWord 0)++ res2 <- exec 42.1 0+ res2 @?= Just (D.VWord 0)++ res3 <- exec 42.2323 42.2323+ res3 @?= Just (D.VWord 1),+ testCase "phi instruction in second block" $+ do+ res <-+ parseAndExec+ (QBE.GlobalIdent "main")+ []+ "function w $main() {\n\+ \@start.1\n\+ \%.0 =w copy 42\n\+ \@body.2\n\+ \%.1 =w phi @start.1 1, @body.2 2\n\+ \ret %.1\n\+ \}"++ res @?= Just (D.VWord 1),+ testCase "variable argument list with single argument" $+ do+ res <-+ parseAndExec+ (QBE.GlobalIdent "varAdd1")+ [D.VWord 1, D.VWord 2]+ "function w $varAdd1(w %a, ...) {\n\+ \@start\n\+ \%ap =l alloc8 8\n\+ \vastart %ap\n\+ \%b =w vaarg %ap\n\+ \%c =w add %a, %b\n\+ \ret %c\n\+ \}"++ res @?= Just (D.VWord 3),+ testCase "variable argument list with no variable argument" $+ do+ res <-+ parseAndExec+ (QBE.GlobalIdent "varAdd1")+ [D.VWord 1, D.VWord 2, D.VWord 2342]+ "function w $varAdd1(w %a, ...) {\n\+ \@start\n\+ \%ap =l alloc8 8\n\+ \vastart %ap\n\+ \ret 0\n\+ \}"++ res @?= Just (D.VWord 0),+ testCase "passing pointer to variable argument list" $+ do+ -- Example from https://c9x.me/compile/doc/il-v1.2.html#Variadic+ res <-+ parseAndExec+ (QBE.GlobalIdent "main")+ []+ "function w $add3(w %a, ...) {\n\+ \@start\n\+ \%ap =l alloc8 32\n\+ \vastart %ap\n\+ \%r =w call $vadd(w %a, l %ap)\n\+ \ret %r\n\+ \}\n\+ \function w $vadd(w %a, l %ap) {\n\+ \@start\n\+ \%b =w vaarg %ap\n\+ \%c =w vaarg %ap\n\+ \%d =w add %a, %b\n\+ \%e =w add %d, %c\n\+ \ret %e\n\+ \}\n\+ \function w $main() {\n\+ \@start\n\+ \%.1 =w copy 23\n\+ \%.2 =w copy 42\n\+ \%.3 =w copy 5\n\+ \%.4 =w call $add3(w %.1, ..., w %.2, w %.3)\n\+ \ret %.4\n\+ \}"++ res @?= Just (D.VWord 70),+ testCase "variable argument list with different argument alignment" $+ do+ res <-+ parseAndExec+ (QBE.GlobalIdent "varAdd")+ [D.VWord 0xdeadbeef, D.VLong 0xdecafbaddecafbad, D.VWord 0xffffffff, D.VDouble 23.1337]+ "function w $varAdd(...) {\n\+ \@start\n\+ \%ap =l alloc8 8\n\+ \vastart %ap\n\+ \%v.1 =w vaarg %ap\n\+ \%v.2 =l vaarg %ap\n\+ \%v.3 =w vaarg %ap\n\+ \%v.4 =d vaarg %ap\n\+ \%e.1 =w ceqw %v.1, 3735928559\n\+ \%e.2 =w ceql %v.2, 16053920545901312941\n\+ \%e.3 =w ceqw %v.3, 4294967295\n\+ \%e.4 =w ceqd %v.4, d_23.1337\n\+ \%r.1 =w and %e.1, %e.2\n\+ \%r.2 =w and %r.1, %e.3\n\+ \%r.3 =w and %r.2, %e.4\n\+ \ret %r.3\n\+ \}"++ res @?= Just (D.VWord 1),+ testCase "execute vastart twice" $+ do+ res <-+ parseAndExec+ (QBE.GlobalIdent "varAdd")+ [D.VWord 0xdeadbeef, D.VLong 0xdecafbaddecafbad, D.VWord 0xffffffff, D.VDouble 23.1337]+ "function w $varAdd(...) {\n\+ \@start\n\+ \%ap =l alloc8 8\n\+ \vastart %ap\n\+ \%p.1 =l loadl %ap\n\+ \vastart %ap\n\+ \%p.2 =l loadl %ap\n\+ \%r.p =w cnel %p.1, %p.2\n\+ \@vaarg\n\+ \%v.1 =w vaarg %ap\n\+ \%v.2 =l vaarg %ap\n\+ \%v.3 =w vaarg %ap\n\+ \%v.4 =d vaarg %ap\n\+ \%e.1 =w ceqw %v.1, 3735928559\n\+ \%e.2 =w ceql %v.2, 16053920545901312941\n\+ \%e.3 =w ceqw %v.3, 4294967295\n\+ \%e.4 =w ceqd %v.4, d_23.1337\n\+ \%r.1 =w and %e.1, %e.2\n\+ \%r.2 =w and %r.1, %e.3\n\+ \%r.3 =w and %r.2, %e.4\n\+ \%r.4 =w and %r.3, %r.p\n\+ \ret %r.4\n\+ \}"++ res @?= Just (D.VWord 1),+ testCase "invoke function via function pointer" $+ do+ res <-+ parseAndExec+ (QBE.GlobalIdent "main")+ []+ "function w $add(w %lhs, w %rhs) {\n\+ \@start\n\+ \%r =w add %lhs, %rhs\n\+ \ret %r\n\+ \}\n\+ \function w $main() {\n\+ \@body\n\+ \%ptr =l copy $add\n\+ \%res =w call %ptr(w 23, w 42)\n\+ \ret %res\n\+ \}"++ res @?= Just (D.VWord 65),+ testCase "__builtin_va from cproc code base" $+ do+ res <-+ parseAndExecFile+ (QBE.GlobalIdent "main")+ []+ "builtin-vaarg-vm.qbe"++ res @?= Just (D.VWord 127),+ testCase "use extern for representing globals" $+ do+ res <-+ parseAndExec+ (QBE.GlobalIdent "main")+ []+ "function w $main() {\n\+ \@body\n\+ \%.1 =w loadw extern $x\n\+ \%.2 =w add %.1, 23\n\+ \ret %.2\n\+ \}\n\+ \export data $x = align 4 { z 4 }\n"++ res @?= Just (D.VWord 23)+ ]++simTests :: TestTree+simTests = testGroup "Tests for the Simulator" [blockTests]
+ test/State.hs view
@@ -0,0 +1,42 @@+-- SPDX-FileCopyrightText: 2026 Sören Tempel <soeren+git@soeren-tempel.net>+--+-- SPDX-License-Identifier: GPL-3.0-only++module State (stateTests) where++import Control.Monad.State.Strict (evalStateT)+import Data.Word (Word8)+import Language.QBE.Simulator.Default.Expression qualified as D+import Language.QBE.Simulator.Default.State (Env, loadObj, mkEnv)+import Language.QBE.Types qualified as QBE+import Test.Tasty+import Test.Tasty.HUnit++stateTests :: TestTree+stateTests =+ testGroup+ "Test the default state implementation"+ [ testCase "loadObj returns end address" $+ do+ let obj = QBE.OItem QBE.Byte [QBE.DString "foobar"]++ env <- mkEnv [] 0x1000 128 :: IO (Env D.RegVal Word8)+ res <- evalStateT (loadObj 0x1000 obj) env++ res @?= 0x1006,+ -- TODO: Turn this into a QuickCheck 'testProperty'.+ testCase "loadObj return value is aligned with QBE.dataSize" $+ do+ let o1 = QBE.OItem QBE.Byte [QBE.DString "foobar"]+ let o2 = QBE.OItem (QBE.Base QBE.Word) [QBE.DConst $ QBE.Number 23]++ env <- mkEnv [] 0x0 128 :: IO (Env D.RegVal Word8)+ res <- evalStateT (loadObj 0x0 o1 >>= flip loadObj o2) env++ -- No padding inserted.+ res @?= 10++ -- The same calculation should be performed by QBE.dataSize.+ let ds = QBE.DataDef [] (QBE.GlobalIdent "d") Nothing [o1, o2]+ 10 @?= QBE.dataSize ds+ ]