aihc-cpp 1.0.0.2 → 2.0.0.0

raw patch · 19 files changed

+2571/−791 lines, 19 filesdep +hppdep +tasty-benchdep +transformersdep ~aihc-cppdep ~bytestringdep ~containersPVP ok

version bump matches the API change (PVP)

Dependencies added: hpp, tasty-bench, transformers

Dependency ranges changed: aihc-cpp, bytestring, containers

API changes (from Hackage documentation)

Files

• CHANGELOG.md +79/−1
• aihc-cpp.cabal +43/−10
• bench/Bench/Corpus.hs +301/−0
• bench/Micro.hs +692/−0
• bench/include/HsBaseConfig.h +80/−0
• bench/include/MachDeps.h +65/−0
• bench/include/cabal_macros.h +27/−0
• src/Aihc/Cpp.hs +102/−68
• src/Aihc/Cpp/Cursor.hs +25/−31
• src/Aihc/Cpp/Evaluator.hs +417/−258
• src/Aihc/Cpp/Parser.hs +111/−71
• src/Aihc/Cpp/Scanner.hs +218/−285
• src/Aihc/Cpp/Types.hs +100/−8
• test/Spec.hs +286/−58
• test/Test/Fixtures/progress/function-macro-arg-rescan.hs +5/−0
• test/Test/Fixtures/progress/macro-rescan-repeated-name.hs +3/−0
• test/Test/Fixtures/progress/manifest.tsv +7/−0
• test/Test/Fixtures/progress/nested-function-macro-rescan.hs +5/−0
• test/Test/Progress.hs +5/−1

@@ -4,7 +4,85 @@  The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.1.0/). -## [Unreleased]+## [2.0.0.0] - 2026-09-10++### Performance++- Preprocessing the whole Stackage `lts-24.58` corpus is about 3.5x faster —+  one sweep over 5,802 CPP-using modules went from 3.07 s to 0.87 s on the+  same machine, with byte-identical output and diagnostics for every module.+  Net of the file reads every tool pays for, that is 4.5x faster than `cpphs`,+  against 1.12x before. The changes:+  - Macro expansion now scans byte offsets and copies nothing until a macro+    actually expands, so a line that names no macro is returned as the very+    `ByteString` that came in. Previously every line of every module was+    rebuilt one character at a time through a `Builder`.+  - A 64-bit first-byte filter over the macro names rejects an identifier+    that can name no macro without walking the macro map, which is the+    outcome for nearly every identifier in a Haskell module.+  - Token pasting in a function-like macro body no longer appends to the end+    of a list once per token, which was quadratic in the body length and the+    single largest source of allocation.+  - The GCC string-continuation check tests the two trailing bytes of a line+    before scanning it for quote state, removing a full scan from every line;+    and a module that defines no function-like macro skips the multi-line+    call lookahead entirely.+  - Splitting the input into lines uses `memchr` rather than a byte-at-a-time+    walk that allocated a cursor per byte of the input.+  - The line scanner works on byte offsets rather than a cursor per byte, and+    a line that opens no comment — nearly every line — is recognised by a+    loop over unboxed arguments and returned as a single span, skipping the+    accumulator-threading scanner entirely.+  - Loop-carried `where` bindings that only some branches use were thunks+    allocated once per byte and once per identifier scanned; they are now+    forced or pushed into the branch that needs them.++### Changed++- **Breaking:** the preprocessor is now agnostic to the source encoding.+  `resultOutput` is a `ByteString` rather than `Text`, and `configMacros`+  is keyed by `ByteString`. Bytes the preprocessor did not generate itself+  are copied from input to output verbatim, so a module in any encoding —+  or in no consistent encoding — passes through unchanged. Nothing but+  `Diagnostic` message text is ever decoded.++  To migrate, decode at the boundary if you want `Text`:+  `Data.Text.Encoding.decodeUtf8With Data.Text.Encoding.Error.lenientDecode (resultOutput r)`.++### Fixed++- `preprocess` no longer throws an impure exception on source that is not+  valid UTF-8 (for example a Latin-1 encoded module containing byte `0xa9`,+  as shipped in Ebnf2ps). Previously `Data.Text.Encoding.decodeUtf8` raised+  from inside a pure function, escaping the `Diagnostic` mechanism the API+  otherwise uses; such bytes now simply pass through. GHC accepts an+  undecodable byte in a comment and rejects one where a token must be+  lexed, so this leaves the encoding decision to the compiler front-end+  instead of failing modules that genuinely compile.+- Whitespace and identifier classification is now ASCII-only. Using+  `Data.Char.isSpace` on a byte treated `0xA0` — an ordinary UTF-8+  continuation byte — as whitespace, which could split a multi-byte+  character in half.+- Macro arguments are now expanded before substitution, so a function-like+  macro invocation produced by an expansion is rescanned and expanded, matching+  GHC's C preprocessor and `cpphs`. The C standard's non-recursive-expansion+  rule is honoured, so a macro is never expanded inside its own expansion.+- A pragma nested inside a Haskell block comment no longer terminates that+  comment. `{-#` is treated as a pragma delimiter only outside a comment;+  inside one it counts as an ordinary nested `{-`, balancing the `-}` of the+  closing `#-}`. Previously each such pragma decremented the comment depth,+  making CPP directives in the rest of the commented-out region live —+  producing spurious `unmatched #endif` warnings and, with a commented-out+  `#if 0`, silently dropping the comment's contents+  ([#1](https://github.com/ai-haskell-compiler/aihc-cpp/issues/1)).++## [1.0.0.3] - 2026-07-26++### Changed++- Moved development to the standalone+  [`ai-haskell-compiler/aihc-cpp`](https://github.com/ai-haskell-compiler/aihc-cpp)+  repository, including the full test and compatibility CI configuration.  ## [1.0.0.2] - 2026-05-27 

