diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,43 @@ +-- SPDX-FileCopyrightText: 2025 Sören Tempel +-- +-- 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 + ] + ] diff --git a/qute.cabal b/qute.cabal new file mode 100644 --- /dev/null +++ b/qute.cabal @@ -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 diff --git a/src/Language/QBE/Analysis/CDG.hs b/src/Language/QBE/Analysis/CDG.hs new file mode 100644 --- /dev/null +++ b/src/Language/QBE/Analysis/CDG.hs @@ -0,0 +1,128 @@ +-- SPDX-FileCopyrightText: 2010 Tristan Ravitch +-- SPDX-FileCopyrightText: 2026 Reliable System Software, Technische Universität Braunschweig +-- +-- 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 . 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 diff --git a/src/Language/QBE/Analysis/CFG.hs b/src/Language/QBE/Analysis/CFG.hs new file mode 100644 --- /dev/null +++ b/src/Language/QBE/Analysis/CFG.hs @@ -0,0 +1,154 @@ +-- SPDX-FileCopyrightText: 2025 Sören Tempel +-- SPDX-FileCopyrightText: 2026 Reliable System Software, Technische Universität Braunschweig +-- +-- 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) diff --git a/src/Language/QBE/Analysis/Graph.hs b/src/Language/QBE/Analysis/Graph.hs new file mode 100644 --- /dev/null +++ b/src/Language/QBE/Analysis/Graph.hs @@ -0,0 +1,727 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE Strict #-} +-- SPDX-FileCopyrightText: 2009 Matt Morrow +-- +-- 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) diff --git a/src/Language/QBE/Simulator.hs b/src/Language/QBE/Simulator.hs new file mode 100644 --- /dev/null +++ b/src/Language/QBE/Simulator.hs @@ -0,0 +1,349 @@ +-- SPDX-FileCopyrightText: 2025-2026 Sören Tempel +-- +-- 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 #-} diff --git a/src/Language/QBE/Simulator/Default/Expression.hs b/src/Language/QBE/Simulator/Default/Expression.hs new file mode 100644 --- /dev/null +++ b/src/Language/QBE/Simulator/Default/Expression.hs @@ -0,0 +1,372 @@ +-- SPDX-FileCopyrightText: 2025 Sören Tempel +-- +-- 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 diff --git a/src/Language/QBE/Simulator/Default/Funcs.hs b/src/Language/QBE/Simulator/Default/Funcs.hs new file mode 100644 --- /dev/null +++ b/src/Language/QBE/Simulator/Default/Funcs.hs @@ -0,0 +1,29 @@ +-- SPDX-FileCopyrightText: 2025 Sören Tempel +-- +-- 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 diff --git a/src/Language/QBE/Simulator/Default/Generator.hs b/src/Language/QBE/Simulator/Default/Generator.hs new file mode 100644 --- /dev/null +++ b/src/Language/QBE/Simulator/Default/Generator.hs @@ -0,0 +1,141 @@ +-- SPDX-FileCopyrightText: 2025 Sören Tempel +-- +-- 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 diff --git a/src/Language/QBE/Simulator/Default/State.hs b/src/Language/QBE/Simulator/Default/State.hs new file mode 100644 --- /dev/null +++ b/src/Language/QBE/Simulator/Default/State.hs @@ -0,0 +1,364 @@ +-- SPDX-FileCopyrightText: 2025-2026 Sören Tempel +-- +-- 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: . +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 #-} diff --git a/src/Language/QBE/Simulator/Error.hs b/src/Language/QBE/Simulator/Error.hs new file mode 100644 --- /dev/null +++ b/src/Language/QBE/Simulator/Error.hs @@ -0,0 +1,53 @@ +-- SPDX-FileCopyrightText: 2025 Sören Tempel +-- +-- 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 diff --git a/src/Language/QBE/Simulator/Expression.hs b/src/Language/QBE/Simulator/Expression.hs new file mode 100644 --- /dev/null +++ b/src/Language/QBE/Simulator/Expression.hs @@ -0,0 +1,184 @@ +-- SPDX-FileCopyrightText: 2025 Sören Tempel +-- +-- 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 #-} diff --git a/src/Language/QBE/Simulator/Memory.hs b/src/Language/QBE/Simulator/Memory.hs new file mode 100644 --- /dev/null +++ b/src/Language/QBE/Simulator/Memory.hs @@ -0,0 +1,121 @@ +-- SPDX-FileCopyrightText: 2023-2024 University of Bremen +-- SPDX-FileCopyrightText: 2025 Sören Tempel +-- +-- 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 #-} diff --git a/src/Language/QBE/Simulator/State.hs b/src/Language/QBE/Simulator/State.hs new file mode 100644 --- /dev/null +++ b/src/Language/QBE/Simulator/State.hs @@ -0,0 +1,299 @@ +-- SPDX-FileCopyrightText: 2025-2026 Sören Tempel +-- +-- 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. . +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 . +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 #-} diff --git a/test/Analysis.hs b/test/Analysis.hs new file mode 100644 --- /dev/null +++ b/test/Analysis.hs @@ -0,0 +1,153 @@ +-- SPDX-FileCopyrightText: 2025 Sören Tempel +-- SPDX-FileCopyrightText: 2026 Reliable System Software, Technische Universität Braunschweig +-- +-- 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" + ] diff --git a/test/Expression.hs b/test/Expression.hs new file mode 100644 --- /dev/null +++ b/test/Expression.hs @@ -0,0 +1,104 @@ +-- SPDX-FileCopyrightText: 2025 Sören Tempel +-- +-- 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) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,26 @@ +-- SPDX-FileCopyrightText: 2025 Sören Tempel +-- +-- 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 + ] diff --git a/test/Memory.hs b/test/Memory.hs new file mode 100644 --- /dev/null +++ b/test/Memory.hs @@ -0,0 +1,40 @@ +-- SPDX-FileCopyrightText: 2025 Sören Tempel +-- +-- 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 + ] diff --git a/test/Simulator.hs b/test/Simulator.hs new file mode 100644 --- /dev/null +++ b/test/Simulator.hs @@ -0,0 +1,1281 @@ +-- SPDX-FileCopyrightText: 2025 Sören Tempel +-- +-- 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] diff --git a/test/State.hs b/test/State.hs new file mode 100644 --- /dev/null +++ b/test/State.hs @@ -0,0 +1,42 @@ +-- SPDX-FileCopyrightText: 2026 Sören Tempel +-- +-- 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 + ]