diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/aihc-cpp.cabal b/aihc-cpp.cabal --- a/aihc-cpp.cabal +++ b/aihc-cpp.cabal @@ -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 diff --git a/bench/Bench/Corpus.hs b/bench/Bench/Corpus.hs new file mode 100644 --- /dev/null +++ b/bench/Bench/Corpus.hs @@ -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"] + ) + ) diff --git a/bench/Micro.hs b/bench/Micro.hs new file mode 100644 --- /dev/null +++ b/bench/Micro.hs @@ -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 <> ": " + _ -> 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 @\\/\\/...@, 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 @\\/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 diff --git a/bench/include/HsBaseConfig.h b/bench/include/HsBaseConfig.h new file mode 100644 --- /dev/null +++ b/bench/include/HsBaseConfig.h @@ -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 + +/* and 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 diff --git a/bench/include/MachDeps.h b/bench/include/MachDeps.h new file mode 100644 --- /dev/null +++ b/bench/include/MachDeps.h @@ -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) diff --git a/bench/include/cabal_macros.h b/bench/include/cabal_macros.h new file mode 100644 --- /dev/null +++ b/bench/include/cabal_macros.h @@ -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 diff --git a/src/Aihc/Cpp.hs b/src/Aihc/Cpp.hs --- a/src/Aihc/Cpp.hs +++ b/src/Aihc/Cpp.hs @@ -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 "" -- -- 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 "" -- -- ((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 "" -- @@ -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 "" -- #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 "" @@ -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 "" @@ -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 "" -- -- Diagnostic {diagSeverity = Error, diagMessage = "Build failed", diagFile = "", 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 \"\"\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 '\' 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 <> "\"" diff --git a/src/Aihc/Cpp/Cursor.hs b/src/Aihc/Cpp/Cursor.hs --- a/src/Aihc/Cpp/Cursor.hs +++ b/src/Aihc/Cpp/Cursor.hs @@ -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. diff --git a/src/Aihc/Cpp/Evaluator.hs b/src/Aihc/Cpp/Evaluator.hs --- a/src/Aihc/Cpp/Evaluator.hs +++ b/src/Aihc/Cpp/Evaluator.hs @@ -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 diff --git a/src/Aihc/Cpp/Parser.hs b/src/Aihc/Cpp/Parser.hs --- a/src/Aihc/Cpp/Parser.hs +++ b/src/Aihc/Cpp/Parser.hs @@ -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 = diff --git a/src/Aihc/Cpp/Scanner.hs b/src/Aihc/Cpp/Scanner.hs --- a/src/Aihc/Cpp/Scanner.hs +++ b/src/Aihc/Cpp/Scanner.hs @@ -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) diff --git a/src/Aihc/Cpp/Types.hs b/src/Aihc/Cpp/Types.hs --- a/src/Aihc/Cpp/Types.hs +++ b/src/Aihc/Cpp/Types.hs @@ -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, diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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 \"\"\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 \"\"\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 \"\"\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 \"\"\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 \"\"\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 \"\"\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 \"\"\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 \"\"\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 \"\"", "x = \"a\\ \\b\""]), + (C.unlines ["#line 1 \"\"", "x = \"a\\ \\b\""]), testCase "ordinary string preserves GHC single-backslash gap" $ assertPreprocessOutput ghcStringGapInput - (T.unlines ["#line 1 \"\"", "x = \"a\\", " \\b\""]), + (C.unlines ["#line 1 \"\"", "x = \"a\\", " \\b\""]), testCase "function macro argument accepts GCC double-backslash continuation" $ assertPreprocessOutput gccStringContinuationMacroInput - (T.unlines ["#line 1 \"\"", "", "x = \"a\\ \\b\""]), + (C.unlines ["#line 1 \"\"", "", "x = \"a\\ \\b\""]), testCase "function macro argument preserves GHC single-backslash gap" $ assertPreprocessOutput ghcStringGapMacroInput - (T.unlines ["#line 1 \"\"", "", "x = \"a\\", " \\b\""]), + (C.unlines ["#line 1 \"\"", "", "x = \"a\\", " \\b\""]), testCase "GCC continuation tracks string gaps across concatenation" $ assertPreprocessOutput gccStringContinuationConcatInput - (T.unlines ["#line 1 \"\"", "x = \"a\\ \\\" <> y <> \"\\n\\ \\b\""]), + (C.unlines ["#line 1 \"\"", "x = \"a\\ \\\" <> y <> \"\\n\\ \\b\""]), testCase "double backslash outside strings is not line-spliced" $ assertPreprocessOutput nonStringDoubleBackslashInput - (T.unlines ["#line 1 \"\"", "", "x = foo \\\\", " bar"]) + (C.unlines ["#line 1 \"\"", "", "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 \"\"\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 \"\"\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 \"\"\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 \"\"\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 \"\"\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 \"\"", "", "e = SELF"]), + testCase "self-referential object macro keeps surrounding tokens" $ + assertPreprocessOutput + (C.unlines ["#define SELF x + SELF", "e = SELF"]) + (C.unlines ["#line 1 \"\"", "", "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 \"\"", "", "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 \"\"", "", "", "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 \"\"", "", "", "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 \"\"\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)" diff --git a/test/Test/Fixtures/progress/function-macro-arg-rescan.hs b/test/Test/Fixtures/progress/function-macro-arg-rescan.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/progress/function-macro-arg-rescan.hs @@ -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)) diff --git a/test/Test/Fixtures/progress/macro-rescan-repeated-name.hs b/test/Test/Fixtures/progress/macro-rescan-repeated-name.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/progress/macro-rescan-repeated-name.hs @@ -0,0 +1,3 @@ +#define F(x) (x) +#define G(x) F(x) + F(F(x)) +h = G(3) diff --git a/test/Test/Fixtures/progress/manifest.tsv b/test/Test/Fixtures/progress/manifest.tsv --- a/test/Test/Fixtures/progress/manifest.tsv +++ b/test/Test/Fixtures/progress/manifest.tsv @@ -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. diff --git a/test/Test/Fixtures/progress/nested-function-macro-rescan.hs b/test/Test/Fixtures/progress/nested-function-macro-rescan.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/progress/nested-function-macro-rescan.hs @@ -0,0 +1,5 @@ +#define WRAP(x) (x) +#define INNER WRAP(1) +#define OUTER WRAP(INNER) +a = INNER +b = OUTER diff --git a/test/Test/Progress.hs b/test/Test/Progress.hs --- a/test/Test/Progress.hs +++ b/test/Test/Progress.hs @@ -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