@@ -1,11 +1,12 @@ cabal-version: 3.8 name: aihc-cpp-version: 1.0.0.2+version: 2.0.0.0 build-type: Simple license: Unlicense license-file: LICENSE extra-doc-files: CHANGELOG.md extra-source-files:+  bench/include/*.h   test/Test/Fixtures/progress/*.hs   test/Test/Fixtures/progress/*.tsv   test/Test/Fixtures/progress/includes/*.inc@@ -19,13 +20,12 @@   package provides deterministic preprocessing with include continuations and   oracle-backed tests against cpphs. -homepage: https://github.com/ai-haskell-compiler/aihc/tree/main/components/aihc-cpp-bug-reports: https://github.com/ai-haskell-compiler/aihc/issues+homepage: https://github.com/ai-haskell-compiler/aihc-cpp+bug-reports: https://github.com/ai-haskell-compiler/aihc-cpp/issues  source-repository head   type: git-  location: https://github.com/ai-haskell-compiler/aihc.git-  subdir: components/aihc-cpp+  location: https://github.com/ai-haskell-compiler/aihc-cpp.git  library   exposed-modules:@@ -41,8 +41,8 @@   hs-source-dirs: src   build-depends:     base >=4.16 && <5,-    bytestring >=0.10.8 && <0.13,-    containers >=0.5 && <0.8,+    bytestring >=0.11 && <0.13,+    containers >=0.5 && <0.9,     deepseq >=1.4 && <1.6,     filepath >=1.3.0.1 && <1.6,     text >=1.2 && <2.2,@@ -58,10 +58,10 @@     Test.Progress    build-depends:-    aihc-cpp >=1.0 && <1.1,+    aihc-cpp >=2.0 && <2.1,     base >=4.16 && <5,-    bytestring >=0.10.8 && <0.13,-    containers >=0.5 && <0.8,+    bytestring >=0.11 && <0.13,+    containers >=0.5 && <0.9,     cpphs >=1.20 && <1.21,     directory >=1.2.3 && <1.5,     filepath >=1.3.0.1 && <1.6,@@ -71,4 +71,37 @@     text >=1.2 && <2.2,    ghc-options: -Wall+  default-language: Haskell2010++benchmark micro+  type: exitcode-stdio-1.0+  hs-source-dirs: bench+  main-is: Micro.hs+  other-modules: Bench.Corpus+  build-depends:+    aihc-cpp >=2.0 && <2.1,+    base >=4.16 && <5,+    bytestring >=0.10.8 && <0.13,+    containers >=0.5 && <0.9,+    cpphs >=1.20 && <1.21,+    deepseq >=1.4 && <1.6,+    directory >=1.2.3 && <1.5,+    filepath >=1.3.0.1 && <1.6,+    hpp >=0.6 && <0.7,+    tasty-bench >=0.4 && <0.5,+    text >=1.2 && <2.2,+    transformers >=0.5 && <0.7,++  -- -M caps the heap so an oversized corpus fails with a clear heap-overflow+  -- message instead of driving the machine into swap or the OOM killer.+  -- -M caps the heap so a runaway corpus fails with a clear heap-overflow+  -- message rather than driving the machine into swap. -rtsopts lets a full+  -- snapshot sweep raise it: too low a cap does not merely abort, it makes a+  -- tool thrash against the limit and look far slower than it is.+  ghc-options:+    -Wall+    -O2+    -rtsopts+    "-with-rtsopts=-A32m -M1024m -T"+   default-language: Haskell2010

@@ -0,0 +1,301 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Deterministic corpus generation for the aihc-cpp benchmarks.+--+-- The corpus is generated rather than committed so that it can be resized+-- without churning the repository, and it is fully deterministic so that two+-- runs on two machines benchmark byte-identical inputs.+--+-- The cases are chosen to isolate the different costs a preprocessor pays, so+-- that a regression can be attributed to one of them rather than showing up as+-- a single number that moved.+--+-- This corpus is artificial, and it is worth being explicit about where it+-- departs from reality. Measured over 1,631 CPP-using modules from 211 Hackage+-- packages: the median module is 6.2KB with 3.5% directive lines; conditionals+-- dominate the directive mix (@#if@ and @#endif@ together outnumber @#define@+-- by more than ten to one); @__GLASGOW_HASKELL__@, @MIN_VERSION_base@ and+-- @mingw32_HOST_OS@ account for most macro references, nearly all of them+-- inside @#if@ conditions rather than expanded into the output; and a module+-- that includes anything usually includes one or two headers.+--+-- So 'passthroughCase' and 'conditionalsCase' are close to real code, while+-- 'macrosCase' (a function-like macro expanded on every line) and+-- 'includesCase' (24 included files) are far heavier than anything real.+-- They are useful for isolating a cost, and misleading if read as a workload.+-- Point the benchmark at real source instead — see the AIHC_CPP_BENCH_CORPUS+-- setting in @bench\/Micro.hs@ — before drawing conclusions about throughput.+module Bench.Corpus+  ( CorpusCase (..),+    corpusCases,+    generateCorpus,+    defaultCorpusRoot,+  )+where++import System.Directory (createDirectoryIfMissing)+import System.FilePath ((</>))++-- | Where the generated corpus goes by default.+--+-- Deliberately outside @src@, @test@, @app@ and @bench@, the directories the+-- formatter and linter walk. A generated corpus is megabytes of machine-written+-- Haskell full of redundant brackets, and hlint follows @#include@ directives,+-- so letting a linter reach it produces six-figure hint counts and exhausts+-- memory. Putting it under @dist-newstyle@ makes that structurally impossible+-- rather than depending on an exclusion pattern staying correct, and means+-- @cabal clean@ disposes of it.+defaultCorpusRoot :: FilePath+defaultCorpusRoot = "dist-newstyle" </> "bench-corpus"++-- | One benchmark input: a top-level file plus any files it includes.+data CorpusCase = CorpusCase+  { -- | Short identifier, also the basename of the generated file.+    caseName :: !String,+    -- | Human-readable note about what this case stresses.+    caseDescription :: !String,+    -- | Path of the entry file, relative to the corpus root.+    caseEntry :: !FilePath,+    -- | All files to write, relative to the corpus root.+    caseFiles :: [(FilePath, String)]+  }++-- | Rough target size, in lines, for each generated case.+--+-- Large enough that a single run takes milliseconds rather than microseconds,+-- so the measurement is not dominated by timer resolution, and small enough+-- that a full sweep of three preprocessors stays interactive.+caseLines :: Int+caseLines = 4000++-- | The benchmark corpus.+--+-- The mix is deliberately weighted towards 'passthrough', because that is what+-- real CPP-using Haskell looks like: a few directives at the top and thousands+-- of lines the preprocessor merely has to copy. The remaining cases isolate+-- individual costs so a regression can be attributed.+corpusCases :: [CorpusCase]+corpusCases =+  [ passthroughCase,+    conditionalsCase,+    macrosCase,+    literalsCase,+    includesCase+  ]++-- | Write the corpus under the given root directory.+generateCorpus :: FilePath -> IO ()+generateCorpus root = do+  createDirectoryIfMissing True root+  createDirectoryIfMissing True (root </> "includes")+  mapM_ writeCase corpusCases+  where+    writeCase c = mapM_ writeOne (caseFiles c)+    writeOne (path, contents) = writeFile (root </> path) contents++-- ---------------------------------------------------------------------------+-- Deterministic pseudo-randomness+-- ---------------------------------------------------------------------------++-- | A tiny linear congruential generator (the Numerical Recipes constants).+--+-- Avoids a dependency on @random@ and, more importantly, pins the corpus to an+-- exact byte sequence that does not drift between library versions.+lcg :: Int -> Int+lcg s = (s * 1664525 + 1013904223) `mod` 2147483648++-- | An infinite deterministic stream of values drawn from a list.+pick :: Int -> [a] -> [a]+pick seed xs = go seed+  where+    n = length xs+    go s = let s' = lcg s in (xs !! (s' `mod` n)) : go s'++-- ---------------------------------------------------------------------------+-- Cases+-- ---------------------------------------------------------------------------++-- | Ordinary Haskell with a realistic sprinkling of directives.+--+-- Roughly 5% directive lines, with the rest simply copied through. This is the+-- case that best predicts the cost a preprocessor adds to a real compile, and+-- the one to weight most heavily when reading the results.+passthroughCase :: CorpusCase+passthroughCase =+  CorpusCase+    { caseName = "passthrough",+      caseDescription = "realistic module: ~5% directives, the rest copied through",+      caseEntry = "passthrough.hs",+      caseFiles = [("passthrough.hs", body)]+    }+  where+    body = unlines (header <> concat (take (caseLines `div` 20) chunks))+    header =+      [ "{-# LANGUAGE CPP #-}",+        "module Passthrough where",+        "#define VERSION_base 1",+        "#define HAS_FEATURE(x) (x)"+      ]+    chunks = zipWith chunk [0 :: Int ..] (pick 1 [0 .. 9 :: Int])+    chunk i r =+      [ "",+        "-- | Documentation for value " <> show i <> ".",+        "value" <> show i <> " :: Int -> Int",+        "value" <> show i <> " x = x + " <> show (r * i `mod` 97),+        "",+        "helper" <> show i <> " :: [Int] -> Int",+        "helper" <> show i <> " xs = sum (map value" <> show i <> " xs)",+        ""+      ]+        <> ( if i `mod` 5 == 0+               then+                 [ "#ifdef VERSION_base",+                   "guarded" <> show i <> " :: Int",+                   "guarded" <> show i <> " = " <> show i,+                   "#else",+                   "guarded" <> show i <> " :: Int",+                   "guarded" <> show i <> " = 0",+                   "#endif"+                 ]+               else+                 [ "plain" <> show i <> " :: Int",+                   "plain" <> show i <> " = " <> show i+                 ]+           )+        <> replicate 8 ("-- filler comment line for value " <> show i)++-- | Dense, deeply nested conditionals with arithmetic and @defined@.+conditionalsCase :: CorpusCase+conditionalsCase =+  CorpusCase+    { caseName = "conditionals",+      caseDescription = "nested #if/#elif/#else with arithmetic and defined()",+      caseEntry = "conditionals.hs",+      caseFiles = [("conditionals.hs", body)]+    }+  where+    body = unlines (header <> concatMap block [0 .. caseLines `div` 16])+    header =+      [ "{-# LANGUAGE CPP #-}",+        "module Conditionals where",+        "#define MAJOR 9",+        "#define MINOR 12",+        "#define GLASGOW_HASKELL 912",+        "#define WORD_SIZE_IN_BITS 64"+      ]+    block i =+      [ "#if MAJOR > 8 && MINOR >= 4",+        "#  if defined(GLASGOW_HASKELL) && GLASGOW_HASKELL >= 900",+        "#    if WORD_SIZE_IN_BITS == 64",+        "cond" <> show i <> " :: Int",+        "cond" <> show i <> " = " <> show i,+        "#    else",+        "cond" <> show i <> " :: Int",+        "cond" <> show i <> " = 0",+        "#    endif",+        "#  elif defined(MISSING)",+        "cond" <> show i <> " = -1",+        "#  else",+        "cond" <> show i <> " = -2",+        "#  endif",+        "#else",+        "cond" <> show i <> " = -3",+        "#endif"+      ]++-- | Heavy object- and function-like macro expansion.+macrosCase :: CorpusCase+macrosCase =+  CorpusCase+    { caseName = "macros",+      caseDescription = "object- and function-like macro expansion on every line",+      caseEntry = "macros.hs",+      caseFiles = [("macros.hs", body)]+    }+  where+    body = unlines (header <> concatMap block [0 .. caseLines `div` 6])+    header =+      [ "{-# LANGUAGE CPP #-}",+        "module Macros where",+        "#define MIN_VERSION_base(a,b,c) 1",+        "#define WRAP(x) (fromIntegral (x))",+        "#define PAIR(a,b) ((a), (b))",+        "#define NAME base",+        "#define WIDE(a,b,c,d) ((a) + (b) + (c) + (d))"+      ]+    block i =+      [ "macro" <> show i <> " :: Int",+        "macro" <> show i <> " = WRAP(" <> show i <> ")",+        "pair" <> show i <> " = PAIR(" <> show i <> ", " <> show (i + 1) <> ")",+        "wide" <> show i <> " = WIDE(" <> show i <> ", 2, 3, 4)",+        "#if MIN_VERSION_base(4,16,0)",+        "gated" <> show i <> " = WRAP(" <> show i <> ")",+        "#endif"+      ]++-- | String, character and comment heavy input.+--+-- Haskell-aware preprocessors track Haskell block comments and string literals+-- so they can avoid expanding macros inside them. That scanning is real work,+-- and the three implementations do differing amounts of it, so it gets its own+-- case rather than quietly taxing the average of the others.+literalsCase :: CorpusCase+literalsCase =+  CorpusCase+    { caseName = "literals",+      caseDescription = "string/char literals and Haskell comments (macro-suppression scanning)",+      caseEntry = "literals.hs",+      caseFiles = [("literals.hs", body)]+    }+  where+    body = unlines (header <> concatMap block [0 .. caseLines `div` 8])+    header =+      [ "{-# LANGUAGE CPP #-}",+        "module Literals where",+        "#define NAME notExpandedInStrings"+      ]+    block i =+      [ "text" <> show i <> " :: String",+        "text" <> show i <> " = \"NAME must not be expanded here \" ++ show " <> show i,+        "chars" <> show i <> " = ['N', 'A', 'M', 'E']",+        "{- NAME inside a Haskell block comment",+        "   spanning several lines, still NAME -}",+        "prime" <> show i <> "' = " <> show i <> " -- NAME in a line comment",+        "escaped" <> show i <> " = \"a \\\"NAME\\\" quoted\"",+        ""+      ]++-- | An include chain, exercising the continuation-based include protocol.+includesCase :: CorpusCase+includesCase =+  CorpusCase+    { caseName = "includes",+      caseDescription = "chain of #include files resolved through the continuation API",+      caseEntry = "includes.hs",+      caseFiles = ("includes.hs", entry) : map leaf [0 .. leafCount - 1]+    }+  where+    leafCount = 24 :: Int+    entry =+      unlines+        ( [ "{-# LANGUAGE CPP #-}",+            "module Includes where"+          ]+            <> ["#include \"includes/part" <> show n <> ".inc\"" | n <- [0 .. leafCount - 1]]+        )+    leaf n =+      ( "includes" </> ("part" <> show n <> ".inc"),+        unlines+          ( [ "#ifndef PART" <> show n,+              "#define PART" <> show n <> " 1",+              "#define PART" <> show n <> "_VALUE(x) ((x) + " <> show n <> ")"+            ]+              <> concat+                [ [ "part" <> show n <> "_" <> show k <> " :: Int",+                    "part" <> show n <> "_" <> show k <> " = PART" <> show n <> "_VALUE(" <> show k <> ")"+                  ]+                | k <- [0 .. (caseLines `div` leafCount) - 1 :: Int]+                ]+              <> ["#endif"]+          )+      )

@@ -0,0 +1,692 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Raw throughput of aihc-cpp against the other two pure-Haskell C+-- preprocessors on Hackage, hpp and cpphs.+--+-- All three run in-process as libraries, on the same preloaded bytes, with+-- their output forced. Nothing but preprocessing is timed: no process startup,+-- no reading the entry file, no lazy IO left unevaluated.+--+-- This deliberately does not check that the three agree. Preprocessing Haskell+-- is under-specified — the tools differ on comment handling, on rescanning, on+-- what survives inside a literal — and demanding equivalence would mean either+-- excluding the interesting inputs or holding aihc-cpp to another+-- implementation's accidents. The test suite is where behaviour is pinned down;+-- this is where speed is.+--+-- Two corpora are available:+--+-- * The default is generated (see "Bench.Corpus"): deterministic and cheap,+--   good for spotting regressions, but artificial. Its shape is a guess at what+--   real code looks like, and a guess written by the same people who wrote the+--   preprocessor being measured.+-- * Setting @AIHC_CPP_BENCH_CORPUS@ to a directory of Haskell source+--   benchmarks every CPP-using module found under it. That is the number to+--   trust when the question is throughput on real work.+module Main (main) where++import Aihc.Cpp+  ( Config (..),+    Diagnostic (..),+    IncludeRequest (..),+    Result (..),+    Severity (..),+    Step (..),+    defaultConfig,+    preprocess,+  )+import Bench.Corpus (CorpusCase (..), corpusCases, defaultCorpusRoot, generateCorpus)+import Control.DeepSeq (NFData, force)+import Control.Exception (AsyncException, SomeException, evaluate, fromException, throwIO, try)+import Control.Monad (foldM)+import Control.Monad.Trans.Except (runExceptT)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS8+import Data.Char (isAlpha, isSpace, toLower)+import Data.Either (fromRight, rights)+import Data.List (isPrefixOf, isSuffixOf, sort, sortOn)+import qualified Data.Map.Strict as M+import Data.Maybe (fromMaybe)+import qualified Data.Text as T+import GHC.Clock (getMonotonicTime)+import GHC.Generics (Generic)+import qualified Hpp+import qualified Hpp.Config as HppConfig+import Language.Preprocessor.Cpphs+  ( BoolOptions (..),+    CpphsOptions (..),+    defaultCpphsOptions,+    runCpphs,+  )+import System.Directory (doesDirectoryExist, doesFileExist, listDirectory)+import System.Environment (lookupEnv)+import System.FilePath (splitDirectories, takeDirectory, takeExtension, (</>))+import System.IO (BufferMode (LineBuffering), hSetBuffering, stdout)+import System.IO.Unsafe (unsafePerformIO)+import Test.Tasty.Bench (Benchmark, bench, bgroup, defaultMain, nfIO)++-- | Which corpus to benchmark.+data Corpus+  = -- | The generated corpus, in a directory this program owns.+    Generated FilePath+  | -- | Real modules discovered under a directory the user supplied.+    RealWorld FilePath++-- | Read the corpus choice from the environment.+--+-- A user-supplied directory is only ever read from. An earlier version called+-- 'generateCorpus' on whatever path this variable named, which overwrote files+-- in that directory and then benchmarked the generated corpus while appearing+-- to honour the setting.+selectCorpus :: IO Corpus+selectCorpus = maybe (Generated defaultCorpusRoot) RealWorld <$> lookupEnv "AIHC_CPP_BENCH_CORPUS"++-- | How many bytes of source to preload, in total.+--+-- The corpus is held in memory three times over, once in each preprocessor's+-- input type, and a Haskell 'String' costs upwards of sixteen bytes per+-- character — so a few megabytes of source becomes a few hundred megabytes of+-- residency. Only the bytes are held now (see 'tools'), so the budget buys+-- much more coverage than it used to, but outputs and collector headroom still+-- scale with it: 8MB samples several hundred modules, 16MB samples about+-- eleven hundred and peaks near 590MB against the 512MB heap cap this binary+-- carries. Raise it for wider coverage and lower it if the cap is ever hit.+byteBudget :: IO Int+byteBudget = maybe defaultBudget read <$> lookupEnv "AIHC_CPP_BENCH_MAX_BYTES"+  where+    defaultBudget = 8 * 1024 * 1024++-- | Every @.hs@ file under a directory, as packed paths.+--+-- Iterative rather than recursive, with the accumulator forced as it goes, and+-- paths held as 'BS.ByteString' rather than 'FilePath'. Both matter at snapshot+-- scale: a full Stackage checkout is fifty thousand modules under a tree of+-- several hundred thousand entries, and a Haskell 'String' path costs around+-- two kilobytes, so keeping them unpacked exhausted the heap before the walk+-- finished.+listHsFiles :: FilePath -> IO [BS.ByteString]+listHsFiles root = sort <$> go [BS8.pack root] []+  where+    go [] acc = pure acc+    go (dir : queue) acc = do+      let dirPath = BS8.unpack dir+      entries <- fromRight [] <$> tryIO (listDirectory dirPath)+      (dirs, files) <- foldM (classify dirPath) ([], []) entries+      go (dirs <> queue) $! foldl (flip (:)) acc files+    classify dirPath (dirs, files) entry+      | "." `isPrefixOf` entry = pure (dirs, files)+      | otherwise = do+          let path = dirPath </> entry+          isDir <- doesDirectoryExist path+          pure $+            if isDir+              then (BS8.pack path : dirs, files)+              else (dirs, if ".hs" `isSuffixOf` entry then BS8.pack path : files else files)+    tryIO :: IO a -> IO (Either SomeException a)+    tryIO = try++-- | Choose the modules to benchmark: CPP-using, within the byte budget.+--+-- Candidates are examined at an even stride through the sorted file list rather+-- than from the front, so the sample spans the whole tree instead of stopping+-- inside whichever package sorts first, and only the candidates are read.+-- Deterministic, so two runs measure the same modules.+selectModules :: Int -> [BS.ByteString] -> IO [FilePath]+selectModules budget paths = take' budget (every stride paths)+  where+    -- Bound how many files are opened just to find out whether they use CPP,+    -- while still examining enough of them to fill the budget: roughly one+    -- module in ten uses CPP, and the median one is a few kilobytes.+    candidates = max 4000 (budget `div` 256)+    stride = max 1 (length paths `div` candidates)+    every n xs = case xs of+      [] -> []+      (x : rest) -> x : every n (drop (n - 1) rest)+    take' _ [] = pure []+    take' remaining (packed : rest)+      | remaining <= 0 = pure []+      | otherwise = do+          let path = BS8.unpack packed+          bytes <- fromRight BS.empty <$> (try (BS.readFile path) :: IO (Either SomeException BS.ByteString))+          if usesCpp bytes+            then (path :) <$> take' (remaining - BS.length bytes) rest+            else take' remaining rest++-- | Does this source actually contain preprocessor directives?+--+-- Modules without them would measure nothing but the cost of copying bytes,+-- which all three tools do at much the same speed and which no one is trying to+-- optimise.+usesCpp :: BS.ByteString -> Bool+usesCpp = any isDirective . BS8.lines+  where+    isDirective line = case BS8.uncons (dropBlanks line) of+      Just ('#', rest) -> any (`BS.isPrefixOf` dropBlanks rest) directives+      _ -> False+    dropBlanks = BS8.dropWhile (`elem` (" \t" :: String))+    directives =+      ["if", "ifdef", "ifndef", "elif", "else", "endif", "define", "undef", "include"]++-- | An input, identified by path, with the include path it should be given.+--+-- Nothing is preloaded. Each tool reads the file inside the timed region and+-- discards it, so peak memory is one module rather than the whole corpus and+-- there is no ceiling on how much of a snapshot can be measured. The read is+-- charged to every tool equally and quantified by the @(read only)@ row.+--+-- The include path is resolved once here rather than per tool, so all three are+-- given exactly the same one.+data Prepared = Prepared+  { prepPath :: !FilePath,+    prepSearch :: ![FilePath]+  }++-- | What one tool did with one module.+data Outcome = Outcome+  { -- | Bytes of output produced.+    outBytes :: !Int,+    -- | The tool produced output but reported an error in the source.+    outError :: !(Maybe String)+  }+  deriving (Generic, NFData)++-- | The three preprocessors behind one interface, plus the cost of feeding one.+--+-- The two parenthesised entries are not competitors. @(read only)@ is the file+-- read every tool pays for; @(read + String)@ adds the 'String' conversion that+-- cpphs's API demands. Subtract the matching baseline from a tool to compare+-- preprocessing rather than plumbing.+--+-- Each forces its output completely and returns the length, so that no tool+-- benefits from leaving a lazy structure unevaluated and all three are charged+-- for producing the whole result, and each converts the input into the shape+-- its own API demands inside the timed region.+tools :: [(String, Prepared -> IO Outcome)]+tools =+  [ ( "aihc-cpp",+      \p -> do+        source <- BS.readFile (prepPath p)+        result <- runAihc (prepSearch p) (prepPath p) source+        -- aihc-cpp reports a bad directive or an unresolvable include as a+        -- diagnostic and still returns output; hpp and cpphs throw. Reporting+        -- these separately from crashes keeps that difference visible instead+        -- of turning it into a robustness claim in either direction.+        let firstError = case [d | d <- resultDiagnostics result, diagSeverity d == Error] of+              (d : _) -> Just (T.unpack (diagMessage d))+              [] -> Nothing+        flip Outcome firstError . BS.length <$> evaluate (force (resultOutput result))+    ),+    ( "hpp",+      \p -> do+        source <- BS.readFile (prepPath p)+        out <- hpp (prepSearch p) p (BS8.lines source)+        flip Outcome Nothing . sum . map BS.length <$> evaluate (force out)+    ),+    ( "cpphs",+      \p -> do+        source <- BS.readFile (prepPath p)+        out <- runCpphs (cpphsOptions (prepSearch p)) (prepPath p) (BS8.unpack source)+        flip Outcome Nothing . length <$> evaluate (force out)+    ),+    ( "(read only)",+      \p -> flip Outcome Nothing . BS.length <$> BS.readFile (prepPath p)+    ),+    ( "(read + String)",+      \p -> do+        source <- BS.readFile (prepPath p)+        flip Outcome Nothing . length <$> evaluate (force (BS8.unpack source))+    )+  ]++main :: IO ()+main = do+  hSetBuffering stdout LineBuffering+  corpus <- selectCorpus+  case corpus of+    Generated root -> do+      generateCorpus root+      declared <- packageIncludeDirs root+      prepared <- mapM (prepare declared root . (root </>) . caseEntry) corpusCases+      mapM_ reportOne (zip corpusCases prepared)+      defaultMain+        [ bgroup (caseName c) [bench name (nfIO (run p)) | (name, run) <- tools]+        | (c, p) <- zip corpusCases prepared+        ]+    RealWorld root -> do+      warnMissingStubs+      declared <- packageIncludeDirs root+      putStrLn ("include-dirs: declared by " <> show (M.size (M.filter (not . null) declared)) <> " packages")+      found <- listHsFiles root+      full <- lookupEnv "AIHC_CPP_BENCH_SWEEP"+      selected <- lookupEnv "AIHC_CPP_BENCH_TOOLS"+      let chosen = case selected of+            Nothing -> tools+            Just names -> [t | t@(name, _) <- tools, name `elem` splitOn ',' names]+      case full of+        Just _ -> fullSweep chosen =<< mapM (prepare declared root) =<< allCppModules found+        Nothing -> do+          budget <- byteBudget+          prepared <- mapM (prepare declared root) =<< selectModules budget found+          reportCorpus (length found) prepared+          defaultMain [bgroup "real-world" (map (sweep prepared) chosen)]++splitOn :: Char -> String -> [String]+splitOn sep str = case break (== sep) str of+  (chunk, []) -> [chunk]+  (chunk, _ : rest) -> chunk : splitOn sep rest++-- | Preprocess every CPP-using module in the corpus, once, per tool.+--+-- The sampled benchmark above exists to catch regressions and needs repeated+-- runs for its statistics, which puts a practical ceiling on corpus size. This+-- answers a different question — how does each tool fare across a whole+-- snapshot — and so takes one pass over everything and reports wall clock and+-- throughput rather than a distribution.+fullSweep :: [(String, Prepared -> IO Outcome)] -> [Prepared] -> IO ()+fullSweep chosen prepared = do+  corpusBytes <- sum <$> mapM (fmap BS.length . BS.readFile . prepPath) prepared+  putStrLn+    ( "full sweep: "+        <> show (length prepared)+        <> " CPP-using modules, "+        <> show (corpusBytes `div` (1024 * 1024))+        <> " MiB"+    )+  putStrLn ""+  putStrLn+    ( pad 18 "tool"+        <> pad 9 "ok"+        <> pad 9 "errored"+        <> pad 9 "crashed"+        <> pad 11 "seconds"+        <> pad 11 "MiB out"+        <> "MiB/s"+    )+  putStrLn (replicate 74 '-')+  mapM_ (one corpusBytes) chosen+  where+    one corpusBytes (name, run) = do+      start <- getMonotonicTime+      -- Folded strictly, keeping only counters and the first few failures.+      -- Retaining every outcome kept each failure's exception alive, and with+      -- it whatever the exception's message had captured.+      tally <- foldM (step run) (Tally 0 0 0 0 [] M.empty) prepared+      elapsed <- subtract start <$> getMonotonicTime+      let mib = fromIntegral corpusBytes / 1048576 :: Double+      putStrLn+        ( pad 18 name+            <> pad 9 (show (tallyOk tally))+            <> pad 9 (show (tallyErrored tally))+            <> pad 9 (show (tallyCrashed tally))+            <> pad 11 (showFixed 2 elapsed)+            <> pad 11 (showFixed 1 (fromIntegral (tallyBytes tally) / 1048576 :: Double))+            <> showFixed 1 (mib / elapsed)+        )+      mapM_ (\msg -> putStrLn ("    " <> msg)) (reverse (tallyFailures tally))+      mapM_ reportError (take 12 (sortOn (negate . snd) (M.toList (tallyErrors tally))))+    reportError (msg, n) = putStrLn ("    " <> pad 6 (show n) <> msg)+    step run tally p = do+      outcome <- tryTool (run p)+      pure $! case outcome of+        Right o -> case outError o of+          Just msg ->+            tally+              { tallyErrored = tallyErrored tally + 1,+                tallyBytes = tallyBytes tally + outBytes o,+                tallyErrors = M.insertWith (+) (generalise msg) 1 (tallyErrors tally)+              }+          Nothing -> tally {tallyOk = tallyOk tally + 1, tallyBytes = tallyBytes tally + outBytes o}+        Left err ->+          tally+            { tallyCrashed = tallyCrashed tally + 1,+              tallyFailures = keepFew (prepPath p <> ": " <> show err) (tallyFailures tally)+            }+    keepFew msg msgs+      | length msgs >= 3 = msgs+      | otherwise = length msg `seq` (msg : msgs)+    pad n str = str <> replicate (max 1 (n - length str)) ' '+    showFixed places x =+      let scaled = round (x * 10 ^ places) :: Integer+          (whole, frac) = scaled `divMod` (10 ^ places)+       in show whole <> "." <> pad0 places (show frac)+    pad0 n str = replicate (n - length str) '0' <> str++-- | Collapse the varying part of a diagnostic so like messages group together.+generalise :: String -> String+generalise msg = case break (== ':') msg of+  (prefix, ':' : _) | prefix `elem` grouped -> prefix <> ": <name>"+  _ -> msg+  where+    grouped = ["missing include", "unterminated conditional", "unknown directive"]++-- | Running counts for one tool's pass over the corpus.+data Tally = Tally+  { tallyOk :: !Int,+    tallyErrored :: !Int,+    tallyCrashed :: !Int,+    tallyBytes :: !Int,+    tallyFailures :: [String],+    -- | How often each distinct error diagnostic was reported.+    tallyErrors :: !(M.Map String Int)+  }++-- | Every CPP-using module, with no sampling and no budget.+allCppModules :: [BS.ByteString] -> IO [FilePath]+allCppModules = fmap reverse . foldM check []+  where+    check acc packed = do+      let path = BS8.unpack packed+      bytes <- fromRight BS.empty <$> (try (BS.readFile path) :: IO (Either SomeException BS.ByteString))+      pure $! if usesCpp bytes then path : acc else acc++-- | Preprocess every module in the corpus, as one benchmark.+--+-- Real modules have a median size of a few kilobytes: too small to time+-- individually, and there are far too many to list separately. Timing the whole+-- set at once is also the workload that matters — what a build pays across a+-- project, not what one module costs.+sweep :: [Prepared] -> (String, Prepared -> IO Outcome) -> Benchmark+sweep prepared (name, run) =+  bench name (nfIO (foldM step 0 prepared))+  where+    step !acc p = (acc +) <$> safely (run p)++-- | Run a preprocessor, treating a failure of its own as zero output.+--+-- Real modules routinely reference headers that are not present and macros that+-- are never defined, and the three tools disagree about which of those is+-- fatal. A crash must not abort the sweep, but it does mean less work was done,+-- which is why the failure counts are reported alongside the timings.+safely :: IO Outcome -> IO Int+safely act = either (const 0) outBytes <$> tryTool act++-- | Catch what a preprocessor does wrong, not what the runtime does.+--+-- A plain @try \@SomeException@ also catches heap and stack overflow, which+-- turned a benchmark run that was simply given too little memory into a report+-- of hundreds of \"tool failures\" — and the tool that tripped the limit looked+-- slow rather than starved. Runtime exhaustion is a problem with how the+-- benchmark was run, so it is re-thrown and aborts the run loudly.+tryTool :: IO a -> IO (Either SomeException a)+tryTool act = do+  outcome <- try act+  case outcome of+    Left err | Just async <- fromException err -> throwIO (async :: AsyncException)+    _ -> pure outcome++prepare :: M.Map FilePath [FilePath] -> FilePath -> FilePath -> IO Prepared+prepare declared root path = pure (Prepared path (searchPathFor declared root path))++-- | Describe the discovered corpus, and how much of it each tool can handle.+reportCorpus :: Int -> [Prepared] -> IO ()+reportCorpus found prepared = do+  corpusBytes <- sum <$> mapM (fmap BS.length . BS.readFile . prepPath) prepared+  putStrLn+    ( "real-world corpus: "+        <> show (length prepared)+        <> " of "+        <> show found+        <> " sampled CPP-using modules, "+        <> show (corpusBytes `div` 1024)+        <> " KiB (raise AIHC_CPP_BENCH_MAX_BYTES to widen)"+    )+  mapM_ report tools+  where+    report (name, run) = do+      outcomes <- mapM (\p -> (,) (prepPath p) <$> tryTool (run p)) prepared+      let failed = [(path, show err) | (path, Left err) <- outcomes]+          produced = sum (map outBytes (rights (map snd outcomes)))+      putStrLn+        ( "  "+            <> name+            <> ": "+            <> show (length prepared - length failed)+            <> " ok, "+            <> show (length failed)+            <> " failed, "+            <> show (produced `div` 1024)+            <> " KiB out"+        )+      -- Name the first few failures. A tool that crashes on real input is+      -- doing less work than the others, and if it is aihc-cpp it is a bug+      -- report rather than a benchmark result.+      mapM_ (\(path, err) -> putStrLn ("      failed: " <> path <> ": " <> err)) (take 3 failed)++-- | Print how much output each tool produces on a generated case.+--+-- Not a correctness check. It is here so a wildly faster result is not mistaken+-- for a win when it is really a tool that gave up early or emitted far less.+reportOne :: (CorpusCase, Prepared) -> IO ()+reportOne (c, p) = do+  inBytes <- BS.length <$> BS.readFile (prepPath p)+  sizes <- mapM (\(name, run) -> (,) name <$> safely (run p)) tools+  putStrLn+    ( caseName c+        <> ": in "+        <> show inBytes+        <> "B, out"+        <> concat [" " <> name <> " " <> show n | (name, n) <- sizes]+    )++-- | Run hpp over the preloaded lines, returning its output chunks.+hpp :: [FilePath] -> Prepared -> [BS.ByteString] -> IO [BS.ByteString]+hpp dirs p inputLines = do+  result <-+    runExceptT+      ( Hpp.runHpp+          (hppState (hppConfig dirs (prepPath p)))+          (Hpp.preprocess inputLines)+      )+  case result of+    Left err -> error ("hpp failed on " <> prepPath p <> ": " <> show err)+    Right (out, _) -> pure (Hpp.hppOutput out)++-- | hpp's initial state, carrying the same predefined macros as the others.+hppState :: HppConfig.Config -> Hpp.HppState+hppState config = foldl' define (Hpp.initHppState config mempty) predefinedMacros+  where+    define st (name, value) =+      fromMaybe (error ("hpp rejected -D" <> BS8.unpack name)) (Hpp.addDefinition name value st)++hppConfig :: [FilePath] -> FilePath -> HppConfig.Config+hppConfig dirs path =+  fromMaybe+    (error "hpp configuration incomplete")+    ( HppConfig.realizeConfig+        HppConfig.defaultConfigF+          { HppConfig.curFileNameF = Just path,+            HppConfig.includePathsF = Just (takeDirectory path : dirs)+          }+    )++-- | The same cpphs configuration the correctness oracle in @test/@ uses, so the+-- implementation being timed is the one already being compared against.+cpphsOptions :: [FilePath] -> CpphsOptions+cpphsOptions dirs =+  defaultCpphsOptions+    { boolopts = (boolopts defaultCpphsOptions) {stripC89 = True, warnings = False},+      includes = dirs,+      defines = [(BS8.unpack name, BS8.unpack value) | (name, value) <- predefinedMacros]+    }++-- | Macros the compiler defines, which no header supplies.+--+-- @__GLASGOW_HASKELL__@ is the single most referenced macro in real Haskell —+-- around a thousand modules in a snapshot test it — and GHC passes it with+-- @-D@ rather than putting it in a header, so no amount of include-path+-- fixing makes it appear. Left undefined it is zero in an @#if@, which is not+-- an error but silently sends every version test down its oldest branch, so+-- the corpus preprocesses code that no real build would.+--+-- The version tracks the compiler the pinned snapshot names (@with-compiler:+-- ghc-9.10.3@ for lts-24.58), in GHC's major*100+minor encoding. Bump it with+-- the snapshot.+predefinedMacros :: [(BS.ByteString, BS.ByteString)]+predefinedMacros =+  [ ("__GLASGOW_HASKELL__", "910"),+    ("__GLASGOW_HASKELL_PATCHLEVEL1__", "3"),+    ("__GLASGOW_HASKELL_PATCHLEVEL2__", "0"),+    -- GHC also defines the host and build platform, in these exact forms+    -- (confirmed against @ghc -E@). Without them a module that dispatches on+    -- platform falls through to its @#error@ branch, and the 731 modules that+    -- test @mingw32_HOST_OS@ take the non-Windows path for the wrong reason.+    --+    -- A fixed platform is claimed rather than the host's, so that a number+    -- measured on one machine is comparable with one measured on another: the+    -- platform decides which branches exist to be preprocessed at all.+    ("x86_64_HOST_ARCH", "1"),+    ("x86_64_BUILD_ARCH", "1"),+    ("linux_HOST_OS", "1"),+    ("linux_BUILD_OS", "1")+  ]++-- | Directories holding stand-ins for headers a real build would supply.+--+-- Defaults to @bench\/include@, relative to the package root where @cabal+-- bench@ runs. @AIHC_CPP_BENCH_INCLUDE@ overrides it with a colon-separated+-- list, so a corpus that needs headers of its own can add a directory.+stubIncludes :: [FilePath]+stubIncludes = unsafeStubIncludes++{-# NOINLINE unsafeStubIncludes #-}+unsafeStubIncludes :: [FilePath]+unsafeStubIncludes =+  unsafePerformIO+    (maybe ["bench" </> "include"] (splitOn ':') <$> lookupEnv "AIHC_CPP_BENCH_INCLUDE")++-- | Report which stub directories were found, and which were not.+--+-- Worth saying out loud: a missing directory does not fail, it just means more+-- modules do not resolve their includes, which shows up as a worse failure+-- count with no indication of why.+warnMissingStubs :: IO ()+warnMissingStubs = mapM_ check stubIncludes+  where+    check dir = do+      present <- doesDirectoryExist dir+      putStrLn $+        if present+          then "stub headers: " <> dir+          else "warning: no stub headers at " <> dir <> " (set AIHC_CPP_BENCH_INCLUDE)"++-- | Where to look for an @#include@ target, beyond the including file's own+-- directory.+--+-- A real build passes include directories that a bare source tree does not+-- have: the RTS headers GHC ships (stubbed under @bench\/include@) and whatever+-- the package declares in @include-dirs@, which is where nearly all of the+-- corpus keeps its own headers. Without them around a hundred modules per+-- snapshot fail to resolve @MachDeps.h@ alone, and since the three tools+-- disagree about whether an unresolvable include is fatal, the failure counts+-- end up describing include resolution rather than the preprocessors.+searchPathFor :: M.Map FilePath [FilePath] -> FilePath -> FilePath -> [FilePath]+searchPathFor declared root path =+  stubIncludes <> declaredDirs <> [packageDir </> "include", packageDir, root]+  where+    packageDir = packageDirOf root path+    declaredDirs = M.findWithDefault [] packageDir declared++-- | The package a corpus file belongs to.+--+-- Corpus layout is @\<root\>\/\<package-version\>\/...@, so the package+-- directory is the first component below the root.+packageDirOf :: FilePath -> FilePath -> FilePath+packageDirOf root path = case stripPrefixDir root path of+  Just (component : _) -> root </> component+  _ -> takeDirectory path++-- | Read @include-dirs@ out of every package's @.cabal@ file, once.+--+-- Packages keep their headers wherever they like — @src@, @cbits@, @srcinc@ —+-- and tell Cabal about it with @include-dirs@. Guessing @\<package\>\/include@+-- covers almost none of them: of the include sites that failed to resolve+-- before this, nine in ten named a header that was present in its own package+-- but in a directory only the @.cabal@ file knows about.+--+-- This is a deliberately loose parser. It takes every @include-dirs@ field in+-- the file regardless of which stanza or conditional it sits under, because the+-- benchmark wants a superset: a directory that some other component would have+-- used costs nothing here, whereas a missing one costs a module.+packageIncludeDirs :: FilePath -> IO (M.Map FilePath [FilePath])+packageIncludeDirs root = do+  packages <- fromRight [] <$> (try (listDirectory root) :: IO (Either SomeException [FilePath]))+  M.fromList . concat <$> mapM forPackage packages+  where+    forPackage name = do+      let dir = root </> name+      entries <- fromRight [] <$> (try (listDirectory dir) :: IO (Either SomeException [FilePath]))+      case filter ((== ".cabal") . takeExtension) entries of+        [] -> pure []+        (cabalFile : _) -> do+          contents <- fromRight BS.empty <$> (try (BS.readFile (dir </> cabalFile)) :: IO (Either SomeException BS.ByteString))+          pure [(dir, map (dir </>) (parseIncludeDirs contents))]++-- | Pull the values of every @include-dirs@ field out of a @.cabal@ file.+--+-- A field's value may sit on its own line, on following lines indented further,+-- and be separated by commas or whitespace. A following line that looks like+-- another field ends the list.+parseIncludeDirs :: BS.ByteString -> [FilePath]+parseIncludeDirs = go . BS8.lines+  where+    go [] = []+    go (line : rest) = case BS8.break (== ':') (BS8.map toLower line) of+      (name, remainder)+        | BS8.strip name == "include-dirs",+          not (BS.null remainder) ->+            let indent = BS8.length (BS8.takeWhile isSpace line)+                (continued, after) = span (isContinuation indent) rest+             in values (BS.drop 1 (BS8.drop (BS8.length name) line))+                  <> concatMap values continued+                  <> go after+      _ -> go rest+    isContinuation indent line =+      not (BS.null (BS8.strip line))+        && BS8.length (BS8.takeWhile isSpace line) > indent+        && not (isField line)+    isField line = case BS8.break (== ':') line of+      (name, remainder) -> not (BS.null remainder) && BS8.all fieldChar (BS8.strip name)+    fieldChar c = isAlpha c || c == '-'+    values =+      map BS8.unpack+        . concatMap (filter (not . BS.null) . BS8.splitWith isSpace)+        . BS8.split ','++stripPrefixDir :: FilePath -> FilePath -> Maybe [FilePath]+stripPrefixDir root path = go (splitDirectories root) (splitDirectories path)+  where+    go [] rest = Just rest+    go (r : rs) (p : ps) | r == p = go rs ps+    go _ _ = Nothing++-- | Preprocess a file whose contents are already in memory, searching the given+-- directories for @#include@ targets as they are requested.+--+-- Includes are read from disk rather than preloaded because that is what cpphs+-- and hpp do: they take the entry file's contents and go to the file system for+-- the rest. Preloading them for aihc-cpp alone would hand it an advantage the+-- other two cannot have.+runAihc :: [FilePath] -> FilePath -> BS.ByteString -> IO Result+runAihc dirs path source =+  go (preprocess config source)+  where+    config =+      defaultConfig+        { configInputFile = path,+          configMacros = M.union (M.fromList predefinedMacros) (configMacros defaultConfig)+        }+    go (Done r) = pure r+    go (NeedInclude req k) = do+      contents <- firstExisting (candidates req)+      go (k contents)+    candidates req = [dir </> includePath req | dir <- includeDirs req]+    includeDirs req =+      let fromDir = takeDirectory (includeFrom req)+       in (if null fromDir then takeDirectory path else fromDir) : dirs+    firstExisting [] = pure Nothing+    firstExisting (candidate : rest) = do+      exists <- doesFileExist candidate+      if exists then Just <$> BS.readFile candidate else firstExisting rest

@@ -0,0 +1,80 @@+/*+ * A stand-in for the HsBaseConfig.h that GHC ships with base, for the+ * benchmark corpus only.+ *+ * Eighteen modules in a Stackage snapshot include this header. The real one is+ * around nine hundred lines, almost all of it errno constants that no module in+ * the corpus refers to; what they do use is the HTYPE_ family, which names the+ * Haskell type corresponding to a C typedef and is substituted into type+ * declarations. Only those are defined here.+ *+ * The mapping below describes a conventional 64-bit Unix. Nothing is compiled,+ * only preprocessed, so the values need only be defined and expand to something+ * shaped like a type name. Written from the macro names the real header+ * defines rather than copied from it, so that this repository stays under a+ * single licence.+ */++#pragma once++/* C scalar types. */+#define HTYPE_CHAR Int8+#define HTYPE_SIGNED_CHAR Int8+#define HTYPE_UNSIGNED_CHAR Word8+#define HTYPE_SHORT Int16+#define HTYPE_UNSIGNED_SHORT Word16+#define HTYPE_INT Int32+#define HTYPE_UNSIGNED_INT Word32+#define HTYPE_LONG Int64+#define HTYPE_UNSIGNED_LONG Word64+#define HTYPE_LONG_LONG Int64+#define HTYPE_UNSIGNED_LONG_LONG Word64+#define HTYPE_FLOAT Float+#define HTYPE_DOUBLE Double+#define HTYPE_WCHAR_T Int32++/* <stdint.h> and <stddef.h> typedefs. */+#define HTYPE_SIZE_T Word64+#define HTYPE_PTRDIFF_T Int64+#define HTYPE_INTPTR_T Int64+#define HTYPE_UINTPTR_T Word64+#define HTYPE_INTMAX_T Int64+#define HTYPE_UINTMAX_T Word64+#define HTYPE_SIG_ATOMIC_T Int32++/* POSIX typedefs. */+#define HTYPE_DEV_T Word64+#define HTYPE_INO_T Word64+#define HTYPE_MODE_T Word32+#define HTYPE_OFF_T Int64+#define HTYPE_PID_T Int32+#define HTYPE_NLINK_T Word64+#define HTYPE_UID_T Word32+#define HTYPE_GID_T Word32+#define HTYPE_SSIZE_T Int64+#define HTYPE_ID_T Word32+#define HTYPE_KEY_T Int32+#define HTYPE_BLKSIZE_T Int64+#define HTYPE_BLKCNT_T Int64+#define HTYPE_FSBLKCNT_T Word64+#define HTYPE_FSFILCNT_T Word64+#define HTYPE_RLIM_T Word64+#define HTYPE_CLOCKID_T Int32+#define HTYPE_TIMER_T Word64+#define HTYPE_TIME_T Int64+#define HTYPE_CLOCK_T Int64+#define HTYPE_USECONDS_T Word32+#define HTYPE_SUSECONDS_T Int64+#define HTYPE_NLINK_T_SIGNED 0++/* Terminal control typedefs. */+#define HTYPE_CC_T Word8+#define HTYPE_SPEED_T Word64+#define HTYPE_TCFLAG_T Word64++/* Feature flags the corpus checks for. */+#define HAVE_UNISTD_H 1+#define HAVE_SYS_TYPES_H 1+#define HAVE_SYS_STAT_H 1+#define HAVE_TERMIOS_H 1+#define HAVE_SIGNAL_H 1

@@ -0,0 +1,65 @@+/*+ * A stand-in for GHC's MachDeps.h, for the benchmark corpus only.+ *+ * Around a hundred modules in a Stackage snapshot include this header. In a+ * real build GHC supplies it from the RTS include directory; a bare source tree+ * has no such directory, so those modules fail to preprocess and drop out of+ * the measurement — and the tools disagree about whether that is fatal, which+ * made the failure counts describe include resolution rather than the+ * preprocessors.+ *+ * The values below describe a conventional 64-bit platform. They are not read+ * for accuracy: nothing here is compiled, only preprocessed, so all that+ * matters is that the macros are defined and that arithmetic in #if conditions+ * evaluates. This is written from the macro names GHC's header defines rather+ * than copied from it, so that this repository stays under a single licence.+ */++#pragma once++#define WORD_SIZE_IN_BITS 64+#define WORD_SIZE_IN_BITS_FLOAT 64++#define SIZEOF_HSCHAR 4+#define ALIGNMENT_HSCHAR 4+#define SIZEOF_HSINT 8+#define ALIGNMENT_HSINT 8+#define SIZEOF_HSWORD 8+#define ALIGNMENT_HSWORD 8+#define SIZEOF_HSFLOAT 4+#define ALIGNMENT_HSFLOAT 4+#define SIZEOF_HSDOUBLE 8+#define ALIGNMENT_HSDOUBLE 8+#define SIZEOF_HSPTR 8+#define ALIGNMENT_HSPTR 8+#define SIZEOF_HSFUNPTR 8+#define ALIGNMENT_HSFUNPTR 8+#define SIZEOF_HSSTABLEPTR 8+#define ALIGNMENT_HSSTABLEPTR 8++#define SIZEOF_INT8 1+#define ALIGNMENT_INT8 1+#define SIZEOF_WORD8 1+#define ALIGNMENT_WORD8 1+#define SIZEOF_INT16 2+#define ALIGNMENT_INT16 2+#define SIZEOF_WORD16 2+#define ALIGNMENT_WORD16 2+#define SIZEOF_INT32 4+#define ALIGNMENT_INT32 4+#define SIZEOF_WORD32 4+#define ALIGNMENT_WORD32 4+#define SIZEOF_INT64 8+#define ALIGNMENT_INT64 8+#define SIZEOF_WORD64 8+#define ALIGNMENT_WORD64 8++#define SIZEOF_VOID_P 8+#define ALIGNMENT_VOID_P 8+#define SIZEOF_LONG 8+#define ALIGNMENT_LONG 8+#define SIZEOF_UNSIGNED_LONG 8+#define ALIGNMENT_UNSIGNED_LONG 8++#define TAG_BITS 3+#define TAG_MASK ((1 << TAG_BITS) - 1)

@@ -0,0 +1,27 @@+/*+ * A deliberately empty stand-in for the cabal_macros.h that Cabal generates,+ * for the benchmark corpus only.+ *+ * Cabal writes one of these per package during a build, defining VERSION_ and+ * MIN_VERSION_ for that package's own dependencies. A bare source tree has+ * none, so a module that includes it by name fails to resolve the include —+ * and because the three preprocessors disagree about whether an unresolvable+ * include is fatal, that turned into a difference in the failure counts that+ * said nothing about preprocessing.+ *+ * This file exists so the include resolves. It defines nothing on purpose.+ *+ * A snapshot-wide file with a MIN_VERSION_ for all 3441 packages was tried and+ * is not here, for two reasons. Resolving the include is nearly all of the+ * benefit: with the macros defined, only two more modules preprocessed+ * cleanly, because an undefined macro in an #if simply takes the other branch+ * rather than failing. And it cannot be pre-included the way a real build+ * pre-includes cabal_macros.h: even pruned to the packages the corpus names it+ * is 212KB against an average module of 12KB, which turned a 71MiB corpus into+ * 1.3GiB and made the benchmark measure macro-file parsing (3.26s to 69.56s).+ *+ * A real per-package cabal_macros.h is small because it holds only that+ * package's dependencies. A shared one cannot be, so this one holds nothing.+ */++#pragma once

@@ -39,16 +39,14 @@     atEnd,     findNewline,     fromByteString,-    lineSlice,     peekByte,     peekByteAt,     skipNewline,     skipWhile,-    sliceText,-    toText,+    sliceBytes,   ) import Aihc.Cpp.Evaluator (evalCondition)-import Aihc.Cpp.Parser (Directive (..), parseDirective)+import Aihc.Cpp.Parser (Directive (..), isSpaceChar, parseDirective) import Aihc.Cpp.Scanner (expandLineBySpanMultiline, lineScanFinalCDepth, lineScanFinalHsDepth, lineScanSpans, scanLine, scanLineDepthOnly) import Aihc.Cpp.Types   ( CondFrame (..),@@ -65,29 +63,29 @@     Step (..),     currentActive,     defaultConfig,+    defineMacro,     emptyState,     mkFrame,+    setMacroTable,+    undefMacro,   ) import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Builder as BSB+import qualified Data.ByteString.Char8 as C import qualified Data.ByteString.Lazy as BSL-import Data.Char (isSpace)-import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import Data.Maybe (fromMaybe) import qualified Data.Set as S import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Lazy.Builder as TB+import qualified Data.Text.Encoding as TE+import qualified Data.Text.Encoding.Error as TEE import System.FilePath (takeDirectory, (</>))  -- $setup -- >>> :set -XOverloadedStrings -- >>> import qualified Data.Map.Strict as M--- >>> import qualified Data.Text as T--- >>> import qualified Data.Text.IO as T+-- >>> import qualified Data.ByteString.Char8 as C  -- | Preprocess C preprocessor directives in the input. --@@ -105,7 +103,7 @@ -- Object-like macros are expanded in the output: -- -- >>> let Done r = preprocess defaultConfig "#define FOO 42\nThe answer is FOO"--- >>> T.putStr (resultOutput r)+-- >>> C.putStr (resultOutput r) -- #line 1 "<input>" -- <BLANKLINE> -- The answer is 42@@ -113,7 +111,7 @@ -- Function-like macros are also supported: -- -- >>> let Done r = preprocess defaultConfig "#define MAX(a,b) ((a) > (b) ? (a) : (b))\nMAX(3, 5)"--- >>> T.putStr (resultOutput r)+-- >>> C.putStr (resultOutput r) -- #line 1 "<input>" -- <BLANKLINE> -- ((3) > (5) ? (3) : (5))@@ -125,7 +123,7 @@ -- >>> :{ -- let Done r = preprocess defaultConfig --       "#define DEBUG 1\n#if DEBUG\ndebug mode\n#else\nrelease mode\n#endif"--- in T.putStr (resultOutput r)+-- in C.putStr (resultOutput r) -- :} -- #line 1 "<input>" -- <BLANKLINE>@@ -144,7 +142,7 @@ -- >>> :{ -- let NeedInclude req k = preprocess defaultConfig "#include \"header.h\"\nmain code" --     Done r = k (Just "-- header content")--- in T.putStr (resultOutput r)+-- in C.putStr (resultOutput r) -- :} -- #line 1 "<input>" -- #line 1 "./header.h"@@ -158,7 +156,7 @@ -- let NeedInclude _ k = preprocess defaultConfig "#include \"missing.h\"" --     Done r = k Nothing -- in do---   T.putStr (resultOutput r)+--   C.putStr (resultOutput r) --   mapM_ print (resultDiagnostics r) -- :} -- #line 1 "<input>"@@ -171,7 +169,7 @@ -- >>> :{ -- let Done r = preprocess defaultConfig "#warning This is a warning" -- in do---   T.putStr (resultOutput r)+--   C.putStr (resultOutput r) --   mapM_ print (resultDiagnostics r) -- :} -- #line 1 "<input>"@@ -183,12 +181,38 @@ -- >>> :{ -- let Done r = preprocess defaultConfig "#error Build failed\nthis line is not processed" -- in do---   T.putStr (resultOutput r)+--   C.putStr (resultOutput r) --   mapM_ print (resultDiagnostics r) -- :} -- #line 1 "<input>" -- <BLANKLINE> -- Diagnostic {diagSeverity = Error, diagMessage = "Build failed", diagFile = "<input>", diagLine = 1}+--+-- === Source encoding+--+-- The preprocessor is agnostic to the source encoding. Every character+-- that is significant to CPP is ASCII, so the input is never decoded:+-- bytes the preprocessor did not itself generate are copied from+-- 'ByteString' input to 'ByteString' output verbatim. A Latin-1 module, a+-- UTF-8 one, or a file with no consistent encoding at all all pass+-- through unchanged, and no input can make 'preprocess' fail to decode+-- something or raise an exception.+--+-- Byte 169 (0xA9, a Latin-1 copyright sign) is neither decoded nor+-- rewritten; it is shown escaped here only because that keeps this+-- example's output pure ASCII:+--+-- >>> let Done r = preprocess defaultConfig "-- \169 2026\nx = 1\n"+-- >>> resultOutput r+-- "#line 1 \"<input>\"\n-- \169 2026\nx = 1\n"+--+-- This is deliberately looser than GHC, which decodes source as UTF-8 --+-- but only where it must lex a token. GHC accepts an undecodable byte+-- inside a comment (real Hackage packages ship such modules) and rejects+-- one inside a string literal. Rejecting the file here would fail+-- modules that genuinely compile, so encoding is left to the caller: the+-- output bytes are exactly what a compiler front-end should lex, and its+-- lexer decides what is valid. preprocess :: Config -> ByteString -> Step preprocess cfg input =   let cursor = fromByteString input@@ -196,14 +220,12 @@   where     initialState =       let st0 = emitLine (linePragma 1 (configInputFile cfg)) (emptyState (configInputFile cfg))-       in st0-            { stMacros = M.map ObjectMacro (configMacros cfg)-            }+       in setMacroTable (M.map ObjectMacro (configMacros cfg)) st0      finish st =-      let out = TL.toStrict (TB.toLazyText (stOutput st))+      let out = BSL.toStrict (BSB.toLazyByteString (stOutput st))           outWithTrailingNewline =-            if T.null out+            if BS.null out               then out               else out <> "\n"        in Done@@ -213,8 +235,8 @@               }  -- | Find the next line in the cursor, handling backslash-continuation--- for directive lines. Returns (lineCursor, lineSpan, restCursor) where:---   * lineCursor is a sub-cursor bounded to the logical line content+-- for directive lines. Returns (lineText, lineSpan, restCursor) where:+--   * lineText is the logical line content, without its newline --   * lineSpan is the number of physical lines consumed (>= 1) --   * restCursor is positioned after the line (past the newline) --@@ -222,7 +244,7 @@ -- (after optional whitespace), matching CPP semantics. -- For continuation lines, a new ByteString is allocated with the -- backslash-newline sequences removed.-nextLine :: Cursor -> (Cursor, Int, Cursor)+nextLine :: Cursor -> (ByteString, Int, Cursor) nextLine cur =   let eol = findNewline cur       lineStart = curPos cur@@ -234,10 +256,10 @@         then -- Backslash continuation: join lines, stripping '\' and '\n'           joinContinuationLines cur lineStart lineEnd rest         else-          let lineText = sliceText lineStart lineEnd cur+          let lineText = sliceBytes lineStart lineEnd cur            in if hasGccStringContinuation emptyQuoteState lineText                 then joinStringContinuationLines cur lineStart lineEnd rest-                else (lineSlice lineEnd cur, 1, rest)+                else (lineText, 1, rest)  -- | Check if the bytes from curPos to lineEnd start with '#' after -- optional whitespace. This determines whether backslash-continuation@@ -253,7 +275,7 @@ -- | Join backslash-continuation lines into a single logical line. -- Builds a new ByteString with '\<newline>' sequences removed. -- Returns (joinedCursor, physicalLineCount, restCursor).-joinContinuationLines :: Cursor -> Int -> Int -> Cursor -> (Cursor, Int, Cursor)+joinContinuationLines :: Cursor -> Int -> Int -> Cursor -> (ByteString, Int, Cursor) joinContinuationLines origCur lineStart firstLineEnd firstRest =   let buf = curBuf origCur       -- First segment: from lineStart to firstLineEnd - 1 (exclude '\')@@ -264,7 +286,7 @@       | atEnd rest =           -- No more input; finalize           let joined = BSL.toStrict (BSB.toLazyByteString acc)-           in (fromByteString joined, spanCount, rest)+           in (joined, spanCount, rest)       | otherwise =           let eol = findNewline rest               segStart = curPos rest@@ -280,7 +302,7 @@                   -- Last line of continuation                   let segment = BSB.byteString (sliceBS segStart segEnd (curBuf origCur))                       joined = BSL.toStrict (BSB.toLazyByteString (acc <> segment))-                   in (fromByteString joined, spanCount + 1, rest')+                   in (joined, spanCount + 1, rest')  -- | Slice a ByteString from position @start@ to @end@ (exclusive). sliceBS :: Int -> Int -> ByteString -> ByteString@@ -302,46 +324,50 @@ -- final backslash is the CPP continuation marker.  GHC's default CPP-like -- handling also accepts the single-backslash spelling, so only the double -- spelling is spliced here.-hasGccStringContinuation :: QuoteState -> Text -> Bool+--+-- The cheap suffix test comes first: 'scanQuoteState' walks the whole line,+-- and almost no line in real source ends in a double backslash, so testing+-- the two trailing bytes first removes a full scan from every line.+hasGccStringContinuation :: QuoteState -> ByteString -> Bool hasGccStringContinuation st lineText =-  qsInString (scanQuoteState st lineText) && "\\\\" `T.isSuffixOf` lineText+  "\\\\" `C.isSuffixOf` lineText && qsInString (scanQuoteState st lineText) -joinStringContinuationLines :: Cursor -> Int -> Int -> Cursor -> (Cursor, Int, Cursor)+joinStringContinuationLines :: Cursor -> Int -> Int -> Cursor -> (ByteString, Int, Cursor) joinStringContinuationLines origCur lineStart firstLineEnd firstRest =   let buf = curBuf origCur-      firstSegment = sliceText lineStart (firstLineEnd - 1) origCur+      firstSegment = sliceBytes lineStart (firstLineEnd - 1) origCur       firstBytes = BSB.byteString (sliceBS lineStart (firstLineEnd - 1) buf)    in go firstBytes 1 firstRest (scanQuoteState emptyQuoteState firstSegment)   where     go !acc !spanCount !rest !quoteState       | atEnd rest =           let joined = BSL.toStrict (BSB.toLazyByteString acc)-           in (fromByteString joined, spanCount, rest)+           in (joined, spanCount, rest)       | otherwise =           let eol = findNewline rest               segStart = curPos rest               segEnd = curPos eol               rest' = fromMaybe eol (skipNewline eol)-              segmentText = sliceText segStart segEnd origCur+              segmentText = sliceBytes segStart segEnd origCur            in if hasGccStringContinuation quoteState segmentText                 then                   let segmentBytes = BSB.byteString (sliceBS segStart (segEnd - 1) (curBuf origCur))-                      scannedText = sliceText segStart (segEnd - 1) origCur+                      scannedText = sliceBytes segStart (segEnd - 1) origCur                    in go (acc <> segmentBytes) (spanCount + 1) rest' (scanQuoteState quoteState scannedText)                 else                   let segmentBytes = BSB.byteString (sliceBS segStart segEnd (curBuf origCur))                       joined = BSL.toStrict (BSB.toLazyByteString (acc <> segmentBytes))-                   in (fromByteString joined, spanCount + 1, rest')+                   in (joined, spanCount + 1, rest') -scanQuoteState :: QuoteState -> Text -> QuoteState+scanQuoteState :: QuoteState -> ByteString -> QuoteState scanQuoteState = go   where     go st txt =-      case T.uncons txt of+      case C.uncons txt of         Nothing -> st         Just (c, rest)           | qsInString st ->-              if qsEscaped st && isSpace c+              if qsEscaped st && isSpaceChar c                 then go st {qsEscaped = False} (dropStringGapClose rest)                 else                   go@@ -362,8 +388,8 @@           | otherwise -> go st {qsEscaped = False} rest      dropStringGapClose txt =-      let afterSpace = T.dropWhile isSpace txt-       in case T.uncons afterSpace of+      let afterSpace = C.dropWhile isSpaceChar txt+       in case C.uncons afterSpace of             Just ('\\', rest) -> rest             _ -> afterSpace @@ -378,13 +404,12 @@           k (emitBlankLines 1 st)         else k st processFile filePath cursor trailingNl stack !lineNo st k =-  let (lineCur, lineSpan, restCursor) = nextLine cursor+  let (lineText, lineSpan, restCursor) = nextLine cursor       -- Detect if this line was followed by a newline (vs EOF).       -- If so and restCursor is at EOF, the file had a trailing newline.       hasTrailingNl = trailingNl && not (atEnd restCursor) || (trailingNl && atEnd restCursor)       -- Actually: trailingNl flag is set at processFile entry for includes.       -- We just propagate it. The check at atEnd above handles the final empty line.-      lineText = toText lineCur       startsInBlockComment = stHsBlockCommentDepth st > 0 || stCBlockCommentDepth st > 0       parsedDirective =         if startsInBlockComment@@ -395,7 +420,7 @@    in if not isActive && not (stSkippingDanglingElse st)         then -- === Fast path for inactive branches ===         -- Only track comment depth; skip full span scanning and macro expansion.-          let (finalHs, finalC) = scanLineDepthOnly (stHsBlockCommentDepth st) (stCBlockCommentDepth st) lineCur+          let (finalHs, finalC) = scanLineDepthOnly (stHsBlockCommentDepth st) (stCBlockCommentDepth st) lineText               advanceSt st' =                 st'                   { stCurrentLine = nextLineNo,@@ -422,7 +447,7 @@                           }                    in handleDirective ctx st directive         else -- === Normal path: full scan + expansion ===-          let lineScan = scanLine (stHsBlockCommentDepth st) (stCBlockCommentDepth st) lineCur+          let lineScan = scanLine (stHsBlockCommentDepth st) (stCBlockCommentDepth st) lineText               advanceLineState st' =                 st'                   { stCurrentLine = nextLineNo,@@ -494,8 +519,8 @@   | atEnd cur = (hsDepth, cDepth)   | otherwise =       let eol = findNewline cur-          lineCur = lineSlice (curPos eol) cur-          (hsDepth', cDepth') = scanLineDepthOnly hsDepth cDepth lineCur+          lineText = sliceBytes (curPos cur) (curPos eol) cur+          (hsDepth', cDepth') = scanLineDepthOnly hsDepth cDepth lineText           rest = fromMaybe eol (skipNewline eol)        in scanConsumedLines hsDepth' cDepth' rest (remaining - 1) @@ -521,11 +546,11 @@ handleDirective ctx st directive =   case directive of     DirDefineObject name value ->-      mutateMacrosWhenActive ctx st (M.insert name (ObjectMacro value))+      mutateMacrosWhenActive ctx st (defineMacro name (ObjectMacro value))     DirDefineFunction name params body ->-      mutateMacrosWhenActive ctx st (M.insert name (FunctionMacro params body))+      mutateMacrosWhenActive ctx st (defineMacro name (FunctionMacro params body))     DirUndef name ->-      mutateMacrosWhenActive ctx st (M.delete name)+      mutateMacrosWhenActive ctx st (undefMacro name)     DirInclude kind includeTarget ->       handleIncludeDirective ctx st kind includeTarget     DirIf expr ->@@ -547,20 +572,20 @@         _ : rest ->           continueBlankWithStack ctx rest st     DirWarning msg ->-      addDiagnosticWhenActive ctx Warning msg st+      addDiagnosticWhenActive ctx Warning (messageText msg) st     DirError msg ->       if currentActive (lcStack ctx)         then           lcDone             ctx-            (emitDirectiveBlank ctx (addDiag Error msg (lcFilePath ctx) (lcLineNo ctx) st))+            (emitDirectiveBlank ctx (addDiag Error (messageText msg) (lcFilePath ctx) (lcLineNo ctx) st))         else continueBlank ctx st     DirLine n mPath ->       handleLineDirective ctx st n mPath     DirPragmaOnce ->       handlePragmaOnceDirective ctx st     DirUnsupported name ->-      addDiagnosticWhenActive ctx Warning ("unsupported directive: " <> name) st+      addDiagnosticWhenActive ctx Warning ("unsupported directive: " <> messageText name) st  emitDirectiveBlank :: LineContext -> EngineState -> EngineState emitDirectiveBlank ctx = emitBlankLines (lcLineSpan ctx)@@ -571,10 +596,10 @@ continueBlankWithStack :: LineContext -> [CondFrame] -> EngineState -> Step continueBlankWithStack ctx stack st = lcContinueWith ctx stack (emitDirectiveBlank ctx st) -mutateMacrosWhenActive :: LineContext -> EngineState -> (Map Text MacroDef -> Map Text MacroDef) -> Step+mutateMacrosWhenActive :: LineContext -> EngineState -> (EngineState -> EngineState) -> Step mutateMacrosWhenActive ctx st mutate =   if currentActive (lcStack ctx)-    then continueBlank ctx (st {stMacros = mutate (stMacros st)})+    then continueBlank ctx (mutate st)     else continueBlank ctx st  addDiagnosticWhenActive :: LineContext -> Severity -> Text -> EngineState -> Step@@ -594,7 +619,7 @@   let frame = mkFrame (currentActive (lcStack ctx)) cond    in continueBlankWithStack ctx (frame : lcStack ctx) st -handleElifDirective :: LineContext -> EngineState -> Text -> Step+handleElifDirective :: LineContext -> EngineState -> ByteString -> Step handleElifDirective ctx st expr =   case lcStack ctx of     [] ->@@ -637,13 +662,13 @@                   }            in continueBlankWithStack ctx (f' : rest) st -handleIncludeDirective :: LineContext -> EngineState -> IncludeKind -> Text -> Step+handleIncludeDirective :: LineContext -> EngineState -> IncludeKind -> ByteString -> Step handleIncludeDirective ctx st kind includeTarget   | not (currentActive (lcStack ctx)) = continueBlank ctx st   | S.member includeFilePath (stPragmaOnceFiles st) = continueBlank ctx st   | otherwise = NeedInclude includeReq nextStep   where-    includePathText = T.unpack includeTarget+    includePathText = C.unpack includeTarget     includeFilePath =       case kind of         IncludeLocal -> takeDirectory (lcFilePath ctx) </> includePathText@@ -659,7 +684,7 @@     nextStep Nothing =       lcContinue         ctx-        (addDiag Error ("missing include: " <> includeTarget) (lcFilePath ctx) (lcLineNo ctx) st)+        (addDiag Error ("missing include: " <> messageText includeTarget) (lcFilePath ctx) (lcLineNo ctx) st)     nextStep (Just includeBytes) =       let includeCursor = fromByteString includeBytes           -- Include files treat trailing newlines as producing an extra@@ -702,11 +727,11 @@             (stWithLinePragma {stCurrentLine = lineNumber})             (lcDone ctx) -emitLine :: Text -> EngineState -> EngineState+emitLine :: ByteString -> EngineState -> EngineState emitLine line st =-  let sep = if stOutputLineCount st > 0 then TB.singleton '\n' else mempty+  let sep = if stOutputLineCount st > 0 then BSB.char8 '\n' else mempty    in st-        { stOutput = stOutput st <> sep <> TB.fromText line,+        { stOutput = stOutput st <> sep <> BSB.byteString line,           stOutputLineCount = stOutputLineCount st + 1         } @@ -714,12 +739,21 @@ emitBlankLines n st   | n <= 0 = st   | otherwise =-      let newlines = mconcat (replicate n (TB.singleton '\n'))+      let newlines = mconcat (replicate n (BSB.char8 '\n'))        in st             { stOutput = stOutput st <> newlines,               stOutputLineCount = stOutputLineCount st + n             } +-- | Turn a fragment of source into human-readable message text.+--+-- This is the only place the preprocessor decodes anything. It is a+-- display concern: 'Diagnostic' is meant to be shown to a person, so+-- invalid UTF-8 becomes U+FFFD here rather than propagating bytes into+-- the message. 'resultOutput' is never decoded and never substituted.+messageText :: ByteString -> Text+messageText = TE.decodeUtf8With TEE.lenientDecode+ addDiag :: Severity -> Text -> FilePath -> Int -> EngineState -> EngineState addDiag sev msg filePath lineNo st =   st@@ -733,5 +767,5 @@           : stDiagnosticsRev st     } -linePragma :: Int -> FilePath -> Text-linePragma n path = "#line " <> T.pack (show n) <> " \"" <> T.pack path <> "\""+linePragma :: Int -> FilePath -> ByteString+linePragma n path = "#line " <> C.pack (show n) <> " \"" <> C.pack path <> "\""

@@ -8,19 +8,19 @@ -- A lightweight cursor abstraction over a strict 'ByteString'. The cursor -- tracks a position into a shared buffer, enabling O(1) peeking and -- zero-copy slicing. All CPP-significant bytes are ASCII (0x00-0x7F),--- so byte-level operations are safe; non-ASCII bytes (>= 0x80) can be--- bulk-copied without decoding.+-- so byte-level operations are safe; non-ASCII bytes (>= 0x80) are+-- bulk-copied and never decoded, which is what makes the preprocessor+-- agnostic to the source encoding. module Aihc.Cpp.Cursor   ( Cursor (..),     fromByteString,-    fromText,-    toText,+    toBytes,     null,     peekByte,     peekByte2,     advance,     advance2,-    sliceText,+    sliceBytes,     sliceSince,     skipWhile,     skipToInteresting,@@ -38,8 +38,6 @@  import Data.ByteString (ByteString) import qualified Data.ByteString as BS-import Data.Text (Text)-import qualified Data.Text.Encoding as TE import Data.Word (Word8) import Prelude hiding (null) @@ -56,13 +54,9 @@ fromByteString :: ByteString -> Cursor fromByteString bs = Cursor bs 0 --- | Create a cursor from 'Text' by encoding to UTF-8.-fromText :: Text -> Cursor-fromText = fromByteString . TE.encodeUtf8---- | Decode the remaining bytes from the cursor position as UTF-8 'Text'.-toText :: Cursor -> Text-toText (Cursor buf pos) = TE.decodeUtf8 (BS.drop pos buf)+-- | The remaining bytes from the cursor position, as a zero-copy slice.+toBytes :: Cursor -> ByteString+toBytes (Cursor buf pos) = BS.drop pos buf  -- | Is the cursor at the end of input? null :: Cursor -> Bool@@ -107,17 +101,17 @@ advance2 (Cursor buf pos) = Cursor buf (pos + 2) {-# INLINE advance2 #-} --- | Extract a zero-copy 'Text' slice from position @start@ to position--- @end@ (exclusive) in the cursor's buffer.-sliceText :: Int -> Int -> Cursor -> Text-sliceText start end (Cursor buf _) =-  TE.decodeUtf8 (BS.take (end - start) (BS.drop start buf))-{-# INLINE sliceText #-}+-- | Extract a zero-copy slice from position @start@ to position @end@+-- (exclusive) in the cursor's buffer.+sliceBytes :: Int -> Int -> Cursor -> ByteString+sliceBytes start end (Cursor buf _) =+  BS.take (end - start) (BS.drop start buf)+{-# INLINE sliceBytes #-} --- | Extract a zero-copy 'Text' slice from the given start position to--- the cursor's current position.-sliceSince :: Int -> Cursor -> Text-sliceSince start cur = sliceText start (curPos cur) cur+-- | Extract a zero-copy slice from the given start position to the+-- cursor's current position.+sliceSince :: Int -> Cursor -> ByteString+sliceSince start cur = sliceBytes start (curPos cur) cur {-# INLINE sliceSince #-}  -- | Advance the cursor while the predicate holds for the current byte.@@ -166,14 +160,14 @@ -- positioned at the newline (or at EOF). The bytes from the -- original position to the returned position form the line content -- (without the newline).+-- 'BS.elemIndex' is a @memchr@, which searches many bytes at a time; the+-- byte-at-a-time loop this replaces also allocated a fresh 'Cursor' per+-- byte of every line in the input. findNewline :: Cursor -> Cursor-findNewline = go-  where-    go !cur = case peekByte cur of-      Nothing -> cur-      Just 0x0A -> cur -- '\n'-      Just _ -> go (advance cur)-{-# INLINE findNewline #-}+findNewline (Cursor buf pos) =+  case BS.elemIndex 0x0A (BS.drop pos buf) of -- '\n'+    Just offset -> Cursor buf (pos + offset)+    Nothing -> Cursor buf (BS.length buf)  -- | Advance past a newline byte if the cursor is currently on one. -- Returns 'Nothing' at EOF, 'Just cursor' after the newline otherwise.

@@ -1,3 +1,4 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-}  module Aihc.Cpp.Evaluator@@ -22,52 +23,60 @@   ) where -import Aihc.Cpp.Parser (isIdentChar, isIdentStart, isOpChar)-import Aihc.Cpp.Types (EngineState (..), MacroDef (..))-import Data.Char (isDigit, isSpace)+import Aihc.Cpp.Parser (isIdentChar, isIdentStart, isOpChar, isSpaceChar)+import Aihc.Cpp.Types (EngineState (..), MacroDef (..), bloomMember)+import Data.Bits ((.&.))+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Builder as BSB+import qualified Data.ByteString.Char8 as C+import qualified Data.ByteString.Lazy as BSL+import qualified Data.ByteString.Unsafe as BSU+import Data.Char (isDigit) import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import Data.Set (Set) import qualified Data.Set as S-import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Lazy.Builder as TB-import qualified Data.Text.Read as TR+import Data.Word (Word8)  -- | Expand macros in a single piece of text using the blue-paint algorithm. -- A single pass with a suppression set replaces the previous iterate-up-to-32 -- fixpoint approach.-expandMacros :: EngineState -> Text -> Text-expandMacros st txt =-  builderToText (expandBlue st S.empty False False False (TB.fromText txt))+expandMacros :: EngineState -> ByteString -> ByteString+expandMacros st = expandWith st S.empty  -- | Expand macros with multi-line support. When a function-like macro call -- spans multiple lines, continuation lines are consumed from @moreLines@. -- Returns the expanded text and the number of extra lines consumed.-expandMacrosMultiline :: EngineState -> Text -> [Text] -> (Text, Int)+expandMacrosMultiline :: EngineState -> ByteString -> [ByteString] -> (ByteString, Int) expandMacrosMultiline st txt moreLines =   let extraNeeded = countExtraLinesConsumed st txt moreLines    in if extraNeeded == 0         then (expandMacros st txt, 0)         else           let combinedLines = txt : take extraNeeded moreLines-              combined = T.intercalate "\n" combinedLines+              combined = C.intercalate "\n" combinedLines               expanded = expandMacros st combined            in (expanded, extraNeeded)  -- | Count how many extra lines a function macro call consumes. -- Scans the first line for an identifier that matches a function macro, -- then checks if parseCallArgs needs to span into continuation lines.-countExtraLinesConsumed :: EngineState -> Text -> [Text] -> Int-countExtraLinesConsumed st txt moreLines = scanForFunctionMacro False False False txt+countExtraLinesConsumed :: EngineState -> ByteString -> [ByteString] -> Int+countExtraLinesConsumed st txt moreLines+  -- A module that defines no function-like macro cannot have a call+  -- spanning lines, and most do not; skipping the scan saves a second+  -- walk over every line of the file.+  | funBloom == 0 = 0+  | otherwise = scanForFunctionMacro False False False txt   where     macros = stMacros st+    funBloom = stFunMacroBloom st -    scanForFunctionMacro :: Bool -> Bool -> Bool -> Text -> Int-    scanForFunctionMacro _ _ _ t | T.null t = 0+    scanForFunctionMacro :: Bool -> Bool -> Bool -> ByteString -> Int+    scanForFunctionMacro _ _ _ t | C.null t = 0     scanForFunctionMacro inString inChar escaped t =-      case T.uncons t of+      case C.uncons t of         Nothing -> 0         Just (c, rest)           | inString ->@@ -84,23 +93,25 @@           | c == '"' -> scanForFunctionMacro True False False rest           | c == '\'' -> scanForFunctionMacro False True False rest           | isIdentStart c ->-              let (ident, rest') = T.span isIdentChar t-               in case M.lookup ident macros of-                    Just (FunctionMacro _ _) ->-                      case tryMultilineCallArgs rest' of-                        Just n -> n-                        Nothing -> scanForFunctionMacro False False False rest'-                    _ -> scanForFunctionMacro False False False rest'+              let (ident, rest') = C.span isIdentChar t+               in if not (bloomMember funBloom (BS.head ident))+                    then scanForFunctionMacro False False False rest'+                    else case M.lookup ident macros of+                      Just (FunctionMacro _ _) ->+                        case tryMultilineCallArgs rest' of+                          Just n -> n+                          Nothing -> scanForFunctionMacro False False False rest'+                      _ -> scanForFunctionMacro False False False rest'           | otherwise -> scanForFunctionMacro False False False rest      -- Try to parse function call args, potentially spanning multiple lines.     -- Returns Just n if the call spans n extra lines, Nothing if no call.-    tryMultilineCallArgs :: Text -> Maybe Int-    tryMultilineCallArgs rest = seekOpenParen (T.dropWhile isSpace rest) 0+    tryMultilineCallArgs :: ByteString -> Maybe Int+    tryMultilineCallArgs rest = seekOpenParen (C.dropWhile isSpaceChar rest) 0 -    seekOpenParen :: Text -> Int -> Maybe Int+    seekOpenParen :: ByteString -> Int -> Maybe Int     seekOpenParen remaining extraLines =-      case T.uncons remaining of+      case C.uncons remaining of         Just ('(', afterOpen) ->           findClosingParen 0 afterOpen extraLines         Just _ ->@@ -109,20 +120,20 @@           case drop extraLines moreLines of             [] -> Nothing             (nextLine : _) ->-              seekOpenParen (T.dropWhile isSpace nextLine) (extraLines + 1)+              seekOpenParen (C.dropWhile isSpaceChar nextLine) (extraLines + 1) -    findClosingParen :: Int -> Text -> Int -> Maybe Int+    findClosingParen :: Int -> ByteString -> Int -> Maybe Int     findClosingParen = goClosing False False False       where-        goClosing :: Bool -> Bool -> Bool -> Int -> Text -> Int -> Maybe Int+        goClosing :: Bool -> Bool -> Bool -> Int -> ByteString -> Int -> Maybe Int         goClosing inString inChar escaped depth remaining extraLines =-          case T.uncons remaining of+          case C.uncons remaining of             Nothing ->               -- Need more lines               case drop extraLines moreLines of                 [] -> Nothing -- No more lines, unclosed call                 (nextLine : _) ->-                  goClosing inString inChar escaped depth (T.cons '\n' nextLine) (extraLines + 1)+                  goClosing inString inChar escaped depth (C.cons '\n' nextLine) (extraLines + 1)             Just (ch, rest)               | inString ->                   let escaped' = ch == '\\' && not escaped@@ -142,246 +153,389 @@               | ch == ')' -> Just extraLines               | otherwise -> goClosing False False False depth rest extraLines --- | Blue-paint macro expansion engine. Uses a suppression set (@painted@)--- to prevent infinite recursion instead of iterating to a fixpoint.--- Output is accumulated via a lazy 'TB.Builder' for amortized O(n).-expandBlue :: EngineState -> Set Text -> Bool -> Bool -> Bool -> TB.Builder -> TB.Builder-expandBlue st painted inString inChar escaped input =-  let txt = builderToText input-   in goText st painted inString inChar escaped txt mempty+-- | Blue-paint macro expansion: expand @txt@, leaving any name in+-- @painted@ alone so that a macro cannot re-enter itself. A single pass+-- with a suppression set replaces the previous iterate-up-to-32 fixpoint+-- approach.+--+-- The scan walks byte offsets and copies nothing until a macro actually+-- expands, so text that names no macro comes back as the very+-- 'ByteString' that went in. That is the case that matters: this runs on+-- every line of every module, and almost no line expands anything.+expandWith :: EngineState -> Set ByteString -> ByteString -> ByteString+expandWith st painted txt0 =+  case scan txt0 0 0 False False False mempty False of+    (_, False) -> txt0+    (acc, True) -> builderToBytes acc+  where+    macros = stMacros st+    bloom = stMacroBloom st --- | Walk the input text, expanding macros with blue-paint suppression.-goText :: EngineState -> Set Text -> Bool -> Bool -> Bool -> Text -> TB.Builder -> TB.Builder-goText _ _ _ _ _ txt acc | T.null txt = acc-goText st painted inString inChar escaped txt acc =-  case T.uncons txt of-    Nothing -> acc-    Just (c, rest)-      | inString ->-          let escaped' = c == '\\' && not escaped-              inString' = not (c == '"' && not escaped)-           in goText st painted inString' False escaped' rest (acc <> TB.singleton c)-      | inChar ->-          let escaped' = c == '\\' && not escaped-              inChar' = not (c == '\'' && not escaped)-           in goText st painted False inChar' escaped' rest (acc <> TB.singleton c)-      | startsHsBlockComment txt ->-          let (commentText, remaining) = consumeHsBlockComment txt-           in goText st painted False False False remaining (acc <> TB.fromText commentText)-      | c == '"' ->-          goText st painted True False False rest (acc <> TB.singleton c)-      | c == '\'' ->-          goText st painted False True False rest (acc <> TB.singleton c)-      | isIdentStart c ->-          expandIdentBlue st painted txt acc-      | c == '-',-        Just ('-', _) <- T.uncons rest ->-          -- Haskell line comment: copy remainder verbatim without macro expansion-          acc <> TB.fromText txt-      | otherwise ->-          goText st painted False False False rest (acc <> TB.singleton c)+    -- \| @scan buf i flushed inString inChar escaped acc changed@ walks+    -- @buf@ from offset @i@; everything before @flushed@ is already in+    -- @acc@. An expansion may continue in a different buffer (a+    -- function-like call whose argument list held a line comment is+    -- rewritten), so the buffer travels with the loop.+    scan :: ByteString -> Int -> Int -> Bool -> Bool -> Bool -> BSB.Builder -> Bool -> (BSB.Builder, Bool)+    scan !buf !i !flushed !inString !inChar !escaped acc !changed+      | i >= len = (acc <> slice buf flushed len, changed)+      -- Matched against a 'case' rather than bound in a @where@: a+      -- @where@ binding the end-of-input guard does not use is a thunk,+      -- and this loop runs once per byte of the corpus.+      | otherwise = case BS.index buf i of+          c+            | inString ->+                let escaped' = c == 0x5C && not escaped -- '\\'+                    inString' = escaped || c /= 0x22 -- '"'+                 in scan buf (i + 1) flushed inString' False escaped' acc changed+            | inChar ->+                let escaped' = c == 0x5C && not escaped -- '\\'+                    inChar' = escaped || c /= 0x27 -- '\''+                 in scan buf (i + 1) flushed False inChar' escaped' acc changed+            | c == 0x22 -> scan buf (i + 1) flushed True False False acc changed -- '"'+            | c == 0x27 -> scan buf (i + 1) flushed False True False acc changed -- '\''+            | isIdentStartByte c -> expandIdent buf i flushed acc changed+            -- A block comment can only open on '{', so the three-byte test+            -- is gated on that byte rather than run against every byte.+            | c == 0x7B && startsHsComment buf len i ->+                -- Copied through verbatim, so there is nothing to flush.+                scan buf (hsCommentEnd buf i) flushed False False False acc changed+            | c == 0x2D && i + 1 < len && BS.index buf (i + 1) == 0x2D ->+                -- Haskell line comment: the rest is not expanded.+                (acc <> slice buf flushed len, changed)+            | otherwise ->+                scan buf (skipDull buf len (i + 1)) flushed False False False acc changed+      where+        len = BS.length buf --- | Handle an identifier during blue-paint expansion.-expandIdentBlue :: EngineState -> Set Text -> Text -> TB.Builder -> TB.Builder-expandIdentBlue st painted txt acc =-  let (ident, rest) = T.span isIdentChar txt-   in if S.member ident painted-        then -- Blue-painted: copy verbatim, don't expand-          goText st painted False False False rest (acc <> TB.fromText ident)-        else case ident of-          "__LINE__" ->-            goText st painted False False False rest (acc <> TB.fromString (show (stCurrentLine st)))-          "__FILE__" ->-            goText st painted False False False rest (acc <> TB.fromString (show (stCurrentFile st)))-          _ ->-            case M.lookup ident (stMacros st) of-              Just (ObjectMacro replacement) ->-                let painted' = S.insert ident painted-                    replacement' = normalizeObjectReplacement replacement-                    expanded = builderToText (goText st painted' False False False replacement' mempty)-                 in goText st painted False False False rest (acc <> TB.fromText expanded)-              Just (FunctionMacro params body) ->-                case parseCallArgs rest of-                  Nothing ->-                    goText st painted False False False rest (acc <> TB.fromText ident)-                  Just (args, restAfter)-                    | length args == length params ->-                        let body' = substituteParamsBuilder (M.fromList (zip params args)) body-                            painted' = S.insert ident painted-                            expanded = builderToText (goText st painted' False False False body' mempty)-                         in goText st painted False False False restAfter (acc <> TB.fromText expanded)-                    | otherwise ->-                        goText st painted False False False rest (acc <> TB.fromText ident)-              Nothing ->-                goText st painted False False False rest (acc <> TB.fromText ident)+    -- \| Handle the identifier starting at @i@.+    --+    -- Split in two so that the common case — an identifier that can name+    -- no macro — allocates nothing. Everything the rare path needs+    -- (@name@, the painted set, the continuations) would otherwise be a+    -- thunk built once per identifier in the corpus.+    expandIdent :: ByteString -> Int -> Int -> BSB.Builder -> Bool -> (BSB.Builder, Bool)+    expandIdent !buf !i !flushed acc !changed+      -- No macro name starts with this byte: much the commonest outcome,+      -- and it costs one bit test rather than a walk of the macro map.+      | not (bloomMember bloom (BS.index buf i)) =+          scan buf end flushed False False False acc changed+      | otherwise = expandNamed buf i end (substr buf i end) flushed acc changed+      where+        !end = identEnd buf i +    -- \| Handle an identifier whose first byte a macro name could share.+    expandNamed :: ByteString -> Int -> Int -> ByteString -> Int -> BSB.Builder -> Bool -> (BSB.Builder, Bool)+    expandNamed !buf !i !end !name !flushed acc !changed+      | S.member name painted = verbatim+      | name == "__LINE__" = replaceWith (BSB.string8 (show (stCurrentLine st)))+      | name == "__FILE__" = replaceWith (BSB.string8 (show (stCurrentFile st)))+      | otherwise =+          case M.lookup name macros of+            Just (ObjectMacro replacement) ->+              replaceWith+                ( BSB.byteString+                    (expandWith st painted' (normalizeObjectReplacement replacement))+                )+            Just (FunctionMacro params body) ->+              case parseCallArgs (BS.drop end buf) of+                Just (args, restAfter)+                  | length args == length params ->+                      -- Arguments are expanded in the caller's paint context,+                      -- before @name@ is painted, so a nested call to the+                      -- same macro inside an argument still expands.+                      let macroArgs = map (macroArg st painted) args+                          body' = substituteMacroArgs (M.fromList (zip params macroArgs)) body+                          expanded = expandWith st painted' body'+                       in scan+                            restAfter+                            0+                            0+                            False+                            False+                            False+                            (acc <> slice buf flushed i <> BSB.byteString expanded)+                            True+                _ -> verbatim+            Nothing -> verbatim+      where+        painted' = S.insert name painted+        verbatim = scan buf end flushed False False False acc changed+        replaceWith b =+          scan buf end end False False False (acc <> slice buf flushed i <> b) True++-- | The offset just past the identifier starting at @i@.+identEnd :: ByteString -> Int -> Int+identEnd buf = go+  where+    len = BS.length buf+    -- The @i < len@ test guards the read on the same line: this is the+    -- innermost loop of the scan and the bounds check doubled its cost.+    go !i+      | i < len && isIdentByte (BSU.unsafeIndex buf i) = go (i + 1)+      | otherwise = i++-- | Advance past bytes that can neither start an identifier nor open a+-- literal or a comment, so runs of whitespace, digits and punctuation are+-- stepped over without re-entering the guard chain per byte.+skipDull :: ByteString -> Int -> Int -> Int+skipDull buf len = go+  where+    -- The @i < len@ test guards the read on the same line: this is the+    -- innermost loop of the scan and the bounds check doubled its cost.+    go !i+      | i < len && isDullByte (BSU.unsafeIndex buf i) = go (i + 1)+      | otherwise = i++isDullByte :: Word8 -> Bool+isDullByte b =+  not (isIdentStartByte b)+    && b /= 0x22 -- '"'+    && b /= 0x27 -- '\''+    && b /= 0x7B -- '{'+    && b /= 0x2D -- '-'+{-# INLINE isDullByte #-}++-- | Given that @buf@ has @{@ at @i@, does a Haskell block comment open+-- there? @{-#@ is a pragma, not a comment.+startsHsComment :: ByteString -> Int -> Int -> Bool+startsHsComment buf len i =+  i + 1 < len+    && BS.index buf (i + 1) == 0x2D -- '-'+    && (i + 2 >= len || BS.index buf (i + 2) /= 0x23) -- '#'++-- | The offset just past the Haskell block comment opening at @i@, or the+-- end of the buffer if it is never closed.+hsCommentEnd :: ByteString -> Int -> Int+hsCommentEnd buf = go (0 :: Int)+  where+    len = BS.length buf+    go :: Int -> Int -> Int+    go !depth !i+      | i + 1 >= len = len+      | b2 == 0x2D && b1 == 0x7B = go (depth + 1) (i + 2) -- '{-'+      | b2 == 0x7D && b1 == 0x2D = if depth <= 1 then i + 2 else go (depth - 1) (i + 2) -- '-}'+      | otherwise = go depth (i + 1)+      where+        b1 = BS.index buf i+        b2 = BS.index buf (i + 1)++-- | Byte-level 'isIdentStart'. See 'Aihc.Cpp.Parser.isIdentStart' for why+-- every byte >= 0x80 qualifies.+isIdentStartByte :: Word8 -> Bool+isIdentStartByte b =+  b == 0x5F -- '_'+    || (b >= 0x41 && b <= 0x5A) -- 'A'-'Z'+    || (b >= 0x61 && b <= 0x7A) -- 'a'-'z'+    || b >= 0x80+{-# INLINE isIdentStartByte #-}++-- | Byte-level 'Aihc.Cpp.Parser.isIdentChar'.+isIdentByte :: Word8 -> Bool+isIdentByte b = isIdentStartByte b || (b >= 0x30 && b <= 0x39)+{-# INLINE isIdentByte #-}++-- | The bytes of @buf@ in @[from, to)@, as a zero-copy slice.+substr :: ByteString -> Int -> Int -> ByteString+substr buf from to = BS.take (to - from) (BS.drop from buf)+{-# INLINE substr #-}++slice :: ByteString -> Int -> Int -> BSB.Builder+slice buf from to+  | to <= from = mempty+  | otherwise = BSB.byteString (substr buf from to)+{-# INLINE slice #-}++-- | A function-like macro argument in both the forms the replacement list+-- can need: the raw spelling (used by @#@ and @##@, which see arguments+-- unexpanded) and the macro-expanded spelling (used everywhere else).+data MacroArg = MacroArg+  { macroArgRaw :: !ByteString,+    macroArgExpanded :: !ByteString+  }++-- | Build a 'MacroArg' by expanding the argument text in the paint context of+-- the call site.+macroArg :: EngineState -> Set ByteString -> ByteString -> MacroArg+macroArg st painted raw = MacroArg raw (expandWith st painted raw)+ -- | Normalize comments inside object-like macro replacement text while -- preserving string and char literals. cpphs replaces @/* ... */@ with spaces -- matching the width of the comment body, but treats empty @/**/@ as a token -- pasting hack with zero width.-normalizeObjectReplacement :: Text -> Text-normalizeObjectReplacement = T.stripEnd . go False False False mempty+normalizeObjectReplacement :: ByteString -> ByteString+normalizeObjectReplacement = C.dropWhileEnd isSpaceChar . go False False False mempty   where-    go :: Bool -> Bool -> Bool -> TB.Builder -> Text -> Text-    go _ _ _ acc txt | T.null txt = builderToText acc+    go :: Bool -> Bool -> Bool -> BSB.Builder -> ByteString -> ByteString+    go _ _ _ acc txt | C.null txt = builderToBytes acc     go inString inChar escaped acc txt =-      case T.uncons txt of-        Nothing -> builderToText acc+      case C.uncons txt of+        Nothing -> builderToBytes acc         Just (c, rest)           | inString ->               let escaped' = c == '\\' && not escaped                   inString' = not (c == '"' && not escaped)-               in go inString' False escaped' (acc <> TB.singleton c) rest+               in go inString' False escaped' (acc <> BSB.char8 c) rest           | inChar ->               let escaped' = c == '\\' && not escaped                   inChar' = not (c == '\'' && not escaped)-               in go False inChar' escaped' (acc <> TB.singleton c) rest-          | c == '"' -> go True False False (acc <> TB.singleton c) rest-          | c == '\'' -> go False True False (acc <> TB.singleton c) rest-          | "/*" `T.isPrefixOf` txt ->+               in go False inChar' escaped' (acc <> BSB.char8 c) rest+          | c == '"' -> go True False False (acc <> BSB.char8 c) rest+          | c == '\'' -> go False True False (acc <> BSB.char8 c) rest+          | "/*" `C.isPrefixOf` txt ->               let (commentText, remaining) = consumeCBlockComment txt                   replacement = commentReplacement commentText-               in go False False False (acc <> TB.fromText replacement) remaining+               in go False False False (acc <> BSB.byteString replacement) remaining           | otherwise ->-              go False False False (acc <> TB.singleton c) rest+              go False False False (acc <> BSB.char8 c) rest -consumeCBlockComment :: Text -> (Text, Text)+consumeCBlockComment :: ByteString -> (ByteString, ByteString) consumeCBlockComment txt =-  let afterOpen = T.drop 2 txt-      (inside, suffix) = T.breakOn "*/" afterOpen-   in if T.null suffix+  let afterOpen = C.drop 2 txt+      (inside, suffix) = BS.breakSubstring "*/" afterOpen+   in if C.null suffix         then (txt, "")-        else ("/*" <> inside <> "*/", T.drop 2 suffix)+        else ("/*" <> inside <> "*/", C.drop 2 suffix) -commentReplacement :: Text -> Text+commentReplacement :: ByteString -> ByteString commentReplacement commentText   | commentText == "/**/" = ""-  | otherwise = T.replicate (T.length (commentBody commentText)) " "+  | otherwise = C.replicate (charWidth (commentBody commentText)) ' ' -commentBody :: Text -> Text+-- | Number of characters in a UTF-8 buffer, for column alignment: count+-- every byte that is not a UTF-8 continuation byte. On valid UTF-8 this+-- is the character count; on anything else it degrades gracefully instead+-- of failing, and on ASCII it is just the length.+charWidth :: ByteString -> Int+charWidth = BS.foldl' step 0+  where+    step !n b = if b .&. 0xC0 == 0x80 then n else n + 1++commentBody :: ByteString -> ByteString commentBody commentText =-  if "/*" `T.isPrefixOf` commentText && "*/" `T.isSuffixOf` commentText-    then T.dropEnd 2 (T.drop 2 commentText)-    else T.drop 2 commentText+  if "/*" `C.isPrefixOf` commentText && "*/" `C.isSuffixOf` commentText+    then C.take (C.length commentText - 4) (C.drop 2 commentText)+    else C.drop 2 commentText  -- | Parse function-like macro call arguments.-parseCallArgs :: Text -> Maybe ([Text], Text)+parseCallArgs :: ByteString -> Maybe ([ByteString], ByteString) parseCallArgs input = do-  ('(', rest) <- T.uncons (T.dropWhile isSpace input)+  ('(', rest) <- C.uncons (C.dropWhile isSpaceChar input)   parseArgs False False False 0 [] mempty rest -parseArgs :: Bool -> Bool -> Bool -> Int -> [Text] -> TB.Builder -> Text -> Maybe ([Text], Text)+parseArgs :: Bool -> Bool -> Bool -> Int -> [ByteString] -> BSB.Builder -> ByteString -> Maybe ([ByteString], ByteString) parseArgs inString inChar escaped depth argsRev current remaining =-  case T.uncons remaining of+  case C.uncons remaining of     Nothing -> Nothing     Just (ch, rest)       | inString ->           let escaped' = ch == '\\' && not escaped               inString' = not (ch == '"' && not escaped)-           in parseArgs inString' False escaped' depth argsRev (current <> TB.singleton ch) rest+           in parseArgs inString' False escaped' depth argsRev (current <> BSB.char8 ch) rest       | inChar ->           let escaped' = ch == '\\' && not escaped               inChar' = not (ch == '\'' && not escaped)-           in parseArgs False inChar' escaped' depth argsRev (current <> TB.singleton ch) rest+           in parseArgs False inChar' escaped' depth argsRev (current <> BSB.char8 ch) rest       | startsHsBlockComment remaining ->           let (commentText, afterComment) = consumeHsBlockComment remaining-           in parseArgs False False False depth argsRev (current <> TB.fromText commentText) afterComment+           in parseArgs False False False depth argsRev (current <> BSB.byteString commentText) afterComment       | ch == '"' ->-          parseArgs True False False depth argsRev (current <> TB.singleton ch) rest+          parseArgs True False False depth argsRev (current <> BSB.char8 ch) rest       | ch == '\'' ->-          parseArgs False True False depth argsRev (current <> TB.singleton ch) rest+          parseArgs False True False depth argsRev (current <> BSB.char8 ch) rest       | ch == '(' ->-          parseArgs False False False (depth + 1) argsRev (current <> TB.singleton ch) rest+          parseArgs False False False (depth + 1) argsRev (current <> BSB.char8 ch) rest       | ch == ')' && depth > 0 ->-          parseArgs False False False (depth - 1) argsRev (current <> TB.singleton ch) rest+          parseArgs False False False (depth - 1) argsRev (current <> BSB.char8 ch) rest       | ch == ')' && depth == 0 ->-          let arg = trimSpacesText (builderToText current)+          let arg = trimSpacesBytes (builderToBytes current)               argsRev' =-                if T.null arg && null argsRev+                if C.null arg && null argsRev                   then [""]                   else arg : argsRev            in Just (reverse argsRev', rest)       | ch == ',' && depth == 0 ->-          let arg = trimSpacesText (builderToText current)+          let arg = trimSpacesBytes (builderToBytes current)            in parseArgs False False False depth (arg : argsRev) mempty rest       | ch == '-' && depth == 0,-        Just ('-', afterDash) <- T.uncons rest ->+        Just ('-', afterDash) <- C.uncons rest ->           -- Haskell line comment inside arg list: close the arg, find ')' in comment           let commentText = "--" <> afterDash            in case findLastCloseParen commentText of                 Nothing -> Nothing                 Just (commentPrefix, afterClose) ->-                  let currentText = builderToText current-                      arg = trimSpacesText currentText-                      trailingWS = T.takeWhileEnd isSpace currentText-                      argsRev' = if T.null arg && null argsRev then [""] else arg : argsRev+                  let currentText = builderToBytes current+                      arg = trimSpacesBytes currentText+                      trailingWS = C.takeWhileEnd isSpaceChar currentText+                      argsRev' = if C.null arg && null argsRev then [""] else arg : argsRev                    in Just (reverse argsRev', trailingWS <> commentPrefix <> afterClose)       | otherwise ->-          parseArgs False False False depth argsRev (current <> TB.singleton ch) rest+          parseArgs False False False depth argsRev (current <> BSB.char8 ch) rest  -- | Find the last ')' in text and split before it.-findLastCloseParen :: Text -> Maybe (Text, Text)+findLastCloseParen :: ByteString -> Maybe (ByteString, ByteString) findLastCloseParen txt =-  case T.findIndex (== ')') (T.reverse txt) of+  case C.elemIndexEnd ')' txt of     Nothing -> Nothing-    Just revIdx ->-      let idx = T.length txt - revIdx - 1-       in Just (T.take idx txt, T.drop (idx + 1) txt)+    Just idx -> Just (C.take idx txt, C.drop (idx + 1) txt) -startsHsBlockComment :: Text -> Bool+startsHsBlockComment :: ByteString -> Bool startsHsBlockComment txt =-  case T.uncons txt of+  case C.uncons txt of     Just ('{', rest) ->-      case T.uncons rest of+      case C.uncons rest of         Just ('-', rest') ->-          case T.uncons rest' of+          case C.uncons rest' of             Just ('#', _) -> False             _ -> True         _ -> False     _ -> False -consumeHsBlockComment :: Text -> (Text, Text)+consumeHsBlockComment :: ByteString -> (ByteString, ByteString) consumeHsBlockComment = go 0 mempty   where-    go :: Int -> TB.Builder -> Text -> (Text, Text)+    go :: Int -> BSB.Builder -> ByteString -> (ByteString, ByteString)     go depth acc txt =-      case T.uncons txt of-        Nothing -> (builderToText acc, "")+      case C.uncons txt of+        Nothing -> (builderToBytes acc, "")         Just (c, rest) ->-          case T.uncons rest of+          case C.uncons rest of             Just ('-', rest')               | c == '{' ->-                  go (depth + 1) (acc <> TB.fromText "{-") rest'+                  go (depth + 1) (acc <> BSB.byteString "{-") rest'             Just ('}', rest')               | c == '-' && depth <= 1 ->-                  (builderToText (acc <> TB.fromText "-}"), rest')+                  (builderToBytes (acc <> BSB.byteString "-}"), rest')             Just ('}', rest')               | c == '-' ->-                  go (depth - 1) (acc <> TB.fromText "-}") rest'+                  go (depth - 1) (acc <> BSB.byteString "-}") rest'             _ ->-              go depth (acc <> TB.singleton c) rest+              go depth (acc <> BSB.char8 c) rest  data Piece-  = PieceWhitespace !Text+  = PieceWhitespace !ByteString   | PiecePaste-  | PieceRaw !Text-  | PieceParam !Text+  | PieceRaw !ByteString+  | PieceParam !ByteString -substituteParams :: Map Text Text -> Text -> Text-substituteParams = substituteParamsBuilder+substituteParams :: Map ByteString ByteString -> ByteString -> ByteString+substituteParams subs = substituteMacroArgs (M.map (\arg -> MacroArg arg arg) subs)  -- | Builder-based parameter substitution. Replaces identifiers found -- in the substitution map, respecting string and char literals.-substituteParamsBuilder :: Map Text Text -> Text -> Text-substituteParamsBuilder subs = renderPieces . collapseTokenPastes . collapseStringizing . tokenizeReplacementList+--+-- Parameters render as their macro-expanded argument, except as operands of+-- @#@ and @##@, which use the raw argument text.+substituteMacroArgs :: Map ByteString MacroArg -> ByteString -> ByteString+substituteMacroArgs subs = renderPieces . collapseTokenPastes . collapseStringizing . tokenizeReplacementList   where-    tokenizeReplacementList :: Text -> [Piece]+    tokenizeReplacementList :: ByteString -> [Piece]     tokenizeReplacementList txt =-      case T.uncons txt of+      case C.uncons txt of         Nothing -> []         Just (c, rest)-          | isSpace c ->-              let (spaces, remaining) = T.span isSpace txt+          | isSpaceChar c ->+              let (spaces, remaining) = C.span isSpaceChar txt                in PieceWhitespace spaces : tokenizeReplacementList remaining           | c == '"' ->               let (literal, remaining) = scanQuoted '"' txt@@ -389,143 +543,148 @@           | c == '\'' ->               let (literal, remaining) = scanQuoted '\'' txt                in PieceRaw literal : tokenizeReplacementList remaining-          | "/*" `T.isPrefixOf` txt ->+          | "/*" `C.isPrefixOf` txt ->               let (commentText, remaining) = consumeCBlockComment txt                   piece = if commentText == "/**/" then PiecePaste else PieceWhitespace (commentReplacement commentText)                in piece : tokenizeReplacementList remaining-          | "##" `T.isPrefixOf` txt ->-              PiecePaste : tokenizeReplacementList (T.drop 2 txt)+          | "##" `C.isPrefixOf` txt ->+              PiecePaste : tokenizeReplacementList (C.drop 2 txt)           | isIdentStart c ->-              let (ident, remaining) = T.span isIdentChar txt+              let (ident, remaining) = C.span isIdentChar txt                   piece = if M.member ident subs then PieceParam ident else PieceRaw ident                in piece : tokenizeReplacementList remaining           | otherwise ->-              PieceRaw (T.singleton c) : tokenizeReplacementList rest+              PieceRaw (C.singleton c) : tokenizeReplacementList rest -    scanQuoted :: Char -> Text -> (Text, Text)+    scanQuoted :: Char -> ByteString -> (ByteString, ByteString)     scanQuoted quote = go False mempty       where         go escaped acc remaining =-          case T.uncons remaining of-            Nothing -> (builderToText acc, "")+          case C.uncons remaining of+            Nothing -> (builderToBytes acc, "")             Just (c, rest)               | c == quote && not escaped ->-                  (builderToText (acc <> TB.singleton c), rest)+                  (builderToBytes (acc <> BSB.char8 c), rest)               | c == '\\' ->-                  go (not escaped) (acc <> TB.singleton c) rest+                  go (not escaped) (acc <> BSB.char8 c) rest               | otherwise ->-                  go False (acc <> TB.singleton c) rest+                  go False (acc <> BSB.char8 c) rest      collapseStringizing :: [Piece] -> [Piece]     collapseStringizing [] = []     collapseStringizing (PieceRaw "#" : PieceParam name : rest) =-      PieceRaw (stringizeArgument (lookupParam name)) : collapseStringizing rest+      PieceRaw (stringizeArgument (lookupParamRaw name)) : collapseStringizing rest     collapseStringizing (PieceRaw "#" : rest) =       PieceRaw "#" : collapseStringizing rest     collapseStringizing (piece : rest) = piece : collapseStringizing rest +    -- The accumulator is held reversed: appending to the end of a list once+    -- per piece is quadratic, and a macro body expanded on every line of a+    -- module makes that the single hottest allocation in the preprocessor.+    -- Reversed, the piece to the left of a @##@ is just the head.     collapseTokenPastes :: [Piece] -> [Piece]     collapseTokenPastes = go []       where-        go acc [] = acc+        go acc [] = reverse acc         go acc (piece : rest) =           case piece of             PiecePaste ->-              let (accNoSpace, _) = trimTrailingWhitespace acc+              let accNoSpace = dropWhile isWhitespacePiece acc                   (leadingSpace, restAfterSpace) = span isWhitespacePiece rest-               in case (unsnoc accNoSpace, restAfterSpace) of-                    (Just (accInit, leftPiece), rightPiece : remaining) ->-                      go (accInit <> [PieceRaw (renderPiece leftPiece <> renderPiece rightPiece)]) remaining-                    _ -> go (acc <> [PieceRaw "##"] <> leadingSpace) restAfterSpace-            _ -> go (acc <> [piece]) rest--    trimTrailingWhitespace :: [Piece] -> ([Piece], [Piece])-    trimTrailingWhitespace pieces =-      let (trailingRev, restRev) = span isWhitespacePiece (reverse pieces)-       in (reverse restRev, reverse trailingRev)--    unsnoc :: [a] -> Maybe ([a], a)-    unsnoc [] = Nothing-    unsnoc [x] = Just ([], x)-    unsnoc (x : xs) = do-      (init', last') <- unsnoc xs-      pure (x : init', last')+               in case (accNoSpace, restAfterSpace) of+                    (leftPiece : accInit, rightPiece : remaining) ->+                      go (PieceRaw (renderPieceRaw leftPiece <> renderPieceRaw rightPiece) : accInit) remaining+                    _ -> go (reverse leadingSpace <> (PieceRaw "##" : acc)) restAfterSpace+            _ -> go (piece : acc) rest      isWhitespacePiece :: Piece -> Bool     isWhitespacePiece (PieceWhitespace _) = True     isWhitespacePiece _ = False -    lookupParam :: Text -> Text-    lookupParam name = M.findWithDefault name name subs+    lookupParamWith :: (MacroArg -> ByteString) -> ByteString -> ByteString+    lookupParamWith field name = maybe name field (M.lookup name subs) -    renderPieces :: [Piece] -> Text-    renderPieces = T.concat . map renderPiece+    lookupParamRaw :: ByteString -> ByteString+    lookupParamRaw = lookupParamWith macroArgRaw -    renderPiece :: Piece -> Text-    renderPiece piece =+    renderPieces :: [Piece] -> ByteString+    renderPieces = C.concat . map renderPiece++    renderPiece :: Piece -> ByteString+    renderPiece = renderPieceWith macroArgExpanded++    -- \| Render an operand of @##@, which sees the raw argument text.+    renderPieceRaw :: Piece -> ByteString+    renderPieceRaw = renderPieceWith macroArgRaw++    renderPieceWith :: (MacroArg -> ByteString) -> Piece -> ByteString+    renderPieceWith field piece =       case piece of         PieceWhitespace txt -> txt         PiecePaste -> "##"         PieceRaw txt -> txt-        PieceParam name -> lookupParam name+        PieceParam name -> lookupParamWith field name -    stringizeArgument :: Text -> Text+    stringizeArgument :: ByteString -> ByteString     stringizeArgument arg =       let normalized = normalizeWhitespace arg-          escaped = T.concatMap escapeStringChar normalized-       in T.cons '"' (T.snoc escaped '"')+          escaped = C.concatMap escapeStringChar normalized+       in C.cons '"' (C.snoc escaped '"') -    normalizeWhitespace :: Text -> Text-    normalizeWhitespace = T.unwords . T.words+    -- Not 'C.words'/'C.unwords': those treat byte 0xA0 as whitespace and+    -- would split a multi-byte character down the middle.+    normalizeWhitespace :: ByteString -> ByteString+    normalizeWhitespace =+      C.intercalate " " . filter (not . C.null) . C.splitWith isSpaceChar -    escapeStringChar :: Char -> Text+    escapeStringChar :: Char -> ByteString     escapeStringChar '"' = "\\\""     escapeStringChar '\\' = "\\\\"-    escapeStringChar c = T.singleton c+    escapeStringChar c = C.singleton c -evalCondition :: EngineState -> Text -> Bool+evalCondition :: EngineState -> ByteString -> Bool evalCondition st expr = eval expr /= 0   where     macros = stMacros st     eval = evalNumeric . replaceRemainingWithZero . expandMacros st . replaceDefined macros -evalNumeric :: Text -> Integer+evalNumeric :: ByteString -> Integer evalNumeric input =   let tokens = tokenize input    in case parseExpr tokens of         (val, _) -> val -data Token = TOp Text | TNum Integer | TIdent Text | TOpenParen | TCloseParen deriving (Show)+data Token = TOp ByteString | TNum Integer | TIdent ByteString | TOpenParen | TCloseParen deriving (Show) -tokenize :: Text -> [Token]+tokenize :: ByteString -> [Token] tokenize input =-  case T.uncons input of+  case C.uncons input of     Nothing -> []     Just (c, rest)-      | isSpace c ->-          tokenize (T.dropWhile isSpace rest)+      | isSpaceChar c ->+          tokenize (C.dropWhile isSpaceChar rest)       | isDigit c ->-          let (num, remaining) = T.span isDigit input-           in case TR.decimal num of-                Right (value, _) -> TNum value : tokenize remaining-                Left _ -> tokenize remaining+          let (num, remaining) = C.span isDigit input+           in case C.readInteger num of+                Just (value, _) -> TNum value : tokenize remaining+                Nothing -> tokenize remaining       | isIdentStart c ->-          let (ident, remaining) = T.span isIdentChar input+          let (ident, remaining) = C.span isIdentChar input            in TIdent ident : tokenize remaining       | c == '(' ->           TOpenParen : tokenize rest       | c == ')' ->           TCloseParen : tokenize rest       | otherwise ->-          let (op, remaining) = T.span isOpChar input-           in if T.null op+          let (op, remaining) = C.span isOpChar input+           in if C.null op                 then tokenize rest                 else TOp op : tokenize remaining  parseExpr :: [Token] -> (Integer, [Token]) parseExpr = parseOr -binary :: ([Token] -> (Integer, [Token])) -> [Text] -> [Token] -> (Integer, [Token])+binary :: ([Token] -> (Integer, [Token])) -> [ByteString] -> [Token] -> (Integer, [Token]) binary next ops ts =   let (v1, ts1) = next ts    in go v1 ts1@@ -574,32 +733,32 @@         _ -> (v, ts1) parseAtom ts = (0, ts) -replaceDefined :: Map Text MacroDef -> Text -> Text+replaceDefined :: Map ByteString MacroDef -> ByteString -> ByteString replaceDefined macros = go   where     go txt =-      case T.uncons txt of+      case C.uncons txt of         Nothing -> ""         Just (c, rest)-          | "defined" `T.isPrefixOf` txt && not (nextCharIsIdent (T.drop 7 txt)) ->-              expandDefined (T.dropWhile isSpace (T.drop 7 txt))+          | "defined" `C.isPrefixOf` txt && not (nextCharIsIdent (C.drop 7 txt)) ->+              expandDefined (C.dropWhile isSpaceChar (C.drop 7 txt))           | otherwise ->-              T.cons c (go rest)+              C.cons c (go rest)      expandDefined rest =-      case T.uncons rest of+      case C.uncons rest of         Just ('(', restAfterOpen) ->-          let rest' = T.dropWhile isSpace restAfterOpen-              (name, restAfterName0) = T.span isIdentChar rest'-              restAfterName = T.dropWhile isSpace restAfterName0-           in case T.uncons restAfterName of+          let rest' = C.dropWhile isSpaceChar restAfterOpen+              (name, restAfterName0) = C.span isIdentChar rest'+              restAfterName = C.dropWhile isSpaceChar restAfterName0+           in case C.uncons restAfterName of                 Just (')', restAfterClose) ->                   boolLiteral (M.member name macros) <> go restAfterClose                 _ ->                   boolLiteral False <> go restAfterName         _ ->-          let (name, restAfterName) = T.span isIdentChar rest-           in if T.null name+          let (name, restAfterName) = C.span isIdentChar rest+           in if C.null name                 then boolLiteral False <> go rest                 else boolLiteral (M.member name macros) <> go restAfterName @@ -607,25 +766,25 @@     boolLiteral False = " 0 "      nextCharIsIdent remaining =-      case T.uncons remaining of+      case C.uncons remaining of         Just (c, _) -> isIdentChar c         Nothing -> False -replaceRemainingWithZero :: Text -> Text+replaceRemainingWithZero :: ByteString -> ByteString replaceRemainingWithZero = go   where     go txt =-      case T.uncons txt of+      case C.uncons txt of         Nothing -> ""         Just (c, rest)           | isIdentStart c ->-              let (_, remaining) = T.span isIdentChar txt+              let (_, remaining) = C.span isIdentChar txt                in " 0 " <> go remaining           | otherwise ->-              T.cons c (go rest)+              C.cons c (go rest) -builderToText :: TB.Builder -> Text-builderToText = TL.toStrict . TB.toLazyText+builderToBytes :: BSB.Builder -> ByteString+builderToBytes = BSL.toStrict . BSB.toLazyByteString -trimSpacesText :: Text -> Text-trimSpacesText = T.dropWhileEnd isSpace . T.dropWhile isSpace+trimSpacesBytes :: ByteString -> ByteString+trimSpacesBytes = C.dropWhileEnd isSpaceChar . C.dropWhile isSpaceChar

@@ -1,5 +1,14 @@ {-# LANGUAGE OverloadedStrings #-} +-- |+-- Module      : Aihc.Cpp.Parser+-- Description : Directive parsing over raw bytes+-- License     : Unlicense+--+-- Directives are parsed straight from the input bytes. Every character+-- that is significant to the C preprocessor is ASCII, so no decoding is+-- required; bytes >= 0x80 are only ever carried along inside identifiers,+-- macro bodies and message text. module Aihc.Cpp.Parser   ( Directive (..),     parseDirective,@@ -8,54 +17,56 @@     parseInclude,     parseLineDirective,     parseIdentifier,-    parseQuotedText,+    parseQuoted,     parseDefineParams,     isIdentStart,     isIdentChar,     isOpChar,+    isSpaceChar,+    strip,+    stripStart,   ) where  import Aihc.Cpp.Types (IncludeKind (..))-import Data.Char (isAlphaNum, isDigit, isLetter)-import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Text.Read as TR+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as C+import Data.Char (isAsciiLower, isAsciiUpper, isDigit)  data Directive-  = DirDefineObject !Text !Text-  | DirDefineFunction !Text ![Text] !Text-  | DirUndef !Text-  | DirInclude !IncludeKind !Text-  | DirIf !Text-  | DirIfDef !Text-  | DirIfNDef !Text-  | DirElif !Text+  = DirDefineObject !ByteString !ByteString+  | DirDefineFunction !ByteString ![ByteString] !ByteString+  | DirUndef !ByteString+  | DirInclude !IncludeKind !ByteString+  | DirIf !ByteString+  | DirIfDef !ByteString+  | DirIfNDef !ByteString+  | DirElif !ByteString   | DirElse   | DirEndIf   | DirLine !Int !(Maybe FilePath)   | DirPragmaOnce-  | DirWarning !Text-  | DirError !Text-  | DirUnsupported !Text+  | DirWarning !ByteString+  | DirError !ByteString+  | DirUnsupported !ByteString -parseDirective :: Text -> Maybe Directive+parseDirective :: ByteString -> Maybe Directive parseDirective raw =-  let trimmed = T.stripStart raw-   in if "#" `T.isPrefixOf` trimmed+  let trimmed = stripStart raw+   in if "#" `C.isPrefixOf` trimmed         then-          let body = T.stripStart (T.drop 1 trimmed)-           in case T.uncons body of-                Just (c, _) | isLetter c || isDigit c -> parseDirectiveBody body+          let body = stripStart (C.drop 1 trimmed)+           in case C.uncons body of+                Just (c, _) | isIdentStart c || isDigit c -> parseDirectiveBody body                 _ -> Nothing         else Nothing -parseDirectiveBody :: Text -> Maybe Directive+parseDirectiveBody :: ByteString -> Maybe Directive parseDirectiveBody body =-  let (name, rest0) = T.span isIdentChar body-      rest = T.stripStart rest0-   in if T.null name-        then case T.uncons body of+  let (name, rest0) = C.span isIdentChar body+      rest = stripStart rest0+   in if C.null name+        then case C.uncons body of           Just (c, _) | isDigit c -> parseLineDirective body           _ -> Nothing         else case name of@@ -77,77 +88,106 @@           "error" -> Just (DirError rest)           _ -> Nothing -parseLineDirective :: Text -> Maybe Directive+parseLineDirective :: ByteString -> Maybe Directive parseLineDirective body =-  case TR.decimal body of-    Left _ -> Nothing-    Right (lineNumber, rest0) ->-      let rest = T.stripStart rest0-       in case parseQuotedText rest of-            Nothing -> Just (DirLine lineNumber Nothing)-            Just path -> Just (DirLine lineNumber (Just (T.unpack path)))+  case C.uncons body of+    -- 'C.readInt' also accepts a leading sign; a #line number must not.+    Just (c, _) | isDigit c ->+      case C.readInt body of+        Nothing -> Nothing+        Just (lineNumber, rest0) ->+          let rest = stripStart rest0+           in case parseQuoted rest of+                Nothing -> Just (DirLine lineNumber Nothing)+                Just path -> Just (DirLine lineNumber (Just (C.unpack path)))+    _ -> Nothing -parsePragma :: Text -> Maybe Directive+parsePragma :: ByteString -> Maybe Directive parsePragma body =-  case T.words body of-    ["once"] -> Just DirPragmaOnce-    _ -> Nothing+  if strip body == "once" then Just DirPragmaOnce else Nothing -parseDefine :: Text -> Maybe Directive+parseDefine :: ByteString -> Maybe Directive parseDefine rest = do-  let (name, rest0) = T.span isIdentChar rest-  if T.null name+  let (name, rest0) = C.span isIdentChar rest+  if C.null name     then Nothing-    else case T.uncons rest0 of+    else case C.uncons rest0 of       Just ('(', afterOpen) ->         let (params, restAfterParams) = parseDefineParams afterOpen          in case params of               Nothing -> Just (DirUnsupported "define-function-macro")-              Just names -> Just (DirDefineFunction name names (T.stripStart restAfterParams))-      _ -> Just (DirDefineObject name (T.stripStart rest0))+              Just names -> Just (DirDefineFunction name names (stripStart restAfterParams))+      _ -> Just (DirDefineObject name (stripStart rest0)) -parseDefineParams :: Text -> (Maybe [Text], Text)+parseDefineParams :: ByteString -> (Maybe [ByteString], ByteString) parseDefineParams input =-  let (inside, suffix) = T.breakOn ")" input-   in if T.null suffix+  let (inside, suffix) = C.break (== ')') input+   in if C.null suffix         then (Nothing, "")         else-          let rawParams = T.splitOn "," inside-              params = map (T.takeWhile isIdentChar . T.strip) rawParams-           in if T.null (T.strip inside)-                then (Just [], T.drop 1 suffix)+          let rawParams = C.split ',' inside+              params = map (C.takeWhile isIdentChar . strip) rawParams+           in if C.null (strip inside)+                then (Just [], C.drop 1 suffix)                 else-                  if any T.null params-                    then (Nothing, T.drop 1 suffix)-                    else (Just params, T.drop 1 suffix)+                  if any C.null params+                    then (Nothing, C.drop 1 suffix)+                    else (Just params, C.drop 1 suffix) -parseIdentifier :: Text -> Maybe Text+parseIdentifier :: ByteString -> Maybe ByteString parseIdentifier txt =-  let ident = T.takeWhile isIdentChar (T.stripStart txt)-   in if T.null ident then Nothing else Just ident+  let ident = C.takeWhile isIdentChar (stripStart txt)+   in if C.null ident then Nothing else Just ident -parseInclude :: Text -> Maybe Directive+parseInclude :: ByteString -> Maybe Directive parseInclude txt =-  case T.uncons (T.stripStart txt) of+  case C.uncons (stripStart txt) of     Just ('"', rest) ->-      let (path, suffix) = T.breakOn "\"" rest-       in if T.null suffix then Nothing else Just (DirInclude IncludeLocal path)+      let (path, suffix) = C.break (== '"') rest+       in if C.null suffix then Nothing else Just (DirInclude IncludeLocal path)     Just ('<', rest) ->-      let (path, suffix) = T.breakOn ">" rest-       in if T.null suffix then Nothing else Just (DirInclude IncludeSystem path)+      let (path, suffix) = C.break (== '>') rest+       in if C.null suffix then Nothing else Just (DirInclude IncludeSystem path)     _ -> Nothing -parseQuotedText :: Text -> Maybe Text-parseQuotedText txt = do-  ('"', rest) <- T.uncons txt-  let (path, suffix) = T.breakOn "\"" rest-  if T.null suffix then Nothing else Just path+parseQuoted :: ByteString -> Maybe ByteString+parseQuoted txt = do+  ('"', rest) <- C.uncons txt+  let (path, suffix) = C.break (== '"') rest+  if C.null suffix then Nothing else Just path +-- | ASCII whitespace.+--+-- Deliberately not 'Data.Char.isSpace': applied to a byte, that would+-- classify 0xA0 (Latin-1 NBSP, and a perfectly ordinary UTF-8+-- continuation byte) as whitespace and split a multi-byte character in+-- half. For the same reason this module avoids 'C.words' and 'C.strip'.+isSpaceChar :: Char -> Bool+isSpaceChar c =+  c == ' ' || c == '\t' || c == '\n' || c == '\r' || c == '\f' || c == '\v'++-- | Drop leading ASCII whitespace.+stripStart :: ByteString -> ByteString+stripStart = C.dropWhile isSpaceChar++-- | Drop leading and trailing ASCII whitespace.+strip :: ByteString -> ByteString+strip = C.dropWhile isSpaceChar . C.dropWhileEnd isSpaceChar++-- | First character of an identifier.+--+-- Any byte >= 0x80 qualifies, so a non-ASCII identifier is scanned as one+-- token regardless of the source encoding, and a byte that decodes to+-- nothing at all is simply part of whatever token contains it. isIdentStart :: Char -> Bool-isIdentStart c = c == '_' || isLetter c+isIdentStart c = c == '_' || isAsciiAlpha c || c >= '\x80' +-- | Subsequent characters of an identifier. See 'isIdentStart'. isIdentChar :: Char -> Bool-isIdentChar c = c == '_' || isAlphaNum c+isIdentChar c = c == '_' || isAsciiAlpha c || isDigit c || c >= '\x80'++isAsciiAlpha :: Char -> Bool+isAsciiAlpha c = isAsciiLower c || isAsciiUpper c  isOpChar :: Char -> Bool isOpChar c =

@@ -12,26 +12,24 @@  import Aihc.Cpp.Cursor   ( Cursor (..),-    advance,-    advance2,-    bufLength,     findNewline,     null,-    peekByte,-    peekByte2,     skipNewline,-    skipToInteresting,-    sliceText,+    sliceBytes,   ) import Aihc.Cpp.Evaluator (expandMacros, expandMacrosMultiline) import Aihc.Cpp.Types (EngineState)-import Data.Text (Text)-import qualified Data.Text as T+import Data.Bits (bit, testBit, (.|.))+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as C+import qualified Data.ByteString.Unsafe as BSU+import Data.Word (Word64, Word8) import Prelude hiding (null)  data LineSpan = LineSpan   { lineSpanInBlockComment :: !Bool,-    lineSpanText :: !Text+    lineSpanText :: !ByteString   }  data LineScan = LineScan@@ -41,9 +39,9 @@   }  -- | Expand macros in a list of line spans (single-line, no lookahead).-expandLineBySpan :: EngineState -> [LineSpan] -> Text+expandLineBySpan :: EngineState -> [LineSpan] -> ByteString expandLineBySpan st =-  T.concat . map expandSpan+  C.concat . map expandSpan   where     expandSpan lineChunk       | lineSpanInBlockComment lineChunk = lineSpanText lineChunk@@ -57,35 +55,42 @@ -- Multi-line expansion is only attempted for lines that consist entirely -- of code spans (no inline comments). Mixed code/comment lines use -- single-line expansion to preserve comment span positions.-expandLineBySpanMultiline :: EngineState -> [LineSpan] -> Cursor -> (Text, Int)+expandLineBySpanMultiline :: EngineState -> [LineSpan] -> Cursor -> (ByteString, Int) expandLineBySpanMultiline st spans futureCursor =   let commentSpans = filter lineSpanInBlockComment spans-      hasLineComment = any (\s -> "--" `T.isPrefixOf` lineSpanText s) commentSpans-      hasCBlockComment = any (T.all (== ' ') . lineSpanText) commentSpans+      hasLineComment = any (\s -> "--" `C.isPrefixOf` lineSpanText s) commentSpans+      hasCBlockComment = any (C.all (== ' ') . lineSpanText) commentSpans       hasHsComment = case commentSpans of         [] -> False         _ -> not hasCBlockComment    in if hasLineComment || hasHsComment         then -- Haskell comments stay in the token stream, so expand the full line.-          let fullText = T.concat [lineSpanText s | s <- spans]+          let fullText = concatSpans spans            in (expandMacros st fullText, 0)         else           if hasCBlockComment             then -- C comments are stripped to spaces, so preserve per-span handling.               (expandLineBySpan st spans, 0)             else -- Pure code line: try multi-line expansion-              let codeText = T.concat [lineSpanText s | s <- spans]+              let codeText = concatSpans spans                   futureCodeLines = cursorToLines futureCursor                in expandMacrosMultiline st codeText futureCodeLines --- | Extract lines from a cursor as a lazy list of Text values.--- Each line is the text up to the next newline (or EOF).-cursorToLines :: Cursor -> [Text]+-- | Join the text of a line's spans. A line with no comment on it is a+-- single span, and returning that slice unchanged keeps the common case+-- zero-copy; 'C.concat' would copy it.+concatSpans :: [LineSpan] -> ByteString+concatSpans [one] = lineSpanText one+concatSpans spans = C.concat (map lineSpanText spans)++-- | Extract lines from a cursor as a lazy list of byte slices.+-- Each line is the content up to the next newline (or EOF).+cursorToLines :: Cursor -> [ByteString] cursorToLines !cur   | null cur = []   | otherwise =       let eol = findNewline cur-          lineText = sliceText (curPos cur) (curPos eol) cur+          lineText = sliceBytes (curPos cur) (curPos eol) cur        in lineText : maybe [] cursorToLines (skipNewline eol)  -- | Lightweight scan that only tracks block comment depth changes.@@ -93,76 +98,75 @@ -- Used for inactive conditional branches where only comment depth -- tracking is needed (no macro expansion or span splitting). ----- Accepts a 'Cursor' positioned at the start of the line content.--- The cursor should be bounded to the line (e.g., via 'lineSlice').-scanLineDepthOnly :: Int -> Int -> Cursor -> (Int, Int)-scanLineDepthOnly = goDepth+-- Takes the text of one logical line.+scanLineDepthOnly :: Int -> Int -> ByteString -> (Int, Int)+scanLineDepthOnly hsDepth0 cDepth0 line = goDepth hsDepth0 cDepth0 0   where-    goDepth :: Int -> Int -> Cursor -> (Int, Int)-    goDepth !hsDepth !cDepth !cur-      | null cur = (hsDepth, cDepth)-      | otherwise =-          case peekByte2 cur of-            Nothing ->-              -- One byte left, no two-char sequence possible-              (hsDepth, cDepth)-            Just (b1, b2)-              | cDepth > 0 ->-                  if b1 == 0x2A && b2 == 0x2F -- '*/'-                    then goDepth hsDepth 0 (advance2 cur)-                    else goDepth hsDepth cDepth (advance cur)-              | hsDepth > 0 && b1 == 0x2D && b2 == 0x7D -> -- '-}'-                  goDepth (hsDepth - 1) cDepth (advance2 cur)-              | b1 == 0x7B && b2 == 0x2D -> -- '{-'-                  let cur' = advance2 cur-                   in case peekByte cur' of-                        Just 0x23 ->-                          -- {-# is a pragma, not a comment-                          goDepth hsDepth cDepth (advance cur)-                        _ ->-                          goDepth (hsDepth + 1) cDepth cur'-              | hsDepth == 0 && b1 == 0x2F && b2 == 0x2A -> -- '/*'-                  goDepth hsDepth 1 (advance2 cur)-              | hsDepth == 0 && b1 == 0x2D && b2 == 0x2D -> -- '--' line comment-                  (hsDepth, cDepth)-              | otherwise ->-                  goDepth hsDepth cDepth (advance cur)+    len = BS.length line +    goDepth :: Int -> Int -> Int -> (Int, Int)+    goDepth !hsDepth !cDepth !i+      -- Fewer than two bytes left: no two-character sequence can start here.+      | i + 1 >= len = (hsDepth, cDepth)+      | cDepth > 0 =+          if b1 == 0x2A && b2 == 0x2F -- '*/'+            then goDepth hsDepth 0 (i + 2)+            else goDepth hsDepth cDepth (i + 1)+      | hsDepth > 0 && b1 == 0x2D && b2 == 0x7D -- '-}'+        =+          goDepth (hsDepth - 1) cDepth (i + 2)+      | b1 == 0x7B && b2 == 0x2D -- '{-'+        =+          if hsDepth == 0 && i + 2 < len && BS.index line (i + 2) == 0x23 -- '#'+            then -- {-# is a pragma, not a comment (only at depth 0; inside a+            -- comment it is an ordinary nested opener, balancing the -} of+            -- its closing #-})+              goDepth hsDepth cDepth (i + 1)+            else goDepth (hsDepth + 1) cDepth (i + 2)+      | hsDepth == 0 && b1 == 0x2F && b2 == 0x2A -- '/*'+        =+          goDepth hsDepth 1 (i + 2)+      | hsDepth == 0 && b1 == 0x2D && b2 == 0x2D -- '--' line comment+        =+          (hsDepth, cDepth)+      | otherwise = goDepth hsDepth cDepth (i + 1)+      where+        b1 = BS.index line i+        b2 = BS.index line (i + 1)+ -- | Scan a line, tracking comment depths and splitting into spans that are--- either inside or outside block comments. Uses a byte-level cursor for--- efficient scanning instead of character-by-character T.uncons/T.cons.+-- either inside or outside block comments. ----- Accepts a 'Cursor' positioned at the start of the line content.--- The cursor should be bounded to the line (e.g., via 'lineSlice').+-- Takes the text of one logical line, and walks it by byte offset: a+-- cursor-per-byte walk allocated a 'Cursor' for every byte of the input. -- -- The scanner splits the line into 'LineSpan' segments. Each segment is -- tagged with whether it is inside a block comment. Code spans (outside--- comments) are zero-copy slices of the UTF-8 encoded input. C89 comment+-- comments) are zero-copy slices of the raw input. C89 comment -- content is replaced with spaces to preserve column alignment.-scanLine :: Int -> Int -> Cursor -> LineScan-scanLine hsDepth0 cDepth0 cursor0 =+scanLine :: Int -> Int -> ByteString -> LineScan+scanLine 0 0 line+  -- Overwhelmingly the common case: a line outside any block comment that+  -- contains no comment at all is one code span, and 'isPlainCodeLine'+  -- settles that with a loop over unboxed arguments. The general scanner+  -- below threads a span accumulator, which costs an allocation per byte.+  | not (BS.null line) && isPlainCodeLine line = LineScan [LineSpan False line] 0 0+scanLine hsDepth0 cDepth0 line =   let (spans, finalHsDepth, finalCDepth) =-        go-          hsDepth0-          cDepth0-          False-          False-          False-          []-          (curPos cursor0)-          (hsDepth0 > 0 || cDepth0 > 0)-          cursor0+        go hsDepth0 cDepth0 False False False [] 0 (hsDepth0 > 0 || cDepth0 > 0) 0    in LineScan         { lineScanSpans = reverse spans,           lineScanFinalHsDepth = finalHsDepth,           lineScanFinalCDepth = finalCDepth         }   where+    len = BS.length line+     -- \| Emit a span from @start@ to @end@ if non-empty, prepending to @acc@.-    emit :: [LineSpan] -> Int -> Int -> Cursor -> Bool -> [LineSpan]-    emit acc start end cur inComment+    emit :: [LineSpan] -> Int -> Int -> Bool -> [LineSpan]+    emit acc start end inComment       | start >= end = acc-      | otherwise = LineSpan inComment (sliceText start end cur) : acc+      | otherwise = LineSpan inComment (BS.take (end - start) (BS.drop start line)) : acc     {-# INLINE emit #-}      go ::@@ -174,215 +178,144 @@       [LineSpan] ->       Int ->       Bool ->-      Cursor ->+      Int ->       ([LineSpan], Int, Int)-    go-      !hsDepth-      !cDepth-      !inString-      !inChar-      !escaped-      !acc-      !spanStart-      !spanInComment-      !cur-        -- End of input: flush the accumulated span-        | null cur =-            (emit acc spanStart (curPos cur) cur spanInComment, hsDepth, cDepth)-        | otherwise =-            case peekByte2 cur of-              Nothing ->-                -- === Only one byte left ===-                if cDepth > 0-                  then-                    -- In C comment: flush accumulated, emit space-                    let acc' = emit acc spanStart (curPos cur) cur spanInComment-                     in (LineSpan True " " : acc', hsDepth, cDepth)-                  else-                    -- Include this last byte in the accumulated span-                    let inCommentNow = hsDepth > 0-                        cur' = advance cur-                     in (emit acc spanStart (curPos cur') cur inCommentNow, hsDepth, cDepth)-              Just (b1, b2) ->-                -- === C block comment mode ===-                if cDepth > 0-                  then-                    if b1 == 0x2A && b2 == 0x2F -- '*/'-                      then-                        let acc' = emit acc spanStart (curPos cur) cur spanInComment-                            cur' = advance2 cur-                         in go-                              hsDepth-                              0-                              False-                              False-                              False-                              (LineSpan True "  " : acc')-                              (curPos cur')-                              False-                              cur'-                      else-                        let acc' = emit acc spanStart (curPos cur) cur spanInComment-                            cur' = advance cur-                         in go-                              hsDepth-                              cDepth-                              False-                              False-                              False-                              (LineSpan True " " : acc')-                              (curPos cur')-                              True-                              cur'-                  -- === Line comment: -- (outside strings and hs comments) ===-                  else-                    if not inString-                      && not inChar-                      && hsDepth == 0-                      && b1 == 0x2D-                      && b2 == 0x2D -- '--'-                      then-                        let acc' = emit acc spanStart (curPos cur) cur spanInComment-                            restText = sliceText (curPos cur) (bufLength cur) cur-                         in (LineSpan True restText : acc', hsDepth, cDepth)-                      -- === Inside string literal ===-                      else-                        if inString-                          then-                            let escaped' = not escaped && b1 == 0x5C -- '\\'-                                inString' = escaped || b1 /= 0x22 -- '"'-                             in go-                                  hsDepth-                                  cDepth-                                  inString'-                                  False-                                  escaped'-                                  acc-                                  spanStart-                                  spanInComment-                                  (advance cur)-                          -- === Inside char literal ===-                          else-                            if inChar-                              then-                                let escaped' = not escaped && b1 == 0x5C -- '\\'-                                    inChar' = escaped || b1 /= 0x27 -- '\''-                                 in go-                                      hsDepth-                                      cDepth-                                      False-                                      inChar'-                                      escaped'-                                      acc-                                      spanStart-                                      spanInComment-                                      (advance cur)-                              -- === Start of string literal ===-                              else-                                if hsDepth == 0 && b1 == 0x22 -- '"'-                                  then-                                    go-                                      hsDepth-                                      cDepth-                                      True-                                      False-                                      False-                                      acc-                                      spanStart-                                      spanInComment-                                      (advance cur)-                                  -- === Start of char literal ===-                                  else-                                    if hsDepth == 0 && b1 == 0x27 -- '\''-                                      then-                                        go-                                          hsDepth-                                          cDepth-                                          False-                                          True-                                          False-                                          acc-                                          spanStart-                                          spanInComment-                                          (advance cur)-                                      -- === End of Haskell block comment: -} ===-                                      else-                                        if hsDepth > 0 && b1 == 0x2D && b2 == 0x7D -- '-}'-                                          then-                                            let cur' = advance2 cur-                                                hsDepth' = hsDepth - 1-                                                -- Flush everything up to and including -} as a comment span-                                                acc' = emit acc spanStart (curPos cur') cur True-                                                inCommentAfter = hsDepth' > 0-                                             in go-                                                  hsDepth'-                                                  cDepth-                                                  False-                                                  False-                                                  False-                                                  acc'-                                                  (curPos cur')-                                                  inCommentAfter-                                                  cur'-                                          -- === Start of Haskell block comment: {- (but not {-#) ===-                                          else-                                            if b1 == 0x7B && b2 == 0x2D -- '{-'-                                              then-                                                let cur' = advance2 cur-                                                 in case peekByte cur' of-                                                      Just 0x23 ->-                                                        -- '#' => pragma {-#, not a block comment-                                                        -- Advance past '{' only, continue in same mode-                                                        go-                                                          hsDepth-                                                          cDepth-                                                          False-                                                          False-                                                          False-                                                          acc-                                                          spanStart-                                                          spanInComment-                                                          (advance cur)-                                                      _ ->-                                                        -- Flush any text before {-, emit {- as comment-                                                        let acc' = emit acc spanStart (curPos cur) cur spanInComment-                                                            acc'' = LineSpan True "{-" : acc'-                                                         in go-                                                              (hsDepth + 1)-                                                              cDepth-                                                              False-                                                              False-                                                              False-                                                              acc''-                                                              (curPos cur')-                                                              True-                                                              cur'-                                              -- === Start of C block comment: /* ===-                                              else-                                                if hsDepth == 0 && b1 == 0x2F && b2 == 0x2A -- '/*'-                                                  then-                                                    let acc' = emit acc spanStart (curPos cur) cur spanInComment-                                                        cur' = advance2 cur-                                                     in go-                                                          hsDepth-                                                          1-                                                          False-                                                          False-                                                          False-                                                          (LineSpan True "  " : acc')-                                                          (curPos cur')-                                                          True-                                                          cur'-                                                  -- === Normal byte: bulk-skip non-interesting bytes ===-                                                  else-                                                    let cur' = skipToInteresting (advance cur)-                                                     in go-                                                          hsDepth-                                                          cDepth-                                                          False-                                                          False-                                                          False-                                                          acc-                                                          spanStart-                                                          spanInComment-                                                          cur'+    go !hsDepth !cDepth !inString !inChar !escaped !acc !spanStart !spanInComment !i+      -- End of input: flush the accumulated span.+      | i >= len =+          (emit acc spanStart i spanInComment, hsDepth, cDepth)+      -- Only one byte left: no two-character sequence is possible.+      | i + 1 >= len =+          if cDepth > 0+            then -- In a C comment: flush what came before, emit a space.+              (LineSpan True " " : emit acc spanStart i spanInComment, hsDepth, cDepth)+            else -- Include this last byte in the accumulated span.+              (emit acc spanStart (i + 1) (hsDepth > 0), hsDepth, cDepth)+      -- === C block comment mode ===+      | cDepth > 0 =+          if b1 == 0x2A && b2 == 0x2F -- '*/'+            then+              go hsDepth 0 False False False (LineSpan True "  " : emit acc spanStart i spanInComment) (i + 2) False (i + 2)+            else+              go hsDepth cDepth False False False (LineSpan True " " : emit acc spanStart i spanInComment) (i + 1) True (i + 1)+      -- === Line comment: -- (outside strings and hs comments) ===+      | not inString && not inChar && hsDepth == 0 && b1 == 0x2D && b2 == 0x2D -- '--'+        =+          (LineSpan True (BS.drop i line) : emit acc spanStart i spanInComment, hsDepth, cDepth)+      -- === Inside string literal ===+      | inString =+          let escaped' = not escaped && b1 == 0x5C -- '\\'+              inString' = escaped || b1 /= 0x22 -- '"'+           in go hsDepth cDepth inString' False escaped' acc spanStart spanInComment (i + 1)+      -- === Inside char literal ===+      | inChar =+          let escaped' = not escaped && b1 == 0x5C -- '\\'+              inChar' = escaped || b1 /= 0x27 -- '\''+           in go hsDepth cDepth False inChar' escaped' acc spanStart spanInComment (i + 1)+      -- === Start of string literal ===+      | hsDepth == 0 && b1 == 0x22 -- '"'+        =+          go hsDepth cDepth True False False acc spanStart spanInComment (i + 1)+      -- === Start of char literal ===+      | hsDepth == 0 && b1 == 0x27 -- '\''+        =+          go hsDepth cDepth False True False acc spanStart spanInComment (i + 1)+      -- === End of Haskell block comment: -} ===+      | hsDepth > 0 && b1 == 0x2D && b2 == 0x7D -- '-}'+        =+          let hsDepth' = hsDepth - 1+              -- Flush everything up to and including -} as a comment span.+              acc' = emit acc spanStart (i + 2) True+           in go hsDepth' cDepth False False False acc' (i + 2) (hsDepth' > 0) (i + 2)+      -- === Start of Haskell block comment: {- (but not a top-level {-# pragma) ===+      | b1 == 0x7B && b2 == 0x2D -- '{-'+        =+          if hsDepth == 0 && i + 2 < len && BS.index line (i + 2) == 0x23 -- '#'+            then -- A pragma, not a block comment (only outside comments;+            -- nested, {-# opens one). Advance past '{' only.+              go hsDepth cDepth False False False acc spanStart spanInComment (i + 1)+            else -- Flush any text before {-, emit {- as a comment.+              go (hsDepth + 1) cDepth False False False (LineSpan True "{-" : emit acc spanStart i spanInComment) (i + 2) True (i + 2)+      -- === Start of C block comment: /* ===+      | hsDepth == 0 && b1 == 0x2F && b2 == 0x2A -- '/*'+        =+          go hsDepth 1 False False False (LineSpan True "  " : emit acc spanStart i spanInComment) (i + 2) True (i + 2)+      -- === Normal byte: bulk-skip bytes that can start nothing ===+      | otherwise =+          go hsDepth cDepth False False False acc spanStart spanInComment (skipDull (i + 1))+      where+        b1 = BS.index line i+        b2 = BS.index line (i + 1)++    -- \| Advance past bytes that cannot start any CPP-significant+    -- two-character sequence, so runs of plain text (identifiers,+    -- whitespace, operators, non-ASCII) are stepped over without+    -- per-byte dispatch.+    skipDull :: Int -> Int+    -- The @i < len@ test guards the read on the same line: this is the+    -- innermost loop of the scan and the bounds check doubled its cost.+    skipDull !i+      | i < len && not (isInteresting (BSU.unsafeIndex line i)) = skipDull (i + 1)+      | otherwise = i++-- | Would the full scan of this line produce exactly one code span and+-- leave both comment depths at zero? That is, does the line open no+-- comment of either kind and contain no @--@ outside a literal?+--+-- This runs the same string- and char-literal state machine as 'scanLine',+-- so the two always agree about whether a @--@ or a @{-@ is a comment. It+-- carries no accumulator, so it compiles to a loop over unboxed arguments+-- that allocates nothing.+isPlainCodeLine :: ByteString -> Bool+isPlainCodeLine line = go 0 False False False+  where+    len = BS.length line++    go :: Int -> Bool -> Bool -> Bool -> Bool+    go !i !inString !inChar !escaped+      -- Fewer than two bytes left: no two-character sequence can start.+      | i + 1 >= len = True+      | inString = go (i + 1) (escaped || b1 /= 0x22) False (not escaped && b1 == 0x5C)+      | inChar = go (i + 1) False (escaped || b1 /= 0x27) (not escaped && b1 == 0x5C)+      | b1 == 0x2D && b2 == 0x2D = False -- '--'+      | b1 == 0x22 = go (i + 1) True False False -- '"'+      | b1 == 0x27 = go (i + 1) False True False -- '\''+      | b1 == 0x7B && b2 == 0x2D -- '{-'+      -- A {-# pragma is not a comment; the scan resumes after the '{'.+        =+          i + 2 < len && BS.index line (i + 2) == 0x23 && go (i + 1) False False False+      | b1 == 0x2F && b2 == 0x2A = False -- '/*'+      | otherwise = go (skipPlainDull (i + 1)) False False False+      where+        b1 = BS.index line i+        b2 = BS.index line (i + 1)++    skipPlainDull :: Int -> Int+    -- The @i < len@ test guards the read on the same line: this is the+    -- innermost loop of the scan and the bounds check doubled its cost.+    skipPlainDull !i+      | i < len && not (isInteresting (BSU.unsafeIndex line i)) = skipPlainDull (i + 1)+      | otherwise = i++-- | Can this byte start a CPP-significant two-character sequence?+--+-- A bit test against a pair of masks rather than a chain of comparisons:+-- this runs on every byte of the input, and the eight-way chain it+-- replaces cost more than the rest of the scan.+--+-- The bytes are @"@ (0x22), @\'@ (0x27), @*@ (0x2A), @-@ (0x2D), @/@+-- (0x2F), @\\@ (0x5C), @{@ (0x7B) and @}@ (0x7D). All are ASCII, so any+-- byte >= 0x80 — a continuation byte of whatever the source encoding is —+-- is uninteresting by construction.+isInteresting :: Word8 -> Bool+isInteresting b+  | b < 64 = testBit interestingLow (fromIntegral b)+  | b < 128 = testBit interestingHigh (fromIntegral b - 64)+  | otherwise = False+{-# INLINE isInteresting #-}++interestingLow :: Word64+interestingLow = bit 0x22 .|. bit 0x27 .|. bit 0x2A .|. bit 0x2D .|. bit 0x2F++interestingHigh :: Word64+interestingHigh = bit (0x5C - 64) .|. bit (0x7B - 64) .|. bit (0x7D - 64)

@@ -14,6 +14,11 @@     Step (..),     EngineState (..),     emptyState,+    defineMacro,+    undefMacro,+    setMacroTable,+    macroFirstByte,+    bloomMember,     CondFrame (..),     currentActive,     mkFrame,@@ -24,13 +29,16 @@  import Aihc.Cpp.Cursor (Cursor) import Control.DeepSeq (NFData)+import Data.Bits (setBit, testBit, (.&.)) import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Builder as BSB import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import Data.Set (Set) import qualified Data.Set as S import Data.Text (Text)-import qualified Data.Text.Lazy.Builder as TB+import Data.Word (Word64, Word8) import GHC.Generics (Generic)  -- $setup@@ -45,12 +53,16 @@     -- | User-defined macros. These are expanded as object-like macros.     -- Note that the values should include any necessary quoting. For     -- example, to define a string macro, use @"\"value\""@.-    configMacros :: !(Map Text Text)+    --+    -- Names and bodies are raw bytes: the preprocessor never decodes+    -- them, so a @-D@ flag taken straight from @argv@ can be passed+    -- through unchanged whatever its encoding.+    configMacros :: !(Map ByteString ByteString)   }  data MacroDef-  = ObjectMacro !Text-  | FunctionMacro ![Text] !Text+  = ObjectMacro !ByteString+  | FunctionMacro ![ByteString] !ByteString   deriving (Eq, Show)  -- | Default configuration with sensible defaults.@@ -106,6 +118,12 @@   { -- | The severity of the diagnostic.     diagSeverity :: !Severity,     -- | The diagnostic message text.+    --+    -- Unlike 'Result', a diagnostic is meant to be shown to a human, so+    -- this is 'Text'. Message fragments taken from the source (an+    -- @#error@ message, an include path) are decoded as UTF-8 with+    -- invalid bytes replaced by U+FFFD; that substitution affects the+    -- message only, never 'resultOutput'.     diagMessage :: !Text,     -- | The file where the diagnostic occurred.     diagFile :: !FilePath,@@ -116,8 +134,12 @@  -- | The result of preprocessing. data Result = Result-  { -- | The preprocessed output text.-    resultOutput :: !Text,+  { -- | The preprocessed output.+    --+    -- Bytes the preprocessor did not itself generate are copied through+    -- verbatim, so the output carries the input's encoding, whatever it+    -- was. See 'Aihc.Cpp.preprocess' for the encoding contract.+    resultOutput :: !ByteString,     -- | Any diagnostics (warnings or errors) emitted during preprocessing.     resultDiagnostics :: ![Diagnostic]   }@@ -134,8 +156,19 @@     NeedInclude !IncludeRequest !(Maybe ByteString -> Step)  data EngineState = EngineState-  { stMacros :: !(Map Text MacroDef),-    stOutput :: !TB.Builder,+  { stMacros :: !(Map ByteString MacroDef),+    -- | Which bytes any macro name can start with, as a 64-bit set (see+    -- 'macroFirstByte'). Nearly every identifier in a Haskell module names+    -- no macro, and testing one bit rejects it without the string+    -- comparisons a 'Map' lookup would run. Kept in step with 'stMacros'+    -- by 'setMacros'; @_@ is always a member, because @__LINE__@ and+    -- @__FILE__@ are recognised without being in the map.+    stMacroBloom :: {-# UNPACK #-} !Word64,+    -- | The same, restricted to function-like macros, and 0 when a module+    -- defines none — which is the common case, and lets the multi-line+    -- call lookahead skip the line entirely.+    stFunMacroBloom :: {-# UNPACK #-} !Word64,+    stOutput :: !BSB.Builder,     stOutputLineCount :: {-# UNPACK #-} !Int,     stDiagnosticsRev :: ![Diagnostic],     stPragmaOnceFiles :: !(Set FilePath),@@ -150,6 +183,8 @@ emptyState filePath =   EngineState     { stMacros = M.empty,+      stMacroBloom = underscoreBloom,+      stFunMacroBloom = 0,       stOutput = mempty,       stOutputLineCount = 0,       stDiagnosticsRev = [],@@ -160,6 +195,63 @@       stCurrentFile = filePath,       stCurrentLine = 1     }++-- | Define a macro, keeping the first-byte blooms in step. Adding a name+-- only ever sets bits, so this costs one @Map@ insert rather than a walk+-- of the whole table.+defineMacro :: ByteString -> MacroDef -> EngineState -> EngineState+defineMacro name def st =+  st+    { stMacros = M.insert name def (stMacros st),+      stMacroBloom = setBit (stMacroBloom st) bit',+      stFunMacroBloom = case def of+        FunctionMacro _ _ -> setBit (stFunMacroBloom st) bit'+        ObjectMacro _ -> stFunMacroBloom st+    }+  where+    bit' = macroFirstByte name++-- | Undefine a macro. Removing a name can clear a bit, which only a full+-- pass can tell, so the blooms are rebuilt; @#undef@ is rare enough for+-- that not to matter.+undefMacro :: ByteString -> EngineState -> EngineState+undefMacro name st = setMacroTable (M.delete name (stMacros st)) st++-- | Replace the macro table wholesale and rebuild the blooms from it.+setMacroTable :: Map ByteString MacroDef -> EngineState -> EngineState+setMacroTable macros st =+  let (allBloom, funBloom) = M.foldrWithKey step (underscoreBloom, 0) macros+   in st+        { stMacros = macros,+          stMacroBloom = allBloom,+          stFunMacroBloom = funBloom+        }+  where+    step name def (allBloom, funBloom) =+      let bit' = macroFirstByte name+          allBloom' = setBit allBloom bit'+       in case def of+            FunctionMacro _ _ -> (allBloom', setBit funBloom bit')+            ObjectMacro _ -> (allBloom', funBloom)++-- | Bloom containing only @_@, the first byte of @__LINE__@ and @__FILE__@.+underscoreBloom :: Word64+underscoreBloom = setBit 0 (macroFirstByte "_")++-- | Which bit of a bloom a name's first byte occupies: the low six bits of+-- that byte. Identifiers start with a letter, @_@, or a byte >= 0x80, and+-- those map to distinct bits across @A-Z@, @a-z@ and @_@, so the filter is+-- exact for ASCII names and merely approximate for the rest.+macroFirstByte :: ByteString -> Int+macroFirstByte name+  | BS.null name = 0+  | otherwise = fromIntegral (BS.head name .&. 0x3F)+{-# INLINE macroFirstByte #-}++-- | Could a name starting with this byte be in the bloom?+bloomMember :: Word64 -> Word8 -> Bool+bloomMember bloom b = testBit bloom (fromIntegral (b .&. 0x3F))+{-# INLINE bloomMember #-}  data CondFrame = CondFrame   { frameOuterActive :: !Bool,

@@ -2,10 +2,12 @@  module Main (main) where -import Aihc.Cpp (Config (..), Result (..), Step (..), defaultConfig, preprocess)+import Aihc.Cpp (Config (..), Diagnostic (..), Result (..), Severity (..), Step (..), defaultConfig, preprocess)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as C import qualified Data.Map.Strict as M-import qualified Data.Text as T import qualified Data.Text.Encoding as TE+import Data.Word (Word8) import Test.Progress (CaseMeta (..), Outcome (..), evaluateCase, loadManifest) import Test.Tasty (TestTree, defaultMain, testGroup) import Test.Tasty.HUnit (Assertion, assertFailure, testCase)@@ -20,11 +22,159 @@         "cpp-oracle"         ( checks             <> [linePragmaTest, dateTimeTest, functionMacroArgumentTest, functionMacroUnclosedCallTest, definedConditionSpacingTest, stringContinuationTests, tokenPastingTests, ccallLineCommentTest]-            <> [pragmaOnceTest]+            <> [pragmaOnceTest, macroRescanTests, pragmaInsideBlockCommentTests, encodingTests]+            <> [lineSpanTests]             <> [QC.testProperty "dummy quickcheck property" prop_dummy]         )     ) +-- | The preprocessor must be agnostic to the source encoding: bytes it+-- did not generate itself are copied through verbatim, whatever they+-- encode. GHC itself accepts an undecodable byte inside a comment (it+-- only rejects one where a token must be lexed), so rejecting such a+-- file outright would fail modules that really do compile.+encodingTests :: TestTree+encodingTests =+  testGroup+    "source encoding"+    [ testCase "latin-1 byte in a comment survives byte-for-byte" $ do+        -- The Stackage module that first exposed this: Ebnf2ps's+        -- Defaults.hs is ISO-8859-1 and has 0xA9 ((c)) in a comment.+        let input = "{-# LANGUAGE CPP #-}\n-- " <> byte 0xA9 <> " 2026\n#define X 1\nx = X\n"+            cfg = defaultConfig {configInputFile = "Defaults.hs"}+        preprocessTo cfg input+          @?= ("#line 1 \"Defaults.hs\"\n{-# LANGUAGE CPP #-}\n-- " <> byte 0xA9 <> " 2026\n\nx = 1\n"),+      testCase "no diagnostics for undecodable bytes" $ do+        let input = "-- " <> byte 0xA9 <> "\nx = 1\n"+        diagnosticsOf defaultConfig input @?= [],+      testCase "latin-1 bytes survive in a string literal and in code" $ do+        let input = "#define X 1\ns = \"" <> byte 0xE9 <> "\"\nc = X -- " <> byte 0xFF <> "\n"+        preprocessTo defaultConfig input+          @?= ("#line 1 \"<input>\"\n\ns = \"" <> byte 0xE9 <> "\"\nc = 1 -- " <> byte 0xFF <> "\n"),+      testCase "a lone continuation byte is not treated as whitespace" $ do+        -- 0xA0 is Latin-1 NBSP and 'Data.Char.isSpace'; treating it as+        -- whitespace would split a UTF-8 character in half.+        let input = "#define A" <> byte 0xA0 <> "B 1\nA" <> byte 0xA0 <> "B\n"+        preprocessTo defaultConfig input+          @?= "#line 1 \"<input>\"\n\n1\n",+      testCase "utf-8 identifiers still expand" $ do+        let input = TE.encodeUtf8 "#define caf\xe9 42\ncaf\xe9\n"+        preprocessTo defaultConfig input+          @?= TE.encodeUtf8 "#line 1 \"<input>\"\n\n42\n",+      testCase "arbitrary non-text bytes round-trip unchanged" $ do+        let payload = BS.pack [0x00, 0x80, 0xFE, 0xFF, 0xC0, 0x80, 0xED, 0xA0, 0x80]+            input = "-- " <> payload <> "\nx = 1\n"+        preprocessTo defaultConfig input+          @?= ("#line 1 \"<input>\"\n-- " <> payload <> "\nx = 1\n"),+      testCase "an undecodable include is preprocessed like any other" $ do+        let includeBytes = "-- " <> byte 0xA9 <> "\n"+        case preprocess defaultConfig {configInputFile = "root.hs"} "#include \"bad.h\"\nx = 1\n" of+          NeedInclude _ k ->+            case k (Just includeBytes) of+              Done result -> do+                [d | d <- resultDiagnostics result, diagSeverity d == Error] @?= []+                (byte 0xA9 `BS.isInfixOf` resultOutput result) @?= True+              _ -> assertFailure "expected Done"+          _ -> assertFailure "expected NeedInclude"+    ]++-- | Number of non-overlapping occurrences of a substring.+countSubstring :: BS.ByteString -> BS.ByteString -> Int+countSubstring needle = go 0+  where+    go n hay =+      case BS.breakSubstring needle hay of+        (_, rest)+          | BS.null rest -> n+          | otherwise -> go (n + 1) (BS.drop (BS.length needle) rest)++-- | A single raw byte, with no encoding applied.+byte :: Word8 -> BS.ByteString+byte b = BS.pack [b]++-- | Run 'preprocess' to completion and return the raw output bytes.+preprocessTo :: Config -> BS.ByteString -> BS.ByteString+preprocessTo cfg input =+  case preprocess cfg input of+    Done result -> resultOutput result+    _ -> error "expected Done"++diagnosticsOf :: Config -> BS.ByteString -> [Diagnostic]+diagnosticsOf cfg input =+  case preprocess cfg input of+    Done result -> resultDiagnostics result+    _ -> error "expected Done"++-- | Where a line splits into code and comment spans.+--+-- The line scanner has a fast path for a line that is one code span, and+-- it decides that with the same string- and char-literal state machine+-- the general scanner uses. A line that only looks like it opens a+-- comment must not take the fast path, and one that only looks like it+-- does not must not miss it: whether a span is code or comment decides+-- whether macros in it expand, so a disagreement is silent.+lineSpanTests :: TestTree+lineSpanTests =+  testGroup+    "line spans"+    [ expands "{- inside a string opens no comment" "x = \"a {- b\" ++ FOO\n" "x = \"a {- b\" ++ 1\n",+      expands "a brace in a char literal opens no comment" "c = '{'\n" "c = '{'\n",+      expands "-- inside a string starts no line comment" "x = \"a -- b\" ++ FOO\n" "x = \"a -- b\" ++ 1\n",+      expands "/* inside a string starts no C comment" "x = \"/*\" ++ FOO\n" "x = \"/*\" ++ 1\n",+      expands "a {-# pragma is not a comment" "{-# LANGUAGE CPP #-}\n" "{-# LANGUAGE CPP #-}\n",+      expands "a closed string leaves literal state" "x = \"a\\\\\\\\\" ++ FOO\n" "x = \"a\\\\\\\\\" ++ 1\n",+      -- The remaining three are the cases the fast path must decline.+      expands+        "a macro inside an inline block comment does not expand"+        "x = 1 {- FOO -} + FOO\n"+        "x = 1 {- FOO -} + 1\n",+      expands+        "a macro after a line comment marker does not expand"+        "x = 1 -- FOO\n"+        "x = 1 -- FOO\n",+      expands+        "a C block comment becomes spaces of the same width"+        "x = 1 /* FOO */ + FOO\n"+        "x = 1           + 1\n",+      -- A prime is lexed as an unterminated char literal, so the rest of+      -- the line is inside a literal and nothing in it expands. That is+      -- long-standing behaviour, pinned here because the fast path has to+      -- reproduce it to agree with the general scanner.+      expands "an unterminated char literal suppresses expansion" "x' = FOO\n" "x' = FOO\n",+      -- The three below are the cases where getting the literal state+      -- wrong changes the output rather than merely costing a fast path.+      -- A C comment is replaced by spaces, so which lines are inside one+      -- is visible; a Haskell comment is not, which is why these use /*.+      expands+        "a string closes before a C comment opens"+        "x = \"a\" /* FOO\nFOO\n*/\ny = FOO\n"+        "x = \"a\"       \n   \n  \ny = 1\n",+      expands+        "a char literal closes before a C comment opens"+        "c = 'x' /* FOO\nFOO\n*/\ny = FOO\n"+        "c = 'x'       \n   \n  \ny = 1\n",+      -- A line whose last byte is the first half of a two-byte sequence+      -- must not make the scanner look past the end of it. 'preprocess'+      -- promises never to raise, so an out-of-range read here would be a+      -- broken contract rather than a wrong answer.+      expands "a line ending in a lone -" "x = 1 -\nFOO\n" "x = 1 -\n1\n",+      expands "a line ending in a lone {" "x = {\nFOO\n" "x = {\n1\n",+      expands "a line ending in a lone /" "x = /\nFOO\n" "x = /\n1\n",+      expands "a line ending in a lone *" "x = 1 *\nFOO\n" "x = 1 *\n1\n",+      expands "a line that is a lone -" "-\n" "-\n",+      expands "a line that is a lone {" "{\n" "{\n",+      -- A function-like call opened inside a line comment is not a call,+      -- so the following line must not be swallowed as its continuation.+      testCase "a line comment ends the multi-line call lookahead" $+        preprocessTo defaultConfig "#define F(a) a\nx = 1 -- F(\n  2)\ny = F(3)\n"+          @?= "#line 1 \"<input>\"\n\nx = 1 -- F(\n  2)\ny = 3\n"+    ]+  where+    expands name body expected =+      testCase name $+        preprocessTo defaultConfig ("#define FOO 1\n" <> body)+          @?= ("#line 1 \"<input>\"\n\n" <> expected)+ -- | Dummy QuickCheck property that always passes. -- Added so that --quickcheck-tests flag is accepted by the test suite. prop_dummy :: Bool@@ -85,12 +235,12 @@ linePragmaTest :: TestTree linePragmaTest =   testCase "include emits line pragmas" $-    case preprocess defaultConfig {configInputFile = "root.hs"} (TE.encodeUtf8 "before\n#include \"nested.inc\"\nafter") of+    case preprocess defaultConfig {configInputFile = "root.hs"} "before\n#include \"nested.inc\"\nafter" of       NeedInclude _ k ->         case k (Just "inside") of           Done result -> do-            let out = T.lines (resultOutput result)-                hasIncludePragma = any (T.isSuffixOf "nested.inc\"") out+            let out = C.lines (resultOutput result)+                hasIncludePragma = any (C.isSuffixOf "nested.inc\"") out             if hasIncludePragma && "#line 3 \"root.hs\"" `elem` out               then pure ()               else assertFailure "expected include line pragmas in output"@@ -100,7 +250,7 @@ functionMacroArgumentTest :: TestTree functionMacroArgumentTest =   testCase "function-like macro keeps nested argument text" $-    case preprocess defaultConfig (TE.encodeUtf8 "#define PAIR(x,y) x + y\nPAIR((1 + 2), 3)") of+    case preprocess defaultConfig "#define PAIR(x,y) x + y\nPAIR((1 + 2), 3)" of       Done result ->         resultOutput result @?= "#line 1 \"<input>\"\n\n(1 + 2) + 3\n"       _ -> assertFailure "expected Done"@@ -108,7 +258,7 @@ functionMacroUnclosedCallTest :: TestTree functionMacroUnclosedCallTest =   testCase "unterminated function-like call does not expand macro" $-    case preprocess defaultConfig (TE.encodeUtf8 "#define ID() replaced\nID(") of+    case preprocess defaultConfig "#define ID() replaced\nID(" of       Done result ->         resultOutput result @?= "#line 1 \"<input>\"\n\nID(\n"       _ -> assertFailure "expected Done"@@ -116,9 +266,9 @@ definedConditionSpacingTest :: TestTree definedConditionSpacingTest =   testCase "defined handles whitespace around parenthesized name" $-    case preprocess defaultConfig (TE.encodeUtf8 "#define FLAG 1\n#if defined   ( FLAG )\nok\n#else\nbad\n#endif") of+    case preprocess defaultConfig "#define FLAG 1\n#if defined   ( FLAG )\nok\n#else\nbad\n#endif" of       Done result ->-        if "ok\n" `T.isInfixOf` resultOutput result && not ("bad\n" `T.isInfixOf` resultOutput result)+        if "ok\n" `C.isInfixOf` resultOutput result && not ("bad\n" `C.isInfixOf` resultOutput result)           then pure ()           else assertFailure ("expected ok branch to be active, output was: " <> show (resultOutput result))       _ -> assertFailure "expected Done"@@ -130,32 +280,32 @@     [ testCase "ordinary string accepts GCC double-backslash continuation" $         assertPreprocessOutput           gccStringContinuationInput-          (T.unlines ["#line 1 \"<input>\"", "x = \"a\\       \\b\""]),+          (C.unlines ["#line 1 \"<input>\"", "x = \"a\\       \\b\""]),       testCase "ordinary string preserves GHC single-backslash gap" $         assertPreprocessOutput           ghcStringGapInput-          (T.unlines ["#line 1 \"<input>\"", "x = \"a\\", "       \\b\""]),+          (C.unlines ["#line 1 \"<input>\"", "x = \"a\\", "       \\b\""]),       testCase "function macro argument accepts GCC double-backslash continuation" $         assertPreprocessOutput           gccStringContinuationMacroInput-          (T.unlines ["#line 1 \"<input>\"", "", "x = \"a\\       \\b\""]),+          (C.unlines ["#line 1 \"<input>\"", "", "x = \"a\\       \\b\""]),       testCase "function macro argument preserves GHC single-backslash gap" $         assertPreprocessOutput           ghcStringGapMacroInput-          (T.unlines ["#line 1 \"<input>\"", "", "x = \"a\\", "       \\b\""]),+          (C.unlines ["#line 1 \"<input>\"", "", "x = \"a\\", "       \\b\""]),       testCase "GCC continuation tracks string gaps across concatenation" $         assertPreprocessOutput           gccStringContinuationConcatInput-          (T.unlines ["#line 1 \"<input>\"", "x = \"a\\       \\\" <> y <> \"\\n\\       \\b\""]),+          (C.unlines ["#line 1 \"<input>\"", "x = \"a\\       \\\" <> y <> \"\\n\\       \\b\""]),       testCase "double backslash outside strings is not line-spliced" $         assertPreprocessOutput           nonStringDoubleBackslashInput-          (T.unlines ["#line 1 \"<input>\"", "", "x = foo \\\\", "       bar"])+          (C.unlines ["#line 1 \"<input>\"", "", "x = foo \\\\", "       bar"])     ] -assertPreprocessOutput :: T.Text -> T.Text -> Assertion+assertPreprocessOutput :: BS.ByteString -> BS.ByteString -> Assertion assertPreprocessOutput input expected =-  case preprocess defaultConfig (TE.encodeUtf8 input) of+  case preprocess defaultConfig input of     Done result -> resultOutput result @?= expected     _ -> assertFailure "expected Done" @@ -164,35 +314,35 @@   testGroup     "token pasting"     [ testCase "CCALL macro expands stringizing and token pasting" $-        case preprocess defaultConfig (TE.encodeUtf8 ccallMacroInput) of+        case preprocess defaultConfig ccallMacroInput of           Done result ->-            if "foreign import ccall unsafe \"foo\"" `T.isInfixOf` resultOutput result-              && "c_foo :: Int -> IO Int" `T.isInfixOf` resultOutput result+            if "foreign import ccall unsafe \"foo\"" `C.isInfixOf` resultOutput result+              && "c_foo :: Int -> IO Int" `C.isInfixOf` resultOutput result               then pure ()               else assertFailure ("expected CCALL expansion in output, got: " <> show (resultOutput result))           _ -> assertFailure "expected Done",       testCase "token pasting joins both sides without expanding arguments first" $-        case preprocess defaultConfig (TE.encodeUtf8 tokenPasteRawArgInput) of+        case preprocess defaultConfig tokenPasteRawArgInput of           Done result ->             resultOutput result @?= "#line 1 \"<input>\"\n\n\nXY\n"           _ -> assertFailure "expected Done",       testCase "token pasting result is rescanned for further macro expansion" $-        case preprocess defaultConfig (TE.encodeUtf8 tokenPasteRescanInput) of+        case preprocess defaultConfig tokenPasteRescanInput of           Done result ->             resultOutput result @?= "#line 1 \"<input>\"\n\n\n42\n"           _ -> assertFailure "expected Done",       testCase "token pasting supports prefix and suffix forms" $-        case preprocess defaultConfig (TE.encodeUtf8 tokenPasteAffixInput) of+        case preprocess defaultConfig tokenPasteAffixInput of           Done result ->             resultOutput result @?= "#line 1 \"<input>\"\n\n\nleft right\n"           _ -> assertFailure "expected Done",       testCase "token pasting supports chained concatenation" $-        case preprocess defaultConfig (TE.encodeUtf8 tokenPasteChainedInput) of+        case preprocess defaultConfig tokenPasteChainedInput of           Done result ->             resultOutput result @?= "#line 1 \"<input>\"\n\nfoobar\n"           _ -> assertFailure "expected Done",       testCase "token pasting survives Haskell block comments in arguments" $-        case preprocess defaultConfig (TE.encodeUtf8 tokenPasteHsCommentInput) of+        case preprocess defaultConfig tokenPasteHsCommentInput of           Done result ->             resultOutput result               @?= "#line 1 \"<input>\"\n\n{-# INLINE _bar #-}; _bar :: LensP Foo Baz{-comment-}; _bar = lens bar $ \\ Foo {..} bar_ -> Foo {bar = bar_, ..}\n"@@ -202,11 +352,11 @@ ccallLineCommentTest :: TestTree ccallLineCommentTest =   testCase "CCALL macro with -- comment in argument list" $-    case preprocess defaultConfig (TE.encodeUtf8 ccallLineCommentInput) of+    case preprocess defaultConfig ccallLineCommentInput of       Done result ->-        if "foreign import ccall unsafe \"xls_wb_sheetcount\"" `T.isInfixOf` resultOutput result-          && "c_xls_wb_sheetcount :: XLSWorkbook -> IO CInt" `T.isInfixOf` resultOutput result-          && " -- Int32" `T.isInfixOf` resultOutput result+        if "foreign import ccall unsafe \"xls_wb_sheetcount\"" `C.isInfixOf` resultOutput result+          && "c_xls_wb_sheetcount :: XLSWorkbook -> IO CInt" `C.isInfixOf` resultOutput result+          && " -- Int32" `C.isInfixOf` resultOutput result           then pure ()           else assertFailure ("expected CCALL expansion with line comment, got: " <> show (resultOutput result))       _ -> assertFailure "expected Done"@@ -214,20 +364,98 @@ pragmaOnceTest :: TestTree pragmaOnceTest =   testCase "#pragma once skips repeated includes" $-    case preprocess defaultConfig {configInputFile = "root.hs"} (TE.encodeUtf8 "#include \"guarded.inc\"\n#include \"guarded.inc\"\nafter") of+    case preprocess defaultConfig {configInputFile = "root.hs"} "#include \"guarded.inc\"\n#include \"guarded.inc\"\nafter" of       NeedInclude _ k1 ->         case k1 (Just "#pragma once\ninside") of           NeedInclude {} -> assertFailure "second include should be skipped"           Done result -> do             let output = resultOutput result-            if T.count "inside" output == 1 && "after\n" `T.isSuffixOf` output+            if countSubstring "inside" output == 1 && "after\n" `C.isSuffixOf` output               then pure ()               else assertFailure ("expected guarded include once, got: " <> show output)       Done _ -> assertFailure "expected include continuation step" -ccallLineCommentInput :: T.Text+-- | Rescanning of macro expansion results, and the C standard's+-- non-recursive-expansion ("blue paint") rule that keeps it terminating.+--+-- These live here rather than in the progress corpus because cpphs, the+-- oracle that corpus compares against, has no recursion guard and diverges+-- on every self-referential case below.+macroRescanTests :: TestTree+macroRescanTests =+  testGroup+    "macro rescanning"+    [ testCase "self-referential object macro expands exactly once" $+        assertPreprocessOutput+          (C.unlines ["#define SELF SELF", "e = SELF"])+          (C.unlines ["#line 1 \"<input>\"", "", "e = SELF"]),+      testCase "self-referential object macro keeps surrounding tokens" $+        assertPreprocessOutput+          (C.unlines ["#define SELF x + SELF", "e = SELF"])+          (C.unlines ["#line 1 \"<input>\"", "", "e = x + SELF"]),+      testCase "self-referential function macro expands exactly once" $+        assertPreprocessOutput+          (C.unlines ["#define REC(x) REC(x)", "f = REC(1)"])+          (C.unlines ["#line 1 \"<input>\"", "", "f = REC(1)"]),+      testCase "mutually recursive function macros terminate" $+        assertPreprocessOutput+          (C.unlines ["#define PING(x) PONG(x)", "#define PONG(x) PING(x)", "g = PING(2)"])+          (C.unlines ["#line 1 \"<input>\"", "", "", "g = PING(2)"]),+      testCase "paint does not leak into a nested call of the same macro" $+        assertPreprocessOutput+          (C.unlines ["#define F(x) (x)", "#define G(x) F(x) + F(F(x))", "h = G(3)"])+          (C.unlines ["#line 1 \"<input>\"", "", "", "h = (3) + ((3))"])+    ]++pragmaInsideBlockCommentTests :: TestTree+pragmaInsideBlockCommentTests =+  testGroup+    "pragma inside a Haskell block comment"+    [ testCase "#-} does not close the enclosing comment" $+        case preprocess defaultConfig pragmaInBlockCommentInput of+          Done result -> do+            resultDiagnostics result @?= []+            resultOutput result+              @?= "#line 1 \"<input>\"\n{-\n#if 0\n{-# INLINABLE foo #-}\n#endif\n-}\nlive\n"+          _ -> assertFailure "expected Done",+      testCase "commented-out #if 0 does not delete live code" $+        case preprocess defaultConfig pragmaInBlockCommentElseInput of+          Done result -> do+            resultDiagnostics result @?= []+            if "kept" `C.isInfixOf` resultOutput result+              then pure ()+              else assertFailure ("expected commented-out branch to stay intact, got: " <> show (resultOutput result))+          _ -> assertFailure "expected Done"+    ]++pragmaInBlockCommentInput :: BS.ByteString+pragmaInBlockCommentInput =+  C.unlines+    [ "{-",+      "#if 0",+      "{-# INLINABLE foo #-}",+      "#endif",+      "-}",+      "live"+    ]++pragmaInBlockCommentElseInput :: BS.ByteString+pragmaInBlockCommentElseInput =+  C.unlines+    [ "{-",+      "{-# INLINABLE foo #-}",+      "#if 0",+      "kept",+      "#else",+      "also kept",+      "#endif",+      "-}",+      "live"+    ]++ccallLineCommentInput :: BS.ByteString ccallLineCommentInput =-  T.unlines+  C.unlines     [ "#define CCALL(name,signature) \\",       "foreign import ccall unsafe #name \\",       "    c_##name :: signature",@@ -235,9 +463,9 @@       "CCALL(xls_wb_sheetcount, XLSWorkbook -> IO CInt -- Int32)"     ] -ccallMacroInput :: T.Text+ccallMacroInput :: BS.ByteString ccallMacroInput =-  T.unlines+  C.unlines     [ "#define CCALL(name,signature) \\",       "foreign import ccall unsafe #name \\",       "    c_##name :: signature",@@ -245,85 +473,85 @@       "CCALL(foo, Int -> IO Int)"     ] -tokenPasteRawArgInput :: T.Text+tokenPasteRawArgInput :: BS.ByteString tokenPasteRawArgInput =-  T.unlines+  C.unlines     [ "#define X Y",       "#define JOIN(a,b) a##b",       "JOIN(X,Y)"     ] -tokenPasteRescanInput :: T.Text+tokenPasteRescanInput :: BS.ByteString tokenPasteRescanInput =-  T.unlines+  C.unlines     [ "#define VALUE 42",       "#define JOIN(a,b) a##b",       "JOIN(VAL,UE)"     ] -tokenPasteAffixInput :: T.Text+tokenPasteAffixInput :: BS.ByteString tokenPasteAffixInput =-  T.unlines+  C.unlines     [ "#define PREFIX(name) left##name",       "#define SUFFIX(name) name##right",       "PREFIX() SUFFIX()"     ] -tokenPasteChainedInput :: T.Text+tokenPasteChainedInput :: BS.ByteString tokenPasteChainedInput =-  T.unlines+  C.unlines     [ "#define CHAIN(a,b,c) a##b##c",       "CHAIN(foo,bar,)"     ] -tokenPasteHsCommentInput :: T.Text+tokenPasteHsCommentInput :: BS.ByteString tokenPasteHsCommentInput =-  T.unlines+  C.unlines     [ "#define LENS(S,F,A) {-# INLINE _/**/F #-}; _/**/F :: LensP S A; _/**/F = lens F $ \\ S {..} F/**/_ -> S {F = F/**/_, ..}",       "LENS(Foo,bar,Baz{-comment-})"     ] -gccStringContinuationInput :: T.Text+gccStringContinuationInput :: BS.ByteString gccStringContinuationInput =-  T.unlines+  C.unlines     [ "x = \"a\\\\",       "       \\b\""     ] -ghcStringGapInput :: T.Text+ghcStringGapInput :: BS.ByteString ghcStringGapInput =-  T.unlines+  C.unlines     [ "x = \"a\\",       "       \\b\""     ] -gccStringContinuationMacroInput :: T.Text+gccStringContinuationMacroInput :: BS.ByteString gccStringContinuationMacroInput =-  T.unlines+  C.unlines     [ "#define ID(x) x",       "x = ID(\"a\\\\",       "       \\b\")"     ] -ghcStringGapMacroInput :: T.Text+ghcStringGapMacroInput :: BS.ByteString ghcStringGapMacroInput =-  T.unlines+  C.unlines     [ "#define ID(x) x",       "x = ID(\"a\\",       "       \\b\")"     ] -gccStringContinuationConcatInput :: T.Text+gccStringContinuationConcatInput :: BS.ByteString gccStringContinuationConcatInput =-  T.unlines+  C.unlines     [ "x = \"a\\\\",       "       \\\" <> y <> \"\\n\\\\",       "       \\b\""     ] -nonStringDoubleBackslashInput :: T.Text+nonStringDoubleBackslashInput :: BS.ByteString nonStringDoubleBackslashInput =-  T.unlines+  C.unlines     [ "#define ID(x) x",       "x = ID(foo \\\\",       "       bar)"

@@ -0,0 +1,5 @@+#define ID(x) x+#define TWICE(x) ID(x) + ID(x)+#define SUM(a,b) (a + b)+c = ID(ID(7))+d = TWICE(SUM(1, 2))

@@ -0,0 +1,3 @@+#define F(x) (x)+#define G(x) F(x) + F(F(x))+h = G(3)

@@ -45,3 +45,10 @@ thyme-lens-comment-paste	macro	thyme-lens-comment-paste.hs	pass macro-c-block-comment-literal	macro	macro-c-block-comment-literal.hs	pass function-macro-c-block-comment	macro	function-macro-c-block-comment.hs	pass+nested-function-macro-rescan	macro	nested-function-macro-rescan.hs	pass+function-macro-arg-rescan	macro	function-macro-arg-rescan.hs	pass+macro-rescan-repeated-name	macro	macro-rescan-repeated-name.hs	pass+# Encoding-agnostic passthrough is covered by the "source encoding" tests in+# test/Spec.hs, not by a fixture here: the cpphs oracle reads its input as+# locale-decoded String and aborts on bytes it cannot decode, so it cannot+# act as an oracle for a non-UTF-8 fixture.

@@ -0,0 +1,5 @@+#define WRAP(x) (x)+#define INNER WRAP(1)+#define OUTER WRAP(INNER)+a = INNER+b = OUTER

@@ -17,6 +17,8 @@ import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Data.Text.Encoding.Error as TEE import qualified Data.Text.IO as TIO import GHC.IO.Handle (hDuplicate, hDuplicateTo) import Language.Preprocessor.Cpphs (BoolOptions (..), CpphsOptions (..), defaultCpphsOptions, runCpphs)@@ -170,7 +172,9 @@   result <- drive (preprocess defaultConfig {configInputFile = sourcePath} source)   let errors = [diagMessage d | d <- resultDiagnostics result, diagSeverity d == Error]   case errors of-    [] -> pure (Right (resultOutput result))+    -- The oracle is 'String'-based, so compare decoded text. Fixtures are+    -- all ASCII; byte-exactness of the output is covered in Spec.hs.+    [] -> pure (Right (TE.decodeUtf8With TEE.lenientDecode (resultOutput result)))     (msg : _) -> pure (Left (T.unpack msg))   where     drive (Done result) = pure result