[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: testsuite: detect fast bignum via ghc-internal, not removed ghc-bignum
by Marge Bot (＠marge-bot) 09 Jun '26
by Marge Bot (＠marge-bot) 09 Jun '26
09 Jun '26
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
2f3cc9ff by Simon Jakobi at 2026-06-08T07:55:49-04:00
testsuite: detect fast bignum via ghc-internal, not removed ghc-bignum
The ghc-bignum package was merged into ghc-internal, so the BIGNUM_GMP
probe in test.mk ran `ghc-pkg field ghc-bignum exposed-modules`, which
fails with "cannot find package ghc-bignum". That error went to stderr
and leaked into the captured stderr of every makefile_test, causing
spurious [bad stderr] failures across the suite. The probe also silently
returned empty, so config.have_fast_bignum was wrongly False even on GMP
builds.
Probe ghc-internal's extra-libraries for the gmp library instead: the
GMP backend module is an other-module (not exposed), but GMP_LIBS adds
gmp to extra-libraries only on a GMP build, so this distinguishes the
backends. Redirect stderr to keep any future missing-package error off
the harness's stderr.
This also removes a stale comment as per suggestion from hsyl20.
Co-Authored-By: Claude Opus 4.7 <noreply(a)anthropic.com>
- - - - -
eb3bf6e7 by Alan Zimmerman at 2026-06-08T07:56:32-04:00
EPA: Rename Transform.anchorEof to addModuleCommentOrigDeltas
This now matches what it actually does.
- - - - -
0dc97b12 by Brian McKenna at 2026-06-09T06:38:48-04:00
Ignore ticks in the pattern-match term oracle
The term-oracle in the pattern-match checker is keyed by a canonical
form of the scrutinee, computed by `makeDictsCoherent`. That canonical
form was tick-sensitive: two occurrences of an otherwise identical
expression that happened to carry different ticks were treated as
distinct values, breaking long-distance information.
This shows up in practice under `-finfo-table-map`, because the
desugarer wraps every record-selector use site in a `SourceNote`
carrying that site's span. For example:
data Box = Box { unBox :: Maybe Int }
f b = case unBox b of
Nothing -> 0
Just _ -> let Just x = unBox b in x
The two `unBox b` expressionss carry different SourceNote spans, the
pattern-match checker sees them as different, the long-distance
information from the outer `Just _` branch never reaches the
let-pattern, and `Just x = unBox b` is wrongly reported as
non-exhaustive.
We now strip all ticks in `makeDictsCoherent`. This is documented as
Wrinkle (UD1) of Note [Unique dictionaries in the TmOracle CoreMap].
Fixes #27314
- - - - -
3465c065 by David Eichmann at 2026-06-09T06:38:49-04:00
Hadrian: remove unused wrapper scripts from windows bindist
These wrapper scripts are only installed on non-relocatable builds
which are not generally supported on windows.
- - - - -
8 changed files:
- + changelog.d/T27314.md
- compiler/GHC/HsToCore/Pmc/Solver.hs
- hadrian/src/Rules/BinaryDist.hs
- testsuite/mk/test.mk
- + testsuite/tests/pmcheck/should_compile/T27314.hs
- testsuite/tests/pmcheck/should_compile/all.T
- utils/check-exact/Main.hs
- utils/check-exact/Transform.hs
Changes:
=====================================
changelog.d/T27314.md
=====================================
@@ -0,0 +1,10 @@
+section: compiler
+issues: #27314
+mrs: !16118
+synopsis:
+ Fix spurious ``-Wincomplete-uni-patterns`` warning under ``-finfo-table-map``.
+description:
+ The pattern-match checker now ignores ticks when comparing scrutinees in
+ its CoreMap, so long-distance information is no longer lost across
+ function-application scrutinees because debug source annotations
+ (e.g. SourceNotes added by ``-finfo-table-map``) were inserted.
=====================================
compiler/GHC/HsToCore/Pmc/Solver.hs
=====================================
@@ -1000,8 +1000,9 @@ makeDictsCoherent (Case scrut bndr ty alts)
, let expr' = makeDictsCoherent expr ]
makeDictsCoherent (Cast expr co)
= Cast (makeDictsCoherent expr) co
-makeDictsCoherent (Tick tick expr)
- = Tick tick (makeDictsCoherent expr)
+makeDictsCoherent (Tick _tick expr)
+ -- See Wrinkle (UD1) in Note [Unique dictionaries in the TmOracle CoreMap]
+ = makeDictsCoherent expr
makeDictsCoherent ty@(Type {})
= ty
makeDictsCoherent co@(Coercion {})
@@ -1061,6 +1062,25 @@ In the end, replacing dictionaries with an error value in the pattern-match
checker was the most self-contained, although we might want to revisit once
we implement a more robust approach to computing equality in the pattern-match
checker (see #19272).
+
+Wrinkle (UD1): ticks
+--------------------
+'makeDictsCoherent' also drops all ticks. The CoreMap key represents
+value-level equality, which ticks never affect.
+
+Example (#27314): with -finfo-table-map every record-selector use site is
+wrapped in a 'SourceNote' carrying that site's span (see
+Note [Record-selector ticks] in GHC.HsToCore.Ticks). Given
+
+ data Box = Box { unBox :: Maybe Int }
+ f b = case unBox b of
+ Nothing -> 0
+ Just _ -> let Just x = unBox b in x
+
+the two `unBox b`s carry different SourceNote spans. Without tick stripping
+the CoreMap treats them as distinct expressions. Long-distance information
+from the outer `Just _` branch therefore never reaches the let-pattern, and
+`Just x = unBox b` is wrongly reported as non-exhaustive.
-}
{- Note [The Pos/Neg invariant]
=====================================
hadrian/src/Rules/BinaryDist.hs
=====================================
@@ -290,23 +290,25 @@ bindistRules = do
copyFile ("hadrian" -/- "cfg" -/- "default.target.in") (bindistFilesDir -/- "default.target.in")
copyFile ("hadrian" -/- "cfg" -/- "default.host.target.in") (bindistFilesDir -/- "default.host.target.in")
- -- todo: do we need these wrappers on windows
- forM_ bin_targets $ \(pkg, _) -> do
- needed_wrappers <- pkgToWrappers pkg
- forM_ needed_wrappers $ \wrapper_name -> do
- let suffix = if useGhcPrefix pkg
- then "ghc-" ++ version
- else version
- wrapper_content <- wrapper wrapper_name
- let unversioned_wrapper_path = bindistFilesDir -/- "wrappers" -/- wrapper_name
- versioned_wrapper = wrapper_name ++ "-" ++ suffix
- versioned_wrapper_path = bindistFilesDir -/- "wrappers" -/- versioned_wrapper
- -- Write the wrapper to the versioned path
- writeFile' versioned_wrapper_path wrapper_content
- -- Create a symlink from the non-versioned to the versioned.
- liftIO $ do
- IO.removeFile unversioned_wrapper_path <|> return ()
- IO.createFileLink versioned_wrapper unversioned_wrapper_path
+ -- These wrapper scripts are only necessary in the configure/install
+ -- workflow which is not supported on windows.
+ unless windowsHost $ do
+ forM_ bin_targets $ \(pkg, _) -> do
+ needed_wrappers <- pkgToWrappers pkg
+ forM_ needed_wrappers $ \wrapper_name -> do
+ let suffix = if useGhcPrefix pkg
+ then "ghc-" ++ version
+ else version
+ wrapper_content <- wrapper wrapper_name
+ let unversioned_wrapper_path = bindistFilesDir -/- "wrappers" -/- wrapper_name
+ versioned_wrapper = wrapper_name ++ "-" ++ suffix
+ versioned_wrapper_path = bindistFilesDir -/- "wrappers" -/- versioned_wrapper
+ -- Write the wrapper to the versioned path
+ writeFile' versioned_wrapper_path wrapper_content
+ -- Create a symlink from the non-versioned to the versioned.
+ liftIO $ do
+ IO.removeFile unversioned_wrapper_path <|> return ()
+ IO.createFileLink versioned_wrapper unversioned_wrapper_path
let buildBinDist compressor = do
win_target <- isWinTarget
=====================================
testsuite/mk/test.mk
=====================================
@@ -109,9 +109,11 @@ endif
HAVE_GDB := $(shell if gdb --version > /dev/null 2> /dev/null; then echo YES; else echo NO; fi)
HAVE_READELF := $(shell if readelf --version > /dev/null 2> /dev/null; then echo YES; else echo NO; fi)
-# we need a better way to find which backend is selected and if --check flag is
-# used
-BIGNUM_GMP := $(shell "$(GHC_PKG)" field ghc-bignum exposed-modules | grep GMP)
+# Detect whether the fast (GMP) bignum backend is in use. The GMP backend module
+# in ghc-internal is hidden, so we look instead for the gmp library it links
+# against: GMP_LIBS adds gmp to ghc-internal's extra-libraries only on a GMP
+# build.
+BIGNUM_GMP := $(shell "$(GHC_PKG)" field ghc-internal extra-libraries 2>/dev/null | grep gmp)
ifeq "$(filter thr, $(GhcRTSWays))" "thr"
RUNTEST_OPTS += -e config.ghc_with_threaded_rts=True
=====================================
testsuite/tests/pmcheck/should_compile/T27314.hs
=====================================
@@ -0,0 +1,8 @@
+module T27314 where
+
+data Box = Box { unBox :: Maybe Int }
+
+f :: Box -> Int
+f b = case unBox b of
+ Nothing -> 0
+ Just _ -> let Just x = unBox b in x
=====================================
testsuite/tests/pmcheck/should_compile/all.T
=====================================
@@ -93,6 +93,7 @@ test('T21360', normal, compile, [overlapping_incomplete+'-Wincomplete-record-upd
test('T21360b', normal, compile, [overlapping_incomplete+'-Wincomplete-record-updates'])
test('T23520', normal, compile, [overlapping_incomplete+'-Wincomplete-record-updates'])
test('T25164', [extra_files(['T25164_aux.hs']), req_th], multimod_compile, ['T25164', '-v0'])
+test('T27314', normal, compile, ['-Wincomplete-uni-patterns -finfo-table-map'])
# Other tests
test('pmc001', [], compile, [overlapping_incomplete])
=====================================
utils/check-exact/Main.hs
=====================================
@@ -646,7 +646,7 @@ addLocaLDecl3 :: Changer
addLocaLDecl3 libdir top = do
Right newDecl <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2")
let
- doAddLocal = replaceDecls (anchorEof lp) [parent',d2']
+ doAddLocal = replaceDecls (addModuleCommentOrigDeltas lp) [parent',d2']
where
lp = top
(de1:d2:_) = hsDecls lp
@@ -667,7 +667,7 @@ addLocaLDecl4 libdir lp = do
Right newDecl <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2")
Right newSig <- withDynFlags libdir (\df -> parseDecl df "sig" "nn :: Int")
let
- doAddLocal = replaceDecls (anchorEof lp) (parent':ds)
+ doAddLocal = replaceDecls (addModuleCommentOrigDeltas lp) (parent':ds)
where
(parent:ds) = hsDecls (makeDeltaAst lp)
@@ -781,7 +781,7 @@ rmDecl3 _libdir lp = do
rmDecl4 :: Changer
rmDecl4 _libdir lp = do
let
- doRmDecl = replaceDecls (anchorEof lp) [de1',sd1]
+ doRmDecl = replaceDecls (addModuleCommentOrigDeltas lp) [de1',sd1]
where
[de1] = hsDecls lp
(de1',Just sd1) = modifyValD (getLocA de1) de1 $ \_m [sd1a,sd2] ->
=====================================
utils/check-exact/Transform.hs
=====================================
@@ -65,7 +65,7 @@ module Transform
, balanceComments
, balanceCommentsList
, balanceCommentsListA
- , anchorEof
+ , addModuleCommentOrigDeltas
-- ** Managing lists, pure functions
, captureOrderBinds
@@ -724,8 +724,8 @@ balanceSameLineComments (L la (Match anm mctxt pats (GRHSs x grhss lb)))
-- ---------------------------------------------------------------------
-anchorEof :: ParsedSource -> ParsedSource
-anchorEof (L l m@(HsModule (XModulePs an _lo _ _) _mn _exps _imps _decls)) = L l (m { hsmodExt = (hsmodExt m){ hsmodAnn = an' } })
+addModuleCommentOrigDeltas :: ParsedSource -> ParsedSource
+addModuleCommentOrigDeltas (L l m@(HsModule (XModulePs an _lo _ _) _mn _exps _imps _decls)) = L l (m { hsmodExt = (hsmodExt m){ hsmodAnn = an' } })
where
an' = addCommentOrigDeltasAnn an
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7da2b3256233f4aeee8beaa1c97e6d…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7da2b3256233f4aeee8beaa1c97e6d…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/sjakobi/T25450-march-native] Implement -march=native for x86/x86_64
by Simon Jakobi (＠sjakobi2) 09 Jun '26
by Simon Jakobi (＠sjakobi2) 09 Jun '26
09 Jun '26
Simon Jakobi pushed to branch wip/sjakobi/T25450-march-native at Glasgow Haskell Compiler / GHC
Commits:
12b5f01f by Simon Jakobi at 2026-06-09T11:28:55+02:00
Implement -march=native for x86/x86_64
Add a -march=native flag that probes the host CPU at parse time via an
in-process CPUID/XGETBV helper and enables the matching CPU-feature
DynFlags, so the effect applies to both the NCG and LLVM backends.
The flag handler only records a marker, since flag parsing is pure; the
probe and feature application run in parseDynamicFlagsFull, guarded
against non-x86 targets and cross-compilation. Detected SSE/AVX and BMI
levels are collapsed to their maximum and folded additively into the
existing feature flags, so explicit -m... options are never disabled.
The probe is memoized for the lifetime of the process.
On x86_64 macOS the kernel enables AVX-512 XSAVE state lazily, so XCR0
reads back with the opmask/ZMM bits clear until a process first faults on
an AVX-512 instruction. To avoid a false negative there, AVX512F is
queried via sysctlbyname(hw.optional.avx512f); the sub-features
(BW/CD/DQ/VL) are still decoded from CPUID leaf 7, and AVX/AVX2/FMA stay
on the XCR0 path, which is correct on macOS.
The flag is registered in expected-undocumented-flags.txt due to #27321.
Thanks to @aratamizuki for help with AVX-512 detection on macOS.
Closes #25450
Assisted-by: Claude Opus 4.8 <noreply(a)anthropic.com>
- - - - -
16 changed files:
- + changelog.d/march-native
- changelog.d/print-enabled-cpu-features
- + compiler/GHC/Driver/CpuFeatures.hs
- compiler/GHC/Driver/DynFlags.hs
- compiler/GHC/Driver/Session.hs
- + compiler/cbits/cpu_features_x86.c
- compiler/ghc.cabal.in
- docs/users_guide/expected-undocumented-flags.txt
- docs/users_guide/using.rst
- testsuite/tests/codeGen/should_gen_asm/all.T
- + testsuite/tests/codeGen/should_gen_asm/march-native-enables-popcnt.asm
- + testsuite/tests/codeGen/should_gen_asm/march-native-enables-popcnt.hs
- testsuite/tests/driver/all.T
- + testsuite/tests/driver/march_native.stdout
- + testsuite/tests/driver/march_native_additive.stdout
- + testsuite/tests/driver/march_native_unsupported_arch.stderr
Changes:
=====================================
changelog.d/march-native
=====================================
@@ -0,0 +1,12 @@
+section: compiler
+synopsis: Add -march=native flag
+issues: #25450
+mrs: !16126
+
+description:
+ GHC now supports ``-march=native`` on x86 and x86_64. It probes the CPU of the
+ machine running GHC and enables all of the corresponding ``-m...`` CPU-feature
+ options automatically (such as ``-msse4.2``, ``-mavx2``, ``-mbmi2`` and
+ ``-mfma``), for both the native code generator and the LLVM backend. The
+ detected features are enabled in addition to any explicitly requested feature
+ flags. The flag is rejected for non-x86 targets and when cross-compiling.
=====================================
changelog.d/print-enabled-cpu-features
=====================================
@@ -8,9 +8,11 @@ description:
prints a JSON object describing the CPU features currently enabled for code
generation, together with a set of ``-m...`` flags that reproduce the
effective feature set for the current target.
- Dynamic options such as ``-mavx2`` and ``-mbmi2`` are respected. ::
+ Dynamic options such as ``-mavx2`` and ``-mbmi2`` are respected, so the flag
+ can also be used to inspect which features :ghc-flag:`-march=native` detected
+ and enabled. ::
- $ ghc -mavx2 --print-enabled-cpu-features
+ $ ghc -march=native --print-enabled-cpu-features
{"tag":"enabled-cpu-features","version":1,"target":"x86_64-linux-gnu",
- "features":["SSE","SSE2","SSE3","SSSE3","SSE4.1","SSE4.2","AVX","AVX2"],
- "as_m_flags":["-mavx2"]}
+ "features":["SSE","SSE2","SSE3","SSSE3","SSE4.1","SSE4.2","AVX","AVX2","BMI1","BMI2","FMA"],
+ "as_m_flags":["-mavx2","-mbmi2","-mfma"]}
=====================================
compiler/GHC/Driver/CpuFeatures.hs
=====================================
@@ -0,0 +1,87 @@
+{-# LANGUAGE CPP #-}
+
+module GHC.Driver.CpuFeatures
+ ( X86CpuFeature(..)
+ , cachedX86CpuFeatures
+ ) where
+
+import GHC.Prelude
+
+import Data.Word (Word64)
+import System.IO.Unsafe (unsafePerformIO)
+
+-- | x86 CPU features understood by GHC's native CPU feature probe.
+data X86CpuFeature
+ = SSE2
+ | SSE3
+ | SSSE3
+ | SSE4_1
+ | SSE4_2
+ | AVX
+ | AVX2
+ | AVX512F
+ | AVX512BW
+ | AVX512CD
+ | AVX512DQ
+ | AVX512VL
+ | BMI1
+ | BMI2
+ | FMA
+ | GFNI
+ deriving (Eq, Ord, Show)
+
+-- | Decode the bitmask returned by 'ghc_detect_x86_cpu_features'.
+--
+-- NOTE: Bit positions must match the enum in @compiler/cbits/cpu_features_x86.c@.
+decodeX86CpuFeatureMask :: Word64 -> [X86CpuFeature]
+decodeX86CpuFeatureMask mask =
+ [ feat
+ | (bit_ix, feat) <- cpuFeatureBitLayout
+ , testBit mask bit_ix
+ ]
+
+-- | Low-level FFI access to the C probe.
+detectX86CpuFeatureMask :: IO Word64
+#if defined(javascript_HOST_ARCH)
+detectX86CpuFeatureMask = pure 0
+#else
+detectX86CpuFeatureMask = c_ghc_detect_x86_cpu_features
+#endif
+
+-- | Probe host x86 CPU features and decode them into an ordered feature list.
+detectX86CpuFeatures :: IO [X86CpuFeature]
+detectX86CpuFeatures = decodeX86CpuFeatureMask <$> detectX86CpuFeatureMask
+
+-- | The host's x86 CPU features, probed once and memoized.
+--
+-- CPUID results are constant for the lifetime of the process, so probing more
+-- than once (e.g. once per @-march=native@ in a command line or file pragma)
+-- is wasteful. This is referentially transparent despite the FFI call.
+cachedX86CpuFeatures :: [X86CpuFeature]
+cachedX86CpuFeatures = unsafePerformIO detectX86CpuFeatures
+{-# NOINLINE cachedX86CpuFeatures #-}
+
+cpuFeatureBitLayout :: [(Int, X86CpuFeature)]
+cpuFeatureBitLayout =
+ [ (0, SSE2)
+ , (1, SSE3)
+ , (2, SSSE3)
+ , (3, SSE4_1)
+ , (4, SSE4_2)
+ , (5, AVX)
+ , (6, AVX2)
+ , (7, AVX512F)
+ , (8, AVX512BW)
+ , (9, AVX512CD)
+ , (10, AVX512DQ)
+ , (11, AVX512VL)
+ , (12, BMI1)
+ , (13, BMI2)
+ , (14, FMA)
+ , (15, GFNI)
+ ]
+
+#if !defined(javascript_HOST_ARCH)
+foreign import ccall unsafe "ghc_detect_x86_cpu_features"
+ c_ghc_detect_x86_cpu_features :: IO Word64
+#endif
=====================================
compiler/GHC/Driver/DynFlags.hs
=====================================
@@ -470,6 +470,8 @@ data DynFlags = DynFlags {
fma :: Bool, -- ^ Enable FMA instructions.
gfni :: Bool, -- ^ Enable GFNI Instructions.
la664 :: Bool, -- ^ Enable LA664 instructions
+ marchNative :: Bool, -- ^ @-march=native@ was requested; the host
+ -- CPU features are applied during flag parsing.
-- Constants used to control the amount of optimization done.
@@ -760,6 +762,7 @@ defaultDynFlags mySettings =
gfni = False,
-- For LoongArch, la464 is used by default.
la664 = False,
+ marchNative = False,
maxInlineAllocSize = 128,
maxInlineMemcpyInsns = 32,
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -245,6 +245,8 @@ import GHC.Platform
import GHC.Platform.Ways
import GHC.Platform.Profile
import GHC.Platform.ArchOS
+import GHC.Platform.Host (hostPlatformArch)
+import qualified GHC.Driver.CpuFeatures as Cpu
import GHC.Unit.Types
import GHC.Unit.Parser
@@ -906,8 +908,12 @@ parseDynamicFlagsFull activeFlags cmdline logger dflags0 args = do
unless (null errs) $ liftIO $ throwGhcExceptionIO $ errorsToGhcException $
map ((rdr . ppr . getLoc &&& unLoc) . errMsg) $ errs
+ -- Apply -march=native: probe the host CPU and enable the matching feature
+ -- flags. This needs IO (CPUID), so it cannot live in the pure flag handlers.
+ dflags1' <- applyMarchNative dflags1
+
-- check for disabled flags in safe haskell
- let (dflags2, sh_warns) = safeFlagCheck cmdline dflags1
+ let (dflags2, sh_warns) = safeFlagCheck cmdline dflags1'
theWays = ways dflags2
unless (allowed_combination theWays) $ liftIO $
@@ -1743,6 +1749,7 @@ dynamic_flags_deps = [
, make_ord_flag defGhcFlag "mavx512vl" (noArg (\d -> d { avx512vl = True }))
, make_ord_flag defGhcFlag "mfma" (noArg (\d -> d { fma = True }))
, make_ord_flag defGhcFlag "mgfni" (noArg (\d -> d { gfni = True }))
+ , make_ord_flag defGhcFlag "march=native" (noArg (\d -> d { marchNative = True }))
, make_ord_flag defGhcFlag "mla664" (noArg (\d -> d { la664 = True }))
@@ -3806,6 +3813,59 @@ x86AsMFlags dflags =
gfniFlags = [ "-mgfni" | gfni dflags ]
+-- | Apply a requested @-march=native@ by probing the host CPU and enabling the
+-- matching CPU-feature flags.
+--
+-- This runs in 'parseDynamicFlagsFull' rather than in a flag handler because the
+-- CPUID probe needs 'IO', whereas flag handlers are pure. The detected features
+-- are folded into the existing feature 'DynFlags' so that 'makeDynFlagsConsistent'
+-- and the backends treat them exactly like the corresponding @-m...@ flags.
+applyMarchNative :: MonadIO m => DynFlags -> m DynFlags
+applyMarchNative dflags
+ | not (marchNative dflags) = return dflags
+ | otherwise = do
+ let arch = platformArch (targetPlatform dflags)
+ unless (arch == ArchX86 || arch == ArchX86_64) $ liftIO $
+ throwGhcExceptionIO $ CmdLineError
+ "-march=native is only supported on x86 and x86_64 targets"
+ unless (arch == hostPlatformArch) $ liftIO $
+ throwGhcExceptionIO $ CmdLineError
+ "-march=native is not supported when cross-compiling"
+ return (applyX86CpuFeatures Cpu.cachedX86CpuFeatures dflags)
+
+-- | Enable the 'DynFlags' CPU-feature fields corresponding to a probed set of
+-- host x86 features. SSE/AVX and BMI levels are collapsed to their maximum,
+-- since 'sseAvxVersion' and 'bmiVersion' each record a single level.
+applyX86CpuFeatures :: [Cpu.X86CpuFeature] -> DynFlags -> DynFlags
+applyX86CpuFeatures feats dflags = dflags
+ { sseAvxVersion = foldr (max . Just) (sseAvxVersion dflags) sseLevels
+ , bmiVersion = foldr (max . Just) (bmiVersion dflags) bmiLevels
+ , avx512f = avx512f dflags || has Cpu.AVX512F
+ , avx512bw = avx512bw dflags || has Cpu.AVX512BW
+ , avx512cd = avx512cd dflags || has Cpu.AVX512CD
+ , avx512dq = avx512dq dflags || has Cpu.AVX512DQ
+ , avx512vl = avx512vl dflags || has Cpu.AVX512VL
+ , fma = fma dflags || has Cpu.FMA
+ , gfni = gfni dflags || has Cpu.GFNI
+ }
+ where
+ has feat = feat `elem` feats
+ sseLevels = [ lvl | feat <- feats, Just lvl <- [sseLevelOf feat] ]
+ bmiLevels = [ lvl | feat <- feats, Just lvl <- [bmiLevelOf feat] ]
+ sseLevelOf feat = case feat of
+ Cpu.SSE2 -> Just SSE2
+ Cpu.SSE3 -> Just SSE3
+ Cpu.SSSE3 -> Just SSSE3
+ Cpu.SSE4_1 -> Just SSE4
+ Cpu.SSE4_2 -> Just SSE42
+ Cpu.AVX -> Just AVX1
+ Cpu.AVX2 -> Just AVX2
+ _ -> Nothing
+ bmiLevelOf feat = case feat of
+ Cpu.BMI1 -> Just BMI1
+ Cpu.BMI2 -> Just BMI2
+ _ -> Nothing
+
-- | Query if the target RTS has the given 'Ways'. It's computed from
-- the @"RTS ways"@ field in the settings file.
targetHasRTSWays :: DynFlags -> Ways -> Bool
=====================================
compiler/cbits/cpu_features_x86.c
=====================================
@@ -0,0 +1,208 @@
+#include <HsFFI.h>
+#include <stdint.h>
+
+#if defined(_MSC_VER) && (defined(_M_IX86) || defined(_M_X64))
+#include <immintrin.h>
+#include <intrin.h>
+#endif
+
+#if !defined(_MSC_VER) && (defined(__i386__) || defined(__x86_64__))
+#include <cpuid.h>
+#endif
+
+#if defined(__APPLE__) && (defined(__i386__) || defined(__x86_64__))
+#include <sys/sysctl.h>
+#endif
+
+enum {
+ GHC_X86_FEAT_SSE2 = 0,
+ GHC_X86_FEAT_SSE3,
+ GHC_X86_FEAT_SSSE3,
+ GHC_X86_FEAT_SSE4_1,
+ GHC_X86_FEAT_SSE4_2,
+ GHC_X86_FEAT_AVX,
+ GHC_X86_FEAT_AVX2,
+ GHC_X86_FEAT_AVX512F,
+ GHC_X86_FEAT_AVX512BW,
+ GHC_X86_FEAT_AVX512CD,
+ GHC_X86_FEAT_AVX512DQ,
+ GHC_X86_FEAT_AVX512VL,
+ GHC_X86_FEAT_BMI1,
+ GHC_X86_FEAT_BMI2,
+ GHC_X86_FEAT_FMA,
+ GHC_X86_FEAT_GFNI
+};
+
+#define SET_FEAT(mask, bit) ((mask) |= ((HsWord64)1ULL << (bit)))
+
+static int ghc_cpuid_count(uint32_t leaf, uint32_t subleaf,
+ uint32_t *a, uint32_t *b, uint32_t *c, uint32_t *d)
+{
+#if defined(_MSC_VER) && (defined(_M_IX86) || defined(_M_X64))
+ int regs[4];
+ __cpuidex(regs, (int)leaf, (int)subleaf);
+ *a = (uint32_t)regs[0];
+ *b = (uint32_t)regs[1];
+ *c = (uint32_t)regs[2];
+ *d = (uint32_t)regs[3];
+ return 1;
+#elif defined(__i386__) || defined(__x86_64__)
+ return __get_cpuid_count(leaf, subleaf, a, b, c, d);
+#else
+ (void)leaf;
+ (void)subleaf;
+ (void)a;
+ (void)b;
+ (void)c;
+ (void)d;
+ return 0;
+#endif
+}
+
+static uint64_t ghc_xgetbv0(void)
+{
+#if defined(_MSC_VER) && (defined(_M_IX86) || defined(_M_X64))
+ return (uint64_t)_xgetbv(0);
+#elif defined(__i386__) || defined(__x86_64__)
+ uint32_t eax, edx;
+ __asm__ volatile(".byte 0x0f, 0x01, 0xd0" /* xgetbv */
+ : "=a"(eax), "=d"(edx)
+ : "c"(0));
+ return ((uint64_t)edx << 32) | (uint64_t)eax;
+#else
+ return 0;
+#endif
+}
+
+#if defined(__APPLE__) && (defined(__i386__) || defined(__x86_64__))
+/* Query a macOS CPU-capability sysctl, e.g. "hw.optional.avx512f". */
+static int ghc_macos_sysctl_flag(const char *name)
+{
+ int result = 0;
+ size_t len = sizeof(result);
+ if (sysctlbyname(name, &result, &len, NULL, 0) != 0) {
+ return 0;
+ }
+ return result != 0;
+}
+#endif
+
+HsWord64 ghc_detect_x86_cpu_features(void)
+{
+ HsWord64 feats = 0;
+
+#if defined(_M_IX86) || defined(_M_X64) || defined(__i386__) || defined(__x86_64__)
+ uint32_t a, b, c, d;
+ uint32_t max_basic = 0;
+
+ if (!ghc_cpuid_count(0, 0, &a, &b, &c, &d)) {
+ return 0;
+ }
+ max_basic = a;
+ if (max_basic < 1) {
+ return 0;
+ }
+
+ ghc_cpuid_count(1, 0, &a, &b, &c, &d);
+
+ {
+ int has_sse2 = !!(d & (1u << 26));
+ int has_sse3 = !!(c & (1u << 0));
+ int has_ssse3 = !!(c & (1u << 9));
+ int has_sse4_1 = !!(c & (1u << 19));
+ int has_sse4_2 = !!(c & (1u << 20));
+ int has_fma_hw = !!(c & (1u << 12));
+ int has_avx_hw = !!(c & (1u << 28));
+ int has_osxsave = !!(c & (1u << 27));
+
+ int avx_usable = 0;
+ int avx512_usable = 0;
+
+ if (has_osxsave) {
+ uint64_t xcr0 = ghc_xgetbv0();
+ avx_usable = ((xcr0 & 0x6u) == 0x6u); /* XMM + YMM state */
+ avx512_usable = ((xcr0 & 0xE6u) == 0xE6u); /* XMM+YMM+opmask+ZMM */
+ }
+
+#if defined(__APPLE__)
+ /* On x86_64 macOS the kernel enables AVX-512 XSAVE state lazily: XCR0
+ reads back with the opmask/ZMM bits clear until a process first faults
+ on an AVX-512 instruction, so the XCR0 check above is a false negative
+ on AVX-512-capable Macs. Use the OS feature query instead. Checking
+ AVX512F alone suffices here; the AVX-512 sub-features (BW/CD/DQ/VL) are
+ still decoded from CPUID leaf 7 below.
+
+ Refs:
+ https://zenn.dev/mod_poppo/articles/detect-processor-features-x86?locale=en…
+ https://github.com/minoki/haskell-cpu-features */
+ avx512_usable = ghc_macos_sysctl_flag("hw.optional.avx512f");
+#endif
+
+ if (has_sse2) {
+ SET_FEAT(feats, GHC_X86_FEAT_SSE2);
+ }
+ if (has_sse3) {
+ SET_FEAT(feats, GHC_X86_FEAT_SSE3);
+ }
+ if (has_ssse3) {
+ SET_FEAT(feats, GHC_X86_FEAT_SSSE3);
+ }
+ if (has_sse4_1) {
+ SET_FEAT(feats, GHC_X86_FEAT_SSE4_1);
+ }
+ if (has_sse4_2) {
+ SET_FEAT(feats, GHC_X86_FEAT_SSE4_2);
+ }
+ if (has_avx_hw && avx_usable) {
+ SET_FEAT(feats, GHC_X86_FEAT_AVX);
+ }
+ if (has_fma_hw && avx_usable) {
+ SET_FEAT(feats, GHC_X86_FEAT_FMA);
+ }
+
+ if (max_basic >= 7 && ghc_cpuid_count(7, 0, &a, &b, &c, &d)) {
+ int has_bmi1 = !!(b & (1u << 3));
+ int has_avx2_hw = !!(b & (1u << 5));
+ int has_bmi2 = !!(b & (1u << 8));
+ int has_avx512f = !!(b & (1u << 16));
+ int has_avx512dq = !!(b & (1u << 17));
+ int has_avx512cd = !!(b & (1u << 28));
+ int has_avx512bw = !!(b & (1u << 30));
+ int has_avx512vl = !!(b & (1u << 31));
+ int has_gfni = !!(c & (1u << 8));
+
+ if (has_bmi1) {
+ SET_FEAT(feats, GHC_X86_FEAT_BMI1);
+ }
+ if (has_bmi2) {
+ SET_FEAT(feats, GHC_X86_FEAT_BMI2);
+ }
+ if (avx_usable && has_avx2_hw) {
+ SET_FEAT(feats, GHC_X86_FEAT_AVX2);
+ }
+
+ if (avx512_usable && has_avx512f) {
+ SET_FEAT(feats, GHC_X86_FEAT_AVX512F);
+ if (has_avx512bw) {
+ SET_FEAT(feats, GHC_X86_FEAT_AVX512BW);
+ }
+ if (has_avx512cd) {
+ SET_FEAT(feats, GHC_X86_FEAT_AVX512CD);
+ }
+ if (has_avx512dq) {
+ SET_FEAT(feats, GHC_X86_FEAT_AVX512DQ);
+ }
+ if (has_avx512vl) {
+ SET_FEAT(feats, GHC_X86_FEAT_AVX512VL);
+ }
+ }
+
+ if (has_gfni) {
+ SET_FEAT(feats, GHC_X86_FEAT_GFNI);
+ }
+ }
+ }
+#endif
+
+ return feats;
+}
=====================================
compiler/ghc.cabal.in
=====================================
@@ -187,6 +187,7 @@ Library
else
c-sources:
cbits/cutils.c
+ cbits/cpu_features_x86.c
cbits/genSym.c
cbits/keepCAFsForGHCi.c
@@ -514,6 +515,7 @@ Library
GHC.Driver.Config.StgToCmm
GHC.Driver.Config.Tidy
GHC.Driver.Config.StgToJS
+ GHC.Driver.CpuFeatures
GHC.Driver.DynFlags
GHC.Driver.IncludeSpecs
GHC.Driver.Downsweep
=====================================
docs/users_guide/expected-undocumented-flags.txt
=====================================
@@ -75,6 +75,7 @@
-instantiated-with
-keep-hi-file
-keep-o-file
+-march=native
-n
-no-keep-hi-file
-no-keep-o-file
=====================================
docs/users_guide/using.rst
=====================================
@@ -496,7 +496,9 @@ The available mode flags are:
Print a JSON object describing the CPU features currently enabled for code
generation, together with a set of ``-m...`` flags that reproduce the
effective feature set for the current target.
- Dynamic options such as ``-mavx2`` and ``-mbmi2`` are respected.
+ Dynamic options such as ``-mavx2`` and ``-mbmi2`` are respected, so this flag
+ can also be used to inspect which features :ghc-flag:`-march=native` detected
+ and enabled.
.. ghc-flag:: --print-debug-on
:shortdesc: print whether GHC was built with ``-DDEBUG``
@@ -1854,6 +1856,34 @@ Some flags only make sense for particular target platforms.
so this flag has no effect when used with the :ref:`native code generator <native-code-gen>`
or the :ref:`LLVM backend <llvm-code-gen>`.
+.. ghc-flag:: -march=native
+ :shortdesc: (x86 only) Enable all CPU features supported by the host
+ :type: dynamic
+ :category: platform-options
+
+ (x86/x86_64 only) Probe the CPU of the machine running GHC and enable all of
+ the corresponding ``-m...`` CPU-feature options automatically (for example
+ ``-msse4.2``, ``-mavx2``, ``-mbmi2``, ``-mfma``). The detected features apply
+ to both the :ref:`native code generator <native-code-gen>` and the
+ :ref:`LLVM backend <llvm-code-gen>`.
+
+ The detected features are enabled *in addition* to any CPU-feature flags you
+ pass explicitly, regardless of their order on the command line; ``-march=native``
+ never disables a feature.
+
+ The features that were detected and enabled can be inspected with
+ :ghc-flag:`--print-enabled-cpu-features`.
+
+ .. warning::
+
+ Code compiled with ``-march=native`` may use instructions that are not
+ available on other CPUs, and is therefore not portable to a different
+ machine.
+
+ Only x86 and x86_64 targets are supported so far; the flag is rejected on
+ other targets. It is also rejected when cross-compiling, since the host CPU
+ is then unrelated to the target.
+
Haddock
-------
=====================================
testsuite/tests/codeGen/should_gen_asm/all.T
=====================================
@@ -17,6 +17,11 @@ test('msse-option-order', [unless(arch('x86_64') or arch('i386'), skip),
when(unregisterised(), skip)], compile_grep_asm, ['hs', False, '-msse4.2 -msse2'])
test('mavx-should-enable-popcnt', [unless(arch('x86_64') or arch('i386'), skip),
when(unregisterised(), skip)], compile_grep_asm, ['hs', False, '-mavx'])
+# -march=native probes the host CPU, so gate on the host actually having SSE4.2
+# (have_cpu_feature reports nothing under cross, skipping the test there too).
+test('march-native-enables-popcnt',
+ [unless((arch('x86_64') or arch('i386')) and have_cpu_feature('sse4_2'), skip),
+ when(unregisterised(), skip)], compile_grep_asm, ['hs', False, '-march=native'])
test('avx512-int64-mul', [unless(arch('x86_64'), skip),
when(unregisterised(), skip)], compile_grep_asm, ['hs', True, '-mavx512dq -mavx512vl'])
test('avx512-int64-minmax', [unless(arch('x86_64'), skip),
=====================================
testsuite/tests/codeGen/should_gen_asm/march-native-enables-popcnt.asm
=====================================
@@ -0,0 +1 @@
+popcnt(?![0-9])
\ No newline at end of file
=====================================
testsuite/tests/codeGen/should_gen_asm/march-native-enables-popcnt.hs
=====================================
@@ -0,0 +1,11 @@
+-- `-march=native` enables the host's CPU features. On a host with SSE4.2
+-- (gated in all.T via have_cpu_feature) this makes popCount compile to a
+-- `popcnt` instruction rather than the SSE2-baseline software fallback.
+import Data.Bits
+
+{-# NOINLINE foo #-}
+foo :: Int -> Int
+foo x = 1 + popCount x
+
+main :: IO ()
+main = print (foo 42)
=====================================
testsuite/tests/driver/all.T
=====================================
@@ -7,6 +7,12 @@ def normalise_unknown_flag(msg):
m = re.search(r'unrecognised flag: \S+', msg)
return m.group(0) + '\n' if m else msg
+def normalise_march_native_error(msg):
+ # Keep only the stable '-march=native ...' diagnostic; the program-name
+ # prefix and any usage trailer vary across configurations.
+ m = re.search(r'-march=native is [^\n]+', msg)
+ return m.group(0) + '\n' if m else msg
+
test('driver011', [extra_files(['A011.hs'])], makefile_test, ['test011'])
test('driver012', [extra_files(['A012.hs'])], makefile_test, ['test012'])
@@ -265,6 +271,45 @@ test('print_enabled_cpu_features_unknown_flag',
run_command,
['{compiler} -mavx22 --print-enabled-cpu-features'])
+# -march=native enables at least the x86_64 baseline (SSE2). The full feature
+# set is host-dependent, so we only assert the always-present baseline.
+test('march_native',
+ [unless(arch('x86_64') or arch('i386'), skip)],
+ run_command,
+ ['{compiler} -march=native --print-enabled-cpu-features | grep -o SSE2'])
+
+# On non-x86 targets -march=native must be rejected.
+test('march_native_unsupported_arch',
+ [when(arch('x86_64') or arch('i386'), skip),
+ normalise_errmsg_fun(normalise_march_native_error), exit_code(1)],
+ run_command,
+ ['{compiler} -march=native --print-enabled-cpu-features'])
+
+# -march=native is additive: its feature set is a superset of the default set.
+# We extract the "features" arrays with and without the flag and assert that no
+# baseline feature is dropped: 'grep -vxF -f native.txt base.txt' prints any
+# baseline feature absent from the -march=native set, of which we expect none.
+# (grep exits 1 when it prints nothing, so '|| true' keeps the success case from
+# failing the test; the empty-stdout check is what enforces the assertion.)
+# This avoids hard-coding the host-specific feature set.
+test('march_native_superset',
+ [unless(arch('x86_64') or arch('i386'), skip)],
+ run_command,
+ ['{compiler} --print-enabled-cpu-features | '
+ 'sed \'s/.*"features":\\[//;s/].*//;s/"//g\' | tr \',\' \'\\n\' > base.txt && '
+ '{compiler} -march=native --print-enabled-cpu-features | '
+ 'sed \'s/.*"features":\\[//;s/].*//;s/"//g\' | tr \',\' \'\\n\' > native.txt && '
+ '(grep -vxF -f native.txt base.txt || true)'])
+
+# -march=native is additive with explicit -m flags, regardless of order: an
+# explicitly requested feature (here AVX2, forced on independent of the host) is
+# still present whether the flag comes before or after -march=native.
+test('march_native_additive',
+ [unless(arch('x86_64') or arch('i386'), skip)],
+ run_command,
+ ['{compiler} -mavx2 -march=native --print-enabled-cpu-features | grep -o AVX2 && '
+ '{compiler} -march=native -mavx2 --print-enabled-cpu-features | grep -o AVX2'])
+
test('T10219', normal, run_command,
# `-x hspp` in make mode should work.
# Note: need to specify `-x hspp` before the filename.
=====================================
testsuite/tests/driver/march_native.stdout
=====================================
@@ -0,0 +1 @@
+SSE2
=====================================
testsuite/tests/driver/march_native_additive.stdout
=====================================
@@ -0,0 +1,2 @@
+AVX2
+AVX2
=====================================
testsuite/tests/driver/march_native_unsupported_arch.stderr
=====================================
@@ -0,0 +1 @@
+-march=native is only supported on x86 and x86_64 targets
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/12b5f01f8e7b3aebe2393c60fd09ec4…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/12b5f01f8e7b3aebe2393c60fd09ec4…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
Teo Camarasu pushed to branch wip/abstract-q at Glasgow Haskell Compiler / GHC
Commits:
dd433ad0 by Teo Camarasu at 2026-06-09T11:29:43+01:00
Make Q abstract
This patch aims to clearly demarcate the internal and external interfaces
of Q.
In the past the `Quasi` typeclass was both part of the external,
public-facing interface, and was used to give the implementation of `Q`.
Now we separate out these two distinct roles. `Quasi` continues to exist
in the public interface, but we introduce a new `MetaHandlers` type,
which is equivalent to `Dict Quasi`.
`Q a` is now defined to be `MetaHandlers IO -> IO a`, and, crucially,
the constructor and the new `MetaHandlers` type are not exposed from the
public interface.
This gives us the ability to vary the interface on the GHC side without
forcing a breaking change on the `template-haskell` side.
Similarly `template-haskell` has more freedom to change the `Quasi`
typeclass without needing any changes in `lib:ghc`.
Implements https://github.com/ghc-proposals/ghc-proposals/pull/70
Resolves #27341
- - - - -
9 changed files:
- + changelog.d/AbstractQ
- compiler/GHC/Data/IOEnv.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/Tc/Gen/Splice.hs-boot
- libraries/ghc-internal/src/GHC/Internal/TH/Lib.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs
- libraries/ghci/GHCi/TH.hs
- libraries/template-haskell/Language/Haskell/TH/Syntax.hs
- testsuite/tests/interface-stability/template-haskell-exports.stdout
Changes:
=====================================
changelog.d/AbstractQ
=====================================
@@ -0,0 +1,7 @@
+section: template-haskell
+synopsis: Hide the implementation of Q
+description: The constructor of Q is now hidden.
+ This is done to improve the stability of ``template-haskell``.
+ To minimize breakage, we have added a new ``qRunQ`` operation to ``Quasi``.
+mrs: !15696
+issues: #27341
=====================================
compiler/GHC/Data/IOEnv.hs
=====================================
@@ -29,7 +29,7 @@ module GHC.Data.IOEnv (
-- I/O operations
IORef, newMutVar, readMutVar, writeMutVar, updMutVar,
- atomicUpdMutVar, atomicUpdMutVar'
+ atomicUpdMutVar, atomicUpdMutVar', unliftIOEnv
) where
import GHC.Prelude
@@ -258,3 +258,11 @@ updEnv upd (IOEnv m) = IOEnv (\ env -> m (upd env))
updEnvIO :: (env -> IO env') -> IOEnv env' a -> IOEnv env a
{-# INLINE updEnvIO #-}
updEnvIO upd (IOEnv m) = IOEnv (\ env -> m =<< upd env)
+
+-- | Provide a continuation with a function that allows unlifting 'IOEnv' computations into 'IO'.
+unliftIOEnv :: forall env b. ((forall a. IOEnv env a -> IO a) -> IO b) -> IOEnv env b
+unliftIOEnv k = IOEnv $ \env ->
+ let
+ unlift :: forall a. IOEnv env a -> IO a
+ unlift (IOEnv m) = m env
+ in k unlift
=====================================
compiler/GHC/Tc/Gen/Splice.hs
=====================================
@@ -25,7 +25,7 @@ module GHC.Tc.Gen.Splice(
tcTypedSplice, tcTypedBracket, tcUntypedBracket,
runAnnotation, getUntypedSpliceBody,
- runMetaE, runMetaP, runMetaT, runMetaD, runQuasi,
+ runMetaE, runMetaP, runMetaT, runMetaD, runQinTcM,
tcTopSpliceExpr, lookupThName_maybe,
defaultRunMeta, runMeta', runRemoteModFinalizers,
finishTH, runTopSplice
@@ -138,6 +138,7 @@ import qualified GHC.LanguageExtensions as LangExt
-- THSyntax gives access to internal functions and data types
import qualified GHC.Boot.TH.Syntax as TH
import qualified GHC.Boot.TH.Monad as TH
+import GHC.Boot.TH.Monad (MetaHandlers(..))
import qualified GHC.Boot.TH.Ppr as TH
#if defined(HAVE_INTERNAL_INTERPRETER)
@@ -1138,8 +1139,8 @@ convertAnnotationWrapper fhv = do
************************************************************************
-}
-runQuasi :: TH.Q a -> TcM a
-runQuasi act = TH.runQ act
+runQinTcM :: TH.Q a -> TcM a
+runQinTcM (TH.Q act) = unliftIOEnv $ \runInIO -> liftIO $ act (metaHandlersTcM runInIO)
runRemoteModFinalizers :: ThModFinalizers -> TcM ()
runRemoteModFinalizers (ThModFinalizers finRefs) = do
@@ -1152,7 +1153,7 @@ runRemoteModFinalizers (ThModFinalizers finRefs) = do
#if defined(HAVE_INTERNAL_INTERPRETER)
InternalInterp -> do
qs <- liftIO (withForeignRefs finRefs $ mapM localRef)
- runQuasi $ sequence_ qs
+ runQinTcM $ sequence_ qs
#endif
ExternalInterp ext -> withExtInterp ext $ \inst -> do
@@ -1466,70 +1467,14 @@ when showing an error message.
To call runQ in the Tc monad, we need to make TcM an instance of Quasi:
-}
-instance TH.Quasi TcM where
- qNewName s = do { u <- newUnique
- ; let i = toInteger (getKey u)
- ; return (TH.mkNameU s i) }
+-- 'msg' is forced to ensure exceptions don't escape,
+-- see Note [Exceptions in TH]
+report :: Bool -> [Char] -> TcM ()
+report True msg = seqList msg $ addErr $ TcRnTHError $ ReportCustomQuasiError True msg
+report False msg = seqList msg $ addDiagnostic $ TcRnTHError $ ReportCustomQuasiError False msg
- -- 'msg' is forced to ensure exceptions don't escape,
- -- see Note [Exceptions in TH]
- qReport True msg = seqList msg $ addErr $ TcRnTHError $ ReportCustomQuasiError True msg
- qReport False msg = seqList msg $ addDiagnostic $ TcRnTHError $ ReportCustomQuasiError False msg
-
- qLocation :: TcM TH.Loc
- qLocation = do { m <- getModule
- ; l <- getSrcSpanM
- ; r <- case l of
- RealSrcSpan s _ -> return s
- GeneratedSrcSpan{} -> pprPanic "qLocation: generatedSrcSpan"
- (pprGeneratedSrcSpanDetails)
- UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location"
- (ppr l)
- ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile r)
- , TH.loc_module = moduleNameString (moduleName m)
- , TH.loc_package = unitString (moduleUnit m)
- , TH.loc_start = (srcSpanStartLine r, srcSpanStartCol r)
- , TH.loc_end = (srcSpanEndLine r, srcSpanEndCol r) }) }
-
- qLookupName = lookupName
- qReify = reify
- qReifyFixity nm = lookupThName nm >>= reifyFixity
- qReifyType = reifyTypeOfThing
- qReifyInstances = reifyInstances
- qReifyRoles = reifyRoles
- qReifyAnnotations = reifyAnnotations
- qReifyModule = reifyModule
- qReifyConStrictness nm = do { nm' <- lookupThName nm
- ; dc <- tcLookupDataCon nm'
- ; let bangs = dataConImplBangs dc
- ; return (map reifyDecidedStrictness bangs) }
-
- -- For qRecover, discard error messages if
- -- the recovery action is chosen. Otherwise
- -- we'll only fail higher up.
- qRecover recover main = tryTcDiscardingErrs recover main
-
- qGetPackageRoot = do
- dflags <- getDynFlags
- return $ fromMaybe "." (workingDirectory dflags)
-
- qAddDependentFile fp = do
- ref <- fmap tcg_dependent_files getGblEnv
- dep_files <- readTcRef ref
- writeTcRef ref (fp:dep_files)
-
- qAddDependentDirectory dp = do
- ref <- fmap tcg_dependent_dirs getGblEnv
- dep_dirs <- readTcRef ref
- writeTcRef ref (dp:dep_dirs)
-
- qAddTempFile suffix = do
- dflags <- getDynFlags
- logger <- getLogger
- tmpfs <- hsc_tmpfs <$> getTopEnv
- liftIO $ newTempName logger tmpfs (tmpDir dflags) TFL_GhcSession suffix
-
- qAddTopDecls thds = do
+addTopDecls :: [TH.Dec] -> TcM ()
+addTopDecls thds = do
exts <- fmap extensionFlags getDynFlags
l <- getSrcSpanM
th_origin <- getThSpliceOrigin
@@ -1557,52 +1502,13 @@ instance TH.Quasi TcM where
bindName :: RdrName -> TcM ()
bindName (Exact n)
= do { th_topnames_var <- fmap tcg_th_topnames getGblEnv
- ; updTcRef th_topnames_var (\ns -> extendNameSet ns n)
- }
+ ; updTcRef th_topnames_var (\ns -> extendNameSet ns n)
+ }
bindName name = addErr $ TcRnTHError $ THNameError $ NonExactName name
- qAddForeignFilePath lang fp = do
- var <- fmap tcg_th_foreign_files getGblEnv
- updTcRef var ((lang, fp) :)
-
- qAddModFinalizer fin = do
- r <- liftIO $ mkRemoteRef fin
- fref <- liftIO $ mkForeignRef r (freeRemoteRef r)
- addModFinalizerRef fref
-
- qAddCorePlugin plugin = do
- hsc_env <- getTopEnv
- let fc = hsc_FC hsc_env
- let home_unit = hsc_home_unit hsc_env
- let dflags = hsc_dflags hsc_env
- let fopts = initFinderOpts dflags
- r <- liftIO $ findHomeModule fc fopts home_unit (mkModuleName plugin)
- let err = TcRnTHError $ AddInvalidCorePlugin plugin
- case r of
- Found {} -> addErr err
- FoundMultiple {} -> addErr err
- _ -> return ()
- th_coreplugins_var <- tcg_th_coreplugins <$> getGblEnv
- updTcRef th_coreplugins_var (plugin:)
-
- qGetQ :: forall a. Typeable a => TcM (Maybe a)
- qGetQ = do
- th_state_var <- fmap tcg_th_state getGblEnv
- th_state <- readTcRef th_state_var
- -- See #10596 for why we use a scoped type variable here.
- return (Map.lookup (typeRep (Proxy :: Proxy a)) th_state >>= fromDynamic)
-
- qPutQ x = do
- th_state_var <- fmap tcg_th_state getGblEnv
- updTcRef th_state_var (\m -> Map.insert (typeOf x) (toDyn x) m)
-
- qIsExtEnabled = xoptM
-
- qExtsEnabled =
- EnumSet.toList . extensionFlags . hsc_dflags <$> getTopEnv
-
- qPutDoc doc_loc s = do
+putDoc :: TH.DocLoc -> String -> TcM ()
+putDoc doc_loc s = do
th_doc_var <- tcg_th_docs <$> getGblEnv
resolved_doc_loc <- resolve_loc doc_loc
is_local <- checkLocalName resolved_doc_loc
@@ -1624,15 +1530,133 @@ instance TH.Quasi TcM where
checkLocalName (InstDoc n) = nameIsLocalOrFrom <$> getModule <*> pure n
checkLocalName ModuleDoc = pure True
-
- qGetDoc (TH.DeclDoc n) = lookupThName n >>= lookupDeclDoc
- qGetDoc (TH.InstDoc t) = lookupThInstName t >>= lookupDeclDoc
- qGetDoc (TH.ArgDoc n i) = lookupThName n >>= lookupArgDoc i
- qGetDoc TH.ModuleDoc = do
+getDoc :: TH.DocLoc -> TcM (Maybe String)
+getDoc (TH.DeclDoc n) = lookupThName n >>= lookupDeclDoc
+getDoc (TH.InstDoc t) = lookupThInstName t >>= lookupDeclDoc
+getDoc (TH.ArgDoc n i) = lookupThName n >>= lookupArgDoc i
+getDoc TH.ModuleDoc = do
df <- getDynFlags
docs <- getGblEnv >>= extractDocs df
return (renderHsDocString . hsDocString <$> (docs_mod_hdr =<< docs))
+getQ :: forall a. Typeable a => TcM (Maybe a)
+getQ = do
+ th_state_var <- fmap tcg_th_state getGblEnv
+ th_state <- readTcRef th_state_var
+ -- See #10596 for why we use a scoped type variable here.
+ return (Map.lookup (typeRep (Proxy :: Proxy a)) th_state >>= fromDynamic)
+
+location :: TcM TH.Loc
+location = do { m <- getModule
+ ; l <- getSrcSpanM
+ ; r <- case l of
+ RealSrcSpan s _ -> return s
+ GeneratedSrcSpan{} -> pprPanic "qLocation: generatedSrcSpan"
+ (pprGeneratedSrcSpanDetails)
+ UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location"
+ (ppr l)
+ ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile r)
+ , TH.loc_module = moduleNameString (moduleName m)
+ , TH.loc_package = unitString (moduleUnit m)
+ , TH.loc_start = (srcSpanStartLine r, srcSpanStartCol r)
+ , TH.loc_end = (srcSpanEndLine r, srcSpanEndCol r) }) }
+
+metaHandlersTcM :: (forall x. TcM x -> IO x) -> TH.MetaHandlers IO
+metaHandlersTcM runInIO = TH.MetaHandlers {
+ mLiftIO = id
+ -- We are careful to use the TcM instance not the one for IO, since that would lead to a different error.
+ , mFail = \s -> runInIO $ fail @TcM s
+ , mNewName = \s -> runInIO $ do { u <- newUnique
+ ; let i = toInteger (getKey u)
+ ; return (TH.mkNameU s i) }
+
+ , mReport = fmap runInIO . report
+
+ , mLocation = runInIO location
+
+ , mLookupName = fmap runInIO . lookupName
+ , mReify = runInIO . reify
+ , mReifyFixity = \nm -> runInIO $ lookupThName nm >>= reifyFixity
+ , mReifyType = runInIO . reifyTypeOfThing
+ , mReifyInstances = fmap runInIO . reifyInstances
+ , mReifyRoles = runInIO . reifyRoles
+ , mReifyAnnotations = runInIO . reifyAnnotations
+ , mReifyModule = runInIO . reifyModule
+ , mReifyConStrictness = \nm -> runInIO $ do
+ { nm' <- lookupThName nm
+ ; dc <- tcLookupDataCon nm'
+ ; let bangs = dataConImplBangs dc
+ ; return (map reifyDecidedStrictness bangs) }
+
+ -- For qRecover, discard error messages if
+ -- the recovery action is chosen. Otherwise
+ -- we'll only fail higher up.
+ -- NB: extremely subtle!!! TODO: write up note
+ -- tryTcDiscardingErrs manipulates the reader env so we need to be careful we don't sneak in the outside env
+ , mRecover = \recover main -> runInIO $ tryTcDiscardingErrs (runQinTcM recover) (runQinTcM main)
+
+ , mGetPackageRoot = runInIO $ do
+ dflags <- getDynFlags
+ return $ fromMaybe "." (workingDirectory dflags)
+
+ , mAddDependentFile = \fp -> runInIO $ do
+ ref <- fmap tcg_dependent_files getGblEnv
+ dep_files <- readTcRef ref
+ writeTcRef ref (fp:dep_files)
+
+ , mAddDependentDirectory = \dp -> runInIO $ do
+ ref <- fmap tcg_dependent_dirs getGblEnv
+ dep_dirs <- readTcRef ref
+ writeTcRef ref (dp:dep_dirs)
+
+ , mAddTempFile = \suffix -> runInIO $ do
+ dflags <- getDynFlags
+ logger <- getLogger
+ tmpfs <- hsc_tmpfs <$> getTopEnv
+ liftIO $ newTempName logger tmpfs (tmpDir dflags) TFL_GhcSession suffix
+
+ , mAddTopDecls = runInIO . addTopDecls
+
+ , mAddForeignFilePath = \lang fp -> runInIO $ do
+ var <- fmap tcg_th_foreign_files getGblEnv
+ updTcRef var ((lang, fp) :)
+
+ , mAddModFinalizer = \fin -> runInIO $ do
+ r <- liftIO $ mkRemoteRef fin
+ fref <- liftIO $ mkForeignRef r (freeRemoteRef r)
+ addModFinalizerRef fref
+
+ , mAddCorePlugin = \plugin -> runInIO $ do
+ hsc_env <- getTopEnv
+ let fc = hsc_FC hsc_env
+ let home_unit = hsc_home_unit hsc_env
+ let dflags = hsc_dflags hsc_env
+ let fopts = initFinderOpts dflags
+ r <- liftIO $ findHomeModule fc fopts home_unit (mkModuleName plugin)
+ let err = TcRnTHError $ AddInvalidCorePlugin plugin
+ case r of
+ Found {} -> addErr err
+ FoundMultiple {} -> addErr err
+ _ -> return ()
+ th_coreplugins_var <- tcg_th_coreplugins <$> getGblEnv
+ updTcRef th_coreplugins_var (plugin:)
+
+ , mGetQ = runInIO getQ
+
+ , mPutQ = \x -> runInIO $ do
+ th_state_var <- fmap tcg_th_state getGblEnv
+ updTcRef th_state_var (\m -> Map.insert (typeOf x) (toDyn x) m)
+
+ , mIsExtEnabled = runInIO . xoptM
+
+ , mExtsEnabled = runInIO $
+ EnumSet.toList . extensionFlags . hsc_dflags <$> getTopEnv
+
+ , mPutDoc = fmap runInIO . putDoc
+
+ , mGetDoc = runInIO . getDoc
+ }
+
-- | Looks up documentation for a declaration in first the current module,
-- otherwise tries to find it in another module via 'hscGetModuleInterface'.
lookupDeclDoc :: Name -> TcM (Maybe String)
@@ -1788,7 +1812,7 @@ runTH ty fhv = do
InternalInterp -> do
-- Run it in the local TcM
hv <- liftIO $ wormhole interp fhv
- r <- runQuasi (unsafeCoerce hv :: TH.Q a)
+ r <- runQinTcM (unsafeCoerce hv :: TH.Q a)
return r
#endif
@@ -1797,7 +1821,7 @@ runTH ty fhv = do
-- Remote GHCi, see Note [Remote Template Haskell] in
-- libraries/ghci/GHCi/TH.hs.
rstate <- getTHState inst
- loc <- TH.qLocation
+ loc <- location
-- run a remote TH request
r <- liftIO $
withForeignRef rstate $ \state_hv ->
@@ -1913,32 +1937,32 @@ wrapTHResult tcm = do
handleTHMessage :: THMessage a -> TcM a
handleTHMessage msg = case msg of
- NewName a -> wrapTHResult $ TH.qNewName a
- Report b str -> wrapTHResult $ TH.qReport b str
- LookupName b str -> wrapTHResult $ TH.qLookupName b str
- Reify n -> wrapTHResult $ TH.qReify n
- ReifyFixity n -> wrapTHResult $ TH.qReifyFixity n
- ReifyType n -> wrapTHResult $ TH.qReifyType n
- ReifyInstances n ts -> wrapTHResult $ TH.qReifyInstances n ts
- ReifyRoles n -> wrapTHResult $ TH.qReifyRoles n
+ NewName a -> wrapTHResult $ runQinTcM $ TH.newName a
+ Report b str -> wrapTHResult $ runQinTcM $ TH.report b str
+ LookupName b str -> wrapTHResult $ runQinTcM $ TH.lookupName b str
+ Reify n -> wrapTHResult $ runQinTcM $ TH.reify n
+ ReifyFixity n -> wrapTHResult $ runQinTcM $ TH.reifyFixity n
+ ReifyType n -> wrapTHResult $ runQinTcM $ TH.reifyType n
+ ReifyInstances n ts -> wrapTHResult $ runQinTcM $ TH.reifyInstances n ts
+ ReifyRoles n -> wrapTHResult $ runQinTcM $ TH.reifyRoles n
ReifyAnnotations lookup tyrep ->
wrapTHResult $ (map B.pack <$> getAnnotationsByTypeRep lookup tyrep)
- ReifyModule m -> wrapTHResult $ TH.qReifyModule m
- ReifyConStrictness nm -> wrapTHResult $ TH.qReifyConStrictness nm
- GetPackageRoot -> wrapTHResult $ TH.qGetPackageRoot
- AddDependentFile f -> wrapTHResult $ TH.qAddDependentFile f
- AddDependentDirectory d -> wrapTHResult $ TH.qAddDependentDirectory d
- AddTempFile s -> wrapTHResult $ TH.qAddTempFile s
+ ReifyModule m -> wrapTHResult $ runQinTcM $ TH.reifyModule m
+ ReifyConStrictness nm -> wrapTHResult $ runQinTcM $ TH.reifyConStrictness nm
+ GetPackageRoot -> wrapTHResult $ runQinTcM $ TH.getPackageRoot
+ AddDependentFile f -> wrapTHResult $ runQinTcM $ TH.addDependentFile f
+ AddDependentDirectory d -> wrapTHResult $ runQinTcM $ TH.addDependentDirectory d
+ AddTempFile s -> wrapTHResult $ runQinTcM $ TH.addTempFile s
AddModFinalizer r -> do
interp <- hscInterp <$> getTopEnv
wrapTHResult $ liftIO (mkFinalizedHValue interp r) >>= addModFinalizerRef
- AddCorePlugin str -> wrapTHResult $ TH.qAddCorePlugin str
- AddTopDecls decs -> wrapTHResult $ TH.qAddTopDecls decs
- AddForeignFilePath lang str -> wrapTHResult $ TH.qAddForeignFilePath lang str
- IsExtEnabled ext -> wrapTHResult $ TH.qIsExtEnabled ext
- ExtsEnabled -> wrapTHResult $ TH.qExtsEnabled
- PutDoc l s -> wrapTHResult $ TH.qPutDoc l s
- GetDoc l -> wrapTHResult $ TH.qGetDoc l
+ AddCorePlugin str -> wrapTHResult $ runQinTcM $ TH.addCorePlugin str
+ AddTopDecls decs -> wrapTHResult $ runQinTcM $ TH.addTopDecls decs
+ AddForeignFilePath lang str -> wrapTHResult $ runQinTcM $ TH.addForeignFilePath lang str
+ IsExtEnabled ext -> wrapTHResult $ runQinTcM $ TH.isExtEnabled ext
+ ExtsEnabled -> wrapTHResult $ runQinTcM $ TH.extsEnabled
+ PutDoc l s -> wrapTHResult $ runQinTcM $ TH.putDoc l s
+ GetDoc l -> wrapTHResult $ runQinTcM $ TH.getDoc l
FailIfErrs -> wrapTHResult failIfErrsM
_ -> panic ("handleTHMessage: unexpected message " ++ show msg)
=====================================
compiler/GHC/Tc/Gen/Splice.hs-boot
=====================================
@@ -42,6 +42,6 @@ runMetaT :: LHsExpr GhcTc -> TcM (LHsType GhcPs)
runMetaD :: LHsExpr GhcTc -> TcM [LHsDecl GhcPs]
lookupThName_maybe :: TH.Name -> TcM (Maybe Name)
-runQuasi :: TH.Q a -> TcM a
+runQinTcM :: TH.Q a -> TcM a
runRemoteModFinalizers :: ThModFinalizers -> TcM ()
finishTH :: TcM ()
=====================================
libraries/ghc-internal/src/GHC/Internal/TH/Lib.hs
=====================================
@@ -1079,7 +1079,7 @@ withDecDoc :: String -> Q Dec -> Q Dec
withDecDoc doc dec = do
dec' <- dec
case doc_loc dec' of
- Just loc -> qAddModFinalizer $ qPutDoc loc doc
+ Just loc -> addModFinalizer $ putDoc loc doc
Nothing -> pure ()
pure dec'
where
@@ -1128,7 +1128,7 @@ funD_doc :: Name -> [Q Clause]
-> [Maybe String] -- ^ Documentation to attach to arguments
-> Q Dec
funD_doc nm cs mfun_doc arg_docs = do
- qAddModFinalizer $ sequence_
+ addModFinalizer $ sequence_
[putDoc (ArgDoc nm i) s | (i, Just s) <- zip [0..] arg_docs]
let dec = funD nm cs
case mfun_doc of
@@ -1145,7 +1145,7 @@ dataD_doc :: Q Cxt -> Name -> [Q (TyVarBndr BndrVis)] -> Maybe (Q Kind)
-- ^ Documentation to attach to the data declaration
-> Q Dec
dataD_doc ctxt tc tvs ksig cons_with_docs derivs mdoc = do
- qAddModFinalizer $ mapM_ docCons cons_with_docs
+ addModFinalizer $ mapM_ docCons cons_with_docs
let dec = dataD ctxt tc tvs ksig (map (\(con, _, _) -> con) cons_with_docs) derivs
maybe dec (flip withDecDoc dec) mdoc
@@ -1159,7 +1159,7 @@ newtypeD_doc :: Q Cxt -> Name -> [Q (TyVarBndr BndrVis)] -> Maybe (Q Kind)
-- ^ Documentation to attach to the newtype declaration
-> Q Dec
newtypeD_doc ctxt tc tvs ksig con_with_docs@(con, _, _) derivs mdoc = do
- qAddModFinalizer $ docCons con_with_docs
+ addModFinalizer $ docCons con_with_docs
let dec = newtypeD ctxt tc tvs ksig con derivs
maybe dec (flip withDecDoc dec) mdoc
@@ -1172,7 +1172,7 @@ typeDataD_doc :: Name -> [Q (TyVarBndr BndrVis)] -> Maybe (Q Kind)
-- ^ Documentation to attach to the data declaration
-> Q Dec
typeDataD_doc tc tvs ksig cons_with_docs mdoc = do
- qAddModFinalizer $ mapM_ docCons cons_with_docs
+ addModFinalizer $ mapM_ docCons cons_with_docs
let dec = typeDataD tc tvs ksig (map (\(con, _, _) -> con) cons_with_docs)
maybe dec (flip withDecDoc dec) mdoc
@@ -1186,7 +1186,7 @@ dataInstD_doc :: Q Cxt -> (Maybe [Q (TyVarBndr ())]) -> Q Type -> Maybe (Q Kind)
-- ^ Documentation to attach to the instance declaration
-> Q Dec
dataInstD_doc ctxt mb_bndrs ty ksig cons_with_docs derivs mdoc = do
- qAddModFinalizer $ mapM_ docCons cons_with_docs
+ addModFinalizer $ mapM_ docCons cons_with_docs
let dec = dataInstD ctxt mb_bndrs ty ksig (map (\(con, _, _) -> con) cons_with_docs)
derivs
maybe dec (flip withDecDoc dec) mdoc
@@ -1202,7 +1202,7 @@ newtypeInstD_doc :: Q Cxt -> (Maybe [Q (TyVarBndr ())]) -> Q Type
-- ^ Documentation to attach to the instance declaration
-> Q Dec
newtypeInstD_doc ctxt mb_bndrs ty ksig con_with_docs@(con, _, _) derivs mdoc = do
- qAddModFinalizer $ docCons con_with_docs
+ addModFinalizer $ docCons con_with_docs
let dec = newtypeInstD ctxt mb_bndrs ty ksig con derivs
maybe dec (flip withDecDoc dec) mdoc
@@ -1212,7 +1212,7 @@ patSynD_doc :: Name -> Q PatSynArgs -> Q PatSynDir -> Q Pat
-> [Maybe String] -- ^ Documentation to attach to the pattern arguments
-> Q Dec
patSynD_doc name args dir pat mdoc arg_docs = do
- qAddModFinalizer $ sequence_
+ addModFinalizer $ sequence_
[putDoc (ArgDoc name i) s | (i, Just s) <- zip [0..] arg_docs]
let dec = patSynD name args dir pat
maybe dec (flip withDecDoc dec) mdoc
=====================================
libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs
=====================================
@@ -35,7 +35,7 @@ import GHC.Types (TYPE, RuntimeRep(..))
#else
import GHC.Internal.Base (
Applicative(..), Functor(..), Monad(..), Monoid(..), Semigroup(..), String,
- flip, id, (.), (++),
+ flip, id, (.), (++), ($),
)
import GHC.Internal.Classes (not)
import GHC.Internal.Data.Data hiding (Fixity(..))
@@ -59,145 +59,137 @@ import GHC.Internal.ForeignSrcLang
import GHC.Internal.LanguageExtensions
import GHC.Internal.TH.Syntax
------------------------------------------------------
---
--- The Quasi class
---
------------------------------------------------------
-
-class (MonadIO m, MonadFail m) => Quasi m where
- -- | Fresh names. See 'newName'.
- qNewName :: String -> m Name
-
- ------- Error reporting and recovery -------
- -- | Report an error (True) or warning (False)
- -- ...but carry on; use 'fail' to stop. See 'report'.
- qReport :: Bool -> String -> m ()
-
- -- | See 'recover'.
- qRecover :: m a -- ^ the error handler
- -> m a -- ^ action which may fail
- -> m a -- ^ Recover from the monadic 'fail'
-
- ------- Inspect the type-checker's environment -------
- -- | True <=> type namespace, False <=> value namespace. See 'lookupName'.
- qLookupName :: Bool -> String -> m (Maybe Name)
- -- | See 'reify'.
- qReify :: Name -> m Info
- -- | See 'reifyFixity'.
- qReifyFixity :: Name -> m (Maybe Fixity)
- -- | See 'reifyType'.
- qReifyType :: Name -> m Type
- -- | Is (n tys) an instance? Returns list of matching instance Decs (with
- -- empty sub-Decs) Works for classes and type functions. See 'reifyInstances'.
- qReifyInstances :: Name -> [Type] -> m [Dec]
- -- | See 'reifyRoles'.
- qReifyRoles :: Name -> m [Role]
- -- | See 'reifyAnnotations'.
- qReifyAnnotations :: Data a => AnnLookup -> m [a]
- -- | See 'reifyModule'.
- qReifyModule :: Module -> m ModuleInfo
- -- | See 'reifyConStrictness'.
- qReifyConStrictness :: Name -> m [DecidedStrictness]
-
- -- | See 'location'.
- qLocation :: m Loc
-
- -- | Input/output (dangerous). See 'runIO'.
- qRunIO :: IO a -> m a
- qRunIO = liftIO
- -- | See 'getPackageRoot'.
- qGetPackageRoot :: m FilePath
-
- -- | See 'addDependentFile'.
- qAddDependentFile :: FilePath -> m ()
-
- -- | See 'addDependentDirectory'.
- qAddDependentDirectory :: FilePath -> m ()
-
- -- | See 'addTempFile'.
- qAddTempFile :: String -> m FilePath
-
- -- | See 'addTopDecls'.
- qAddTopDecls :: [Dec] -> m ()
-
- -- | See 'addForeignFilePath'.
- qAddForeignFilePath :: ForeignSrcLang -> String -> m ()
-
- -- | See 'addModFinalizer'.
- qAddModFinalizer :: Q () -> m ()
-
- -- | See 'addCorePlugin'.
- qAddCorePlugin :: String -> m ()
-
- -- | See 'getQ'.
- qGetQ :: Typeable a => m (Maybe a)
-
- -- | See 'putQ'.
- qPutQ :: Typeable a => a -> m ()
-
- -- | See 'isExtEnabled'.
- qIsExtEnabled :: Extension -> m Bool
- -- | See 'extsEnabled'.
- qExtsEnabled :: m [Extension]
-
- -- | See 'putDoc'.
- qPutDoc :: DocLoc -> String -> m ()
- -- | See 'getDoc'.
- qGetDoc :: DocLoc -> m (Maybe String)
+data MetaHandlers m = MetaHandlers {
+ mLiftIO :: forall a. IO a -> m a
+ , mFail :: forall a. String -> m a
+ -- | Fresh names. See 'newName'.
+ , mNewName :: String -> m Name
+
+ ------- Error reporting and recovery -------
+ -- | Report an error (True) or warning (False)
+ -- ...but carry on; use 'fail' to stop. See 'report'.
+ , mReport :: Bool -> String -> m ()
+
+ -- | See 'recover'.
+ , mRecover :: forall a. Q a -- ^ the error handler
+ -> Q a -- ^ action which may fail
+ -> m a -- ^ Recover from the monadic 'fail'
+
+ ------- Inspect the type-checker's environment -------
+ -- | True <=> type namespace, False <=> value namespace. See 'lookupName'.
+ , mLookupName :: Bool -> String -> m (Maybe Name)
+ -- | See 'reify'.
+ , mReify :: Name -> m Info
+ -- | See 'reifyFixity'.
+ , mReifyFixity :: Name -> m (Maybe Fixity)
+ -- | See 'reifyType'.
+ , mReifyType :: Name -> m Type
+ -- | Is (n tys) an instance? Returns list of matching instance Decs (with
+ -- empty sub-Decs) Works for classes and type functions. See 'reifyInstances'.
+ , mReifyInstances :: Name -> [Type] -> m [Dec]
+ -- | See 'reifyRoles'.
+ , mReifyRoles :: Name -> m [Role]
+ -- | See 'reifyAnnotations'.
+ , mReifyAnnotations :: forall a. Data a => AnnLookup -> m [a]
+ -- | See 'reifyModule'.
+ , mReifyModule :: Module -> m ModuleInfo
+ -- | See 'reifyConStrictness'.
+ , mReifyConStrictness :: Name -> m [DecidedStrictness]
+
+ -- | See 'location'.
+ , mLocation :: m Loc
+
+ -- | See 'getPackageRoot'.
+ , mGetPackageRoot :: m FilePath
+
+ -- | See 'addDependentFile'.
+ , mAddDependentFile :: FilePath -> m ()
+
+ -- | See 'addDependentDirectory'.
+ , mAddDependentDirectory :: FilePath -> m ()
+
+ -- | See 'addTempFile'.
+ , mAddTempFile :: String -> m FilePath
+
+ -- | See 'addTopDecls'.
+ , mAddTopDecls :: [Dec] -> m ()
+
+ -- | See 'addForeignFilePath'.
+ , mAddForeignFilePath :: ForeignSrcLang -> String -> m ()
+
+ -- | See 'addModFinalizer'.
+ , mAddModFinalizer :: Q () -> m ()
+
+ -- | See 'addCorePlugin'.
+ , mAddCorePlugin :: String -> m ()
+
+ -- | See 'getQ'.
+ , mGetQ :: forall a. Typeable a => m (Maybe a)
+
+ -- | See 'putQ'.
+ , mPutQ :: forall a. Typeable a => a -> m ()
+
+ -- | See 'isExtEnabled'.
+ , mIsExtEnabled :: Extension -> m Bool
+ -- | See 'extsEnabled'.
+ , mExtsEnabled :: m [Extension]
+
+ -- | See 'putDoc'.
+ , mPutDoc :: DocLoc -> String -> m ()
+ -- | See 'getDoc'.
+ , mGetDoc :: DocLoc -> m (Maybe String)
+ }
------------------------------------------------------
--- The IO instance of Quasi
------------------------------------------------------
+badIO :: String -> IO a
+badIO op = do { hPutStrLn stderr ("Can't do `" ++ op ++ "' in the IO monad")
+ ; fail "Template Haskell failure" }
--- | This instance is used only when running a Q
--- computation in the IO monad, usually just to
--- print the result. There is no interesting
--- type environment, so reification isn't going to
--- work.
-instance Quasi IO where
- qNewName = newNameIO
-
- qReport True msg = hPutStrLn stderr ("Template Haskell error: " ++ msg)
- qReport False msg = hPutStrLn stderr ("Template Haskell error: " ++ msg)
-
- qLookupName _ _ = badIO "lookupName"
- qReify _ = badIO "reify"
- qReifyFixity _ = badIO "reifyFixity"
- qReifyType _ = badIO "reifyFixity"
- qReifyInstances _ _ = badIO "reifyInstances"
- qReifyRoles _ = badIO "reifyRoles"
- qReifyAnnotations _ = badIO "reifyAnnotations"
- qReifyModule _ = badIO "reifyModule"
- qReifyConStrictness _ = badIO "reifyConStrictness"
- qLocation = badIO "currentLocation"
- qRecover _ _ = badIO "recover" -- Maybe we could fix this?
- qGetPackageRoot = badIO "getProjectRoot"
- qAddDependentFile _ = badIO "addDependentFile"
- qAddTempFile _ = badIO "addTempFile"
- qAddTopDecls _ = badIO "addTopDecls"
- qAddForeignFilePath _ _ = badIO "addForeignFilePath"
- qAddModFinalizer _ = badIO "addModFinalizer"
- qAddCorePlugin _ = badIO "addCorePlugin"
- qGetQ = badIO "getQ"
- qPutQ _ = badIO "putQ"
- qIsExtEnabled _ = badIO "isExtEnabled"
- qExtsEnabled = badIO "extsEnabled"
- qPutDoc _ _ = badIO "putDoc"
- qGetDoc _ = badIO "getDoc"
- qAddDependentDirectory _ = badIO "AddDependentDirectory"
+metaHandlersIO :: MetaHandlers IO
+metaHandlersIO = MetaHandlers {
+ mLiftIO = id
+ , mFail = fail
+ , mNewName = newNameIO
+ , mReport = \b msg ->
+ if b then
+ hPutStrLn stderr ("Template Haskell error: " ++ msg)
+ else
+ hPutStrLn stderr ("Template Haskell error: " ++ msg) -- TODO: should this be different from above?
+ , mLookupName = \ _ _ -> badIO "lookupName"
+ , mReify = \_ -> badIO "reify"
+ , mReifyFixity = \_ -> badIO "reifyFixity"
+ , mReifyType = \_ -> badIO "reifyFixity"
+ , mReifyInstances = \_ _ -> badIO "reifyInstances"
+ , mReifyRoles = \_ -> badIO "reifyRoles"
+ , mReifyAnnotations = \_ -> badIO "reifyAnnotations"
+ , mReifyModule = \_ -> badIO "reifyModule"
+ , mReifyConStrictness = \_ -> badIO "reifyConStrictness"
+ , mLocation = badIO "currentLocation"
+ , mRecover = \_ _ -> badIO "recover" -- Maybe we could fix this?
+ , mGetPackageRoot = badIO "getProjectRoot"
+ , mAddDependentFile = \_ -> badIO "addDependentFile"
+ , mAddTempFile = \_ -> badIO "addTempFile"
+ , mAddTopDecls = \_ -> badIO "addTopDecls"
+ , mAddForeignFilePath = \_ _ -> badIO "addForeignFilePath"
+ , mAddModFinalizer = \_ -> badIO "addModFinalizer"
+ , mAddCorePlugin = \_ -> badIO "addCorePlugin"
+ , mGetQ = badIO "getQ"
+ , mPutQ = \_ -> badIO "putQ"
+ , mIsExtEnabled = \_ -> badIO "isExtEnabled"
+ , mExtsEnabled = badIO "extsEnabled"
+ , mPutDoc = \_ _ -> badIO "putDoc"
+ , mGetDoc = \_ -> badIO "getDoc"
+ , mAddDependentDirectory = \_ -> badIO "AddDependentDirectory"
+ }
instance Quote IO where
newName = newNameIO
+
+
newNameIO :: String -> IO Name
newNameIO s = do { n <- atomicModifyIORef' counter (\x -> (x + 1, x))
; pure (mkNameU s n) }
-badIO :: String -> IO a
-badIO op = do { qReport True ("Can't do `" ++ op ++ "' in the IO monad")
- ; fail "Template Haskell failure" }
-
-- Global variable to generate unique symbols
counter :: IORef Uniq
{-# NOINLINE counter #-}
@@ -220,36 +212,22 @@ counter = unsafePerformIO (newIORef 0)
-- inversion](https://en.wikipedia.org/wiki/Dependency_inversion_principle),
-- providing an abstract interface for the user which is later concretely
-- fufilled by an concrete 'Quasi' instance, internal to GHC.
-newtype Q a = Q { unQ :: forall m. Quasi m => m a }
-
--- | \"Runs\" the 'Q' monad. Normal users of Template Haskell
--- should not need this function, as the splice brackets @$( ... )@
--- are the usual way of running a 'Q' computation.
---
--- This function is primarily used in GHC internals, and for debugging
--- splices by running them in 'IO'.
---
--- Note that many functions in 'Q', such as 'reify' and other compiler
--- queries, are not supported when running 'Q' in 'IO'; these operations
--- simply fail at runtime. Indeed, the only operations guaranteed to succeed
--- are 'newName', 'runIO', 'reportError' and 'reportWarning'.
-runQ :: Quasi m => Q a -> m a
-runQ (Q m) = m
+newtype Q a = Q { unQ :: MetaHandlers IO -> IO a }
instance Monad Q where
- Q m >>= k = Q (m >>= \x -> unQ (k x))
+ Q m >>= k = Q $ \h -> (m h >>= \x -> unQ (k x) h)
(>>) = (*>)
instance MonadFail Q where
- fail s = report True s >> Q (fail "Q monad failure")
+ fail s = report True s >> Q (\h -> mFail h "Q monad failure")
instance Functor Q where
- fmap f (Q x) = Q (fmap f x)
+ fmap f (Q x) = Q $ \h -> fmap f (x h)
instance Applicative Q where
- pure x = Q (pure x)
- Q f <*> Q x = Q (f <*> x)
- Q m *> Q n = Q (m *> n)
+ pure x = Q $ \_ -> pure x
+ Q f <*> Q x = Q $ \h -> (f h <*> x h)
+ Q m *> Q n = Q $ \h -> (m h *> n h)
-- | @since 2.17.0.0
instance Semigroup a => Semigroup (Q a) where
@@ -319,7 +297,7 @@ class Monad m => Quote m where
newName :: String -> m Name
instance Quote Q where
- newName s = Q (qNewName s)
+ newName s = Q $ \h -> mNewName h s
-----------------------------------------------------
--
@@ -517,35 +495,26 @@ joinCode = flip bindCode id
-- | Report an error (True) or warning (False),
-- but carry on; use 'fail' to stop.
report :: Bool -> String -> Q ()
-report b s = Q (qReport b s)
-{-# DEPRECATED report "Use reportError or reportWarning instead" #-} -- deprecated in 7.6
-
--- | Report an error to the user, but allow the current splice's computation to carry on. To abort the computation, use 'fail'.
-reportError :: String -> Q ()
-reportError = report True
-
--- | Report a warning to the user, and carry on.
-reportWarning :: String -> Q ()
-reportWarning = report False
+report b s = Q $ \h -> mReport h b s
-- | Recover from errors raised by 'reportError' or 'fail'.
recover :: Q a -- ^ handler to invoke on failure
-> Q a -- ^ computation to run
-> Q a
-recover (Q r) (Q m) = Q (qRecover r m)
+recover rec main = Q $ \h -> mRecover h rec main
-- We don't export lookupName; the Bool isn't a great API
-- Instead we export lookupTypeName, lookupValueName
lookupName :: Bool -> String -> Q (Maybe Name)
-lookupName ns s = Q (qLookupName ns s)
+lookupName ns s = Q $ \h -> mLookupName h ns s
-- | Look up the given name in the (type namespace of the) current splice's scope. See "Language.Haskell.TH.Syntax#namelookup" for more details.
lookupTypeName :: String -> Q (Maybe Name)
-lookupTypeName s = Q (qLookupName True s)
+lookupTypeName s = Q $ \h -> mLookupName h True s
-- | Look up the given name in the (value namespace of the) current splice's scope. See "Language.Haskell.TH.Syntax#namelookup" for more details.
lookupValueName :: String -> Q (Maybe Name)
-lookupValueName s = Q (qLookupName False s)
+lookupValueName s = Q $ \h -> mLookupName h False s
{-
Note [Name lookup]
@@ -620,7 +589,7 @@ To ensure we get information about @D@-the-value, use 'lookupValueName':
and to get information about @D@-the-type, use 'lookupTypeName'.
-}
reify :: Name -> Q Info
-reify v = Q (qReify v)
+reify v = Q $ \h -> mReify h v
{- | @reifyFixity nm@ attempts to find a fixity declaration for @nm@. For
example, if the function @foo@ has the fixity declaration @infixr 7 foo@, then
@@ -629,7 +598,7 @@ example, if the function @foo@ has the fixity declaration @infixr 7 foo@, then
'Nothing', so you may assume @bar@ has 'defaultFixity'.
-}
reifyFixity :: Name -> Q (Maybe Fixity)
-reifyFixity nm = Q (qReifyFixity nm)
+reifyFixity nm = Q $ \h -> mReifyFixity h nm
{- | @reifyType nm@ attempts to find the type or kind of @nm@. For example,
@reifyType 'not@ returns @Bool -> Bool@, and
@@ -637,7 +606,7 @@ reifyFixity nm = Q (qReifyFixity nm)
This works even if there's no explicit signature and the type or kind is inferred.
-}
reifyType :: Name -> Q Type
-reifyType nm = Q (qReifyType nm)
+reifyType nm = Q $ \h -> mReifyType h nm
{- | Template Haskell is capable of reifying information about types and
terms defined in previous declaration groups. Top-level declaration splices break up
@@ -729,7 +698,7 @@ has some discussion around this.
-}
reifyInstances :: Name -> [Type] -> Q [InstanceDec]
-reifyInstances cls tys = Q (qReifyInstances cls tys)
+reifyInstances cls tys = Q $ \h -> mReifyInstances h cls tys
{- | @reifyRoles nm@ returns the list of roles associated with the parameters
(both visible and invisible) of
@@ -748,20 +717,20 @@ and @reifyRoles Proxy@, we will get @['NominalR', 'PhantomR']@. The 'NominalR' i
the role of the invisible @k@ parameter. Kind parameters are always nominal.
-}
reifyRoles :: Name -> Q [Role]
-reifyRoles nm = Q (qReifyRoles nm)
+reifyRoles nm = Q $ \h -> mReifyRoles h nm
-- | @reifyAnnotations target@ returns the list of annotations
-- associated with @target@. Only the annotations that are
-- appropriately typed is returned. So if you have @Int@ and @String@
-- annotations for the same target, you have to call this function twice.
reifyAnnotations :: Data a => AnnLookup -> Q [a]
-reifyAnnotations an = Q (qReifyAnnotations an)
+reifyAnnotations an = Q $ \h -> mReifyAnnotations h an
-- | @reifyModule mod@ looks up information about module @mod@. To
-- look up the current module, call this function with the return
-- value of 'Language.Haskell.TH.Lib.thisModule'.
reifyModule :: Module -> Q ModuleInfo
-reifyModule m = Q (qReifyModule m)
+reifyModule m = Q $ \h -> mReifyModule h m
-- | @reifyConStrictness nm@ looks up the strictness information for the fields
-- of the constructor with the name @nm@. Note that the strictness information
@@ -776,7 +745,7 @@ reifyModule m = Q (qReifyModule m)
-- circumstances, but it would return @['DecidedStrict', DecidedStrict]@ if the
-- @-XStrictData@ language extension was enabled.
reifyConStrictness :: Name -> Q [DecidedStrictness]
-reifyConStrictness n = Q (qReifyConStrictness n)
+reifyConStrictness n = Q $ \h -> mReifyConStrictness h n
-- | Is the list of instances returned by 'reifyInstances' nonempty?
--
@@ -789,7 +758,7 @@ isInstance nm tys = do { decs <- reifyInstances nm tys
-- | The location at which this computation is spliced.
location :: Q Loc
-location = Q qLocation
+location = Q mLocation
-- |The 'runIO' function lets you run an I\/O computation in the 'Q' monad.
-- Take care: you are guaranteed the ordering of calls to 'runIO' within
@@ -799,7 +768,7 @@ location = Q qLocation
-- necessarily flushed when the compiler finishes running, so you should
-- flush them yourself.
runIO :: IO a -> Q a
-runIO m = Q (qRunIO m)
+runIO m = Q $ \h -> mLiftIO h m
-- | Get the package root for the current package which is being compiled.
-- This can be set explicitly with the -package-root flag but is normally
@@ -811,7 +780,7 @@ runIO m = Q (qRunIO m)
-- change directory when compiling files but instead set the -package-root flag
-- appropriately.
getPackageRoot :: Q FilePath
-getPackageRoot = Q qGetPackageRoot
+getPackageRoot = Q mGetPackageRoot
-- | Record external directories that runIO is using (dependent upon).
-- The compiler can then recognize that it should re-compile the Haskell file
@@ -830,7 +799,7 @@ getPackageRoot = Q qGetPackageRoot
-- * The state of the directory is read at the interface generation time,
-- not at the time of the function call.
addDependentDirectory :: FilePath -> Q ()
-addDependentDirectory dp = Q (qAddDependentDirectory dp)
+addDependentDirectory dp = Q $ \h -> mAddDependentDirectory h dp
-- | Record external files that runIO is using (dependent upon).
-- The compiler can then recognize that it should re-compile the Haskell file
@@ -844,17 +813,17 @@ addDependentDirectory dp = Q (qAddDependentDirectory dp)
--
-- * The dependency is based on file content, not a modification time
addDependentFile :: FilePath -> Q ()
-addDependentFile fp = Q (qAddDependentFile fp)
+addDependentFile fp = Q $ \h -> mAddDependentFile h fp
-- | Obtain a temporary file path with the given suffix. The compiler will
-- delete this file after compilation.
addTempFile :: String -> Q FilePath
-addTempFile suffix = Q (qAddTempFile suffix)
+addTempFile suffix = Q $ \h -> mAddTempFile h suffix
-- | Add additional top-level declarations. The added declarations will be type
-- checked along with the current declaration group.
addTopDecls :: [Dec] -> Q ()
-addTopDecls ds = Q (qAddTopDecls ds)
+addTopDecls ds = Q $ \h -> mAddTopDecls h ds
-- | Same as 'addForeignSource', but expects to receive a path pointing to the
-- foreign file instead of a 'String' of its contents. Consider using this in
@@ -863,7 +832,7 @@ addTopDecls ds = Q (qAddTopDecls ds)
-- This is a good alternative to 'addForeignSource' when you are trying to
-- directly link in an object file.
addForeignFilePath :: ForeignSrcLang -> FilePath -> Q ()
-addForeignFilePath lang fp = Q (qAddForeignFilePath lang fp)
+addForeignFilePath lang fp = Q $ \h -> mAddForeignFilePath h lang fp
-- | Add a finalizer that will run in the Q monad after the current module has
-- been type checked. This only makes sense when run within a top-level splice.
@@ -872,7 +841,7 @@ addForeignFilePath lang fp = Q (qAddForeignFilePath lang fp)
-- 'reify' is able to find the local definitions when executed inside the
-- finalizer.
addModFinalizer :: Q () -> Q ()
-addModFinalizer act = Q (qAddModFinalizer (unQ act))
+addModFinalizer act = Q $ \h -> mAddModFinalizer h act
-- | Adds a core plugin to the compilation pipeline.
--
@@ -882,7 +851,7 @@ addModFinalizer act = Q (qAddModFinalizer (unQ act))
-- to tell the compiler that we needed to compile first a plugin module in the
-- current package.
addCorePlugin :: String -> Q ()
-addCorePlugin plugin = Q (qAddCorePlugin plugin)
+addCorePlugin plugin = Q $ \h -> mAddCorePlugin h plugin
-- | Get state from the 'Q' monad. The state maintained by 'Q' is isomorphic to
-- a type-indexed finite map. That is,
@@ -896,20 +865,20 @@ addCorePlugin plugin = Q (qAddCorePlugin plugin)
-- Note that the state is local to the Haskell module in which the Template
-- Haskell expression is executed.
getQ :: Typeable a => Q (Maybe a)
-getQ = Q qGetQ
+getQ = Q mGetQ
-- | Replace the state in the 'Q' monad. Note that the state is local to the
-- Haskell module in which the Template Haskell expression is executed.
putQ :: Typeable a => a -> Q ()
-putQ x = Q (qPutQ x)
+putQ x = Q $ \h -> mPutQ h x
-- | Determine whether the given language extension is enabled in the 'Q' monad.
isExtEnabled :: Extension -> Q Bool
-isExtEnabled ext = Q (qIsExtEnabled ext)
+isExtEnabled ext = Q $ \h -> mIsExtEnabled h ext
-- | List all enabled language extensions.
extsEnabled :: Q [Extension]
-extsEnabled = Q qExtsEnabled
+extsEnabled = Q mExtsEnabled
-- | Add Haddock documentation to the specified location. This will overwrite
-- any documentation at the location if it already exists. This will reify the
@@ -928,48 +897,18 @@ extsEnabled = Q qExtsEnabled
-- Adding documentation to anything outside of the current module will cause an
-- error.
putDoc :: DocLoc -> String -> Q ()
-putDoc t s = Q (qPutDoc t s)
+putDoc t s = Q $ \h -> mPutDoc h t s
-- | Retrieves the Haddock documentation at the specified location, if one
-- exists.
-- It can be used to read documentation on things defined outside of the current
-- module, provided that those modules were compiled with the @-haddock@ flag.
getDoc :: DocLoc -> Q (Maybe String)
-getDoc n = Q (qGetDoc n)
+getDoc n = Q $ \h -> mGetDoc h n
instance MonadIO Q where
liftIO = runIO
-instance Quasi Q where
- qNewName = newName
- qReport = report
- qRecover = recover
- qReify = reify
- qReifyFixity = reifyFixity
- qReifyType = reifyType
- qReifyInstances = reifyInstances
- qReifyRoles = reifyRoles
- qReifyAnnotations = reifyAnnotations
- qReifyModule = reifyModule
- qReifyConStrictness = reifyConStrictness
- qLookupName = lookupName
- qLocation = location
- qGetPackageRoot = getPackageRoot
- qAddDependentFile = addDependentFile
- qAddDependentDirectory = addDependentDirectory
- qAddTempFile = addTempFile
- qAddTopDecls = addTopDecls
- qAddForeignFilePath = addForeignFilePath
- qAddModFinalizer = addModFinalizer
- qAddCorePlugin = addCorePlugin
- qGetQ = getQ
- qPutQ = putQ
- qIsExtEnabled = isExtEnabled
- qExtsEnabled = extsEnabled
- qPutDoc = putDoc
- qGetDoc = getDoc
-
-
----------------------------------------------------
-- The following operations are used solely in GHC.HsToCore.Quote when
-- desugaring brackets. They are not necessary for the user, who can use
=====================================
libraries/ghci/GHCi/TH.hs
=====================================
@@ -1,5 +1,5 @@
{-# LANGUAGE ScopedTypeVariables, StandaloneDeriving, DeriveGeneric,
- TupleSections, RecordWildCards, InstanceSigs, CPP #-}
+ TupleSections, RecordWildCards, InstanceSigs, CPP, RankNTypes #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
-- |
@@ -164,58 +164,70 @@ ghcCmd m = GHCiQ $ \sRef -> do
instance MonadIO GHCiQ where
liftIO m = GHCiQ $ \_ -> m
-instance TH.Quasi GHCiQ where
- qNewName str = ghcCmd (NewName str)
- qReport isError msg = ghcCmd (Report isError msg)
-
- -- See Note [TH recover with -fexternal-interpreter] in GHC.Tc.Gen.Splice
- qRecover (GHCiQ h) a = GHCiQ $ \sRef -> mask $ \unmask -> do
- s <- readIORef sRef
- remoteTHCall (qsPipe s) StartRecover
- e <- try $ unmask $ runGHCiQ (a <* ghcCmd FailIfErrs) sRef
- remoteTHCall (qsPipe s) (EndRecover (isLeft e))
- case e of
- Left GHCiQException{} -> h sRef
- Right r -> return r
- qLookupName isType occ = ghcCmd (LookupName isType occ)
- qReify name = ghcCmd (Reify name)
- qReifyFixity name = ghcCmd (ReifyFixity name)
- qReifyType name = ghcCmd (ReifyType name)
- qReifyInstances name tys = ghcCmd (ReifyInstances name tys)
- qReifyRoles name = ghcCmd (ReifyRoles name)
-
-- To reify annotations, we send GHC the AnnLookup and also the
-- TypeRep of the thing we're looking for, to avoid needing to
-- serialize irrelevant annotations.
- qReifyAnnotations :: forall a . Data a => TH.AnnLookup -> GHCiQ [a]
- qReifyAnnotations lookup =
+reifyAnnotations :: forall a . Data a => TH.AnnLookup -> GHCiQ [a]
+reifyAnnotations lookup =
map (deserializeWithData . B.unpack) <$>
ghcCmd (ReifyAnnotations lookup typerep)
where typerep = typeOf (undefined :: a)
- qReifyModule m = ghcCmd (ReifyModule m)
- qReifyConStrictness name = ghcCmd (ReifyConStrictness name)
- qLocation = fromMaybe noLoc . qsLocation <$> getState
- qGetPackageRoot = ghcCmd GetPackageRoot
- qAddDependentFile file = ghcCmd (AddDependentFile file)
- qAddDependentDirectory dir = ghcCmd (AddDependentDirectory dir)
- qAddTempFile suffix = ghcCmd (AddTempFile suffix)
- qAddTopDecls decls = ghcCmd (AddTopDecls decls)
- qAddForeignFilePath lang fp = ghcCmd (AddForeignFilePath lang fp)
- qAddModFinalizer fin = GHCiQ (\_ -> mkRemoteRef fin) >>=
+runQinGHCiQ :: TH.Q a -> GHCiQ a
+runQinGHCiQ (TH.Q m) = GHCiQ $ \sRef -> m (metaHandlersGHCiQ (runInIO sRef))
+ where
+ runInIO :: IORef QState -> GHCiQ a -> IO a
+ runInIO sRef (GHCiQ m) = m sRef
+
+metaHandlersGHCiQ :: (forall x. GHCiQ x -> IO x) -> TH.MetaHandlers IO
+metaHandlersGHCiQ runInIO = TH.MetaHandlers {
+ mLiftIO = id
+ , mFail = runInIO . fail
+ , mNewName = \str -> runInIO $ ghcCmd (NewName str)
+ , mReport = \isError msg -> runInIO $ ghcCmd (Report isError msg)
+
+ -- See Note [TH recover with -fexternal-interpreter] in GHC.Tc.Gen.Splice
+ , mRecover = \h a -> runInIO $ GHCiQ $ \sRef -> mask $ \unmask -> do
+ s <- readIORef sRef
+ remoteTHCall (qsPipe s) StartRecover
+ e <- try $ unmask $ runGHCiQ (runQinGHCiQ a <* ghcCmd FailIfErrs) sRef
+ remoteTHCall (qsPipe s) (EndRecover (isLeft e))
+ case e of
+ Left GHCiQException{} ->
+ runGHCiQ (runQinGHCiQ h) sRef
+ Right r -> return r
+ , mLookupName = \isType occ -> runInIO $ ghcCmd (LookupName isType occ)
+ , mReify = \name ->runInIO $ ghcCmd (Reify name)
+ , mReifyFixity = \name ->runInIO $ ghcCmd (ReifyFixity name)
+ , mReifyType = \name -> runInIO $ ghcCmd (ReifyType name)
+ , mReifyInstances = \name tys -> runInIO $ ghcCmd (ReifyInstances name tys)
+ , mReifyRoles = \name -> runInIO $ ghcCmd (ReifyRoles name)
+
+ , mReifyAnnotations = runInIO . reifyAnnotations
+ , mReifyModule = \m -> runInIO $ ghcCmd (ReifyModule m)
+ , mReifyConStrictness = \name -> runInIO $ ghcCmd (ReifyConStrictness name)
+ , mLocation = runInIO $ fromMaybe noLoc . qsLocation <$> getState
+ , mGetPackageRoot = runInIO $ ghcCmd GetPackageRoot
+ , mAddDependentFile = \file -> runInIO $ ghcCmd (AddDependentFile file)
+ , mAddDependentDirectory = \dir -> runInIO $ ghcCmd (AddDependentDirectory dir)
+ , mAddTempFile = \suffix -> runInIO $ ghcCmd (AddTempFile suffix)
+ , mAddTopDecls = \decls -> runInIO $ ghcCmd (AddTopDecls decls)
+ , mAddForeignFilePath = \lang fp -> runInIO $ ghcCmd (AddForeignFilePath lang fp)
+ , mAddModFinalizer = \fin -> runInIO $ GHCiQ (\_ -> mkRemoteRef fin) >>=
ghcCmd . AddModFinalizer
- qAddCorePlugin str = ghcCmd (AddCorePlugin str)
- qGetQ = do
+ , mAddCorePlugin = \str -> runInIO $ ghcCmd (AddCorePlugin str)
+ , mGetQ = runInIO $ do
s <- getState
let lookup :: forall a. Typeable a => Map TypeRep Dynamic -> Maybe a
lookup m = fromDynamic =<< M.lookup (typeOf (undefined::a)) m
return $ lookup (qsMap s)
- qPutQ k = GHCiQ $ \sRef ->
- modifyIORef' sRef (\s -> s { qsMap = M.insert (typeOf k) (toDyn k) (qsMap s) })
- qIsExtEnabled x = ghcCmd (IsExtEnabled x)
- qExtsEnabled = ghcCmd ExtsEnabled
- qPutDoc l s = ghcCmd (PutDoc l s)
- qGetDoc l = ghcCmd (GetDoc l)
+ , mPutQ = \k -> runInIO $ GHCiQ $ \sRef ->
+ modifyIORef' sRef (\s -> s { qsMap = M.insert (typeOf k) (toDyn k) (qsMap s) })
+ , mIsExtEnabled = \x -> runInIO $ ghcCmd (IsExtEnabled x)
+ , mExtsEnabled = runInIO $ ghcCmd ExtsEnabled
+ , mPutDoc = \l s -> runInIO $ ghcCmd (PutDoc l s)
+ , mGetDoc = \l -> runInIO $ ghcCmd (GetDoc l)
+}
-- | The implementation of the 'StartTH' message: create
-- a new IORef QState, and return a RemoteRef to it.
@@ -235,7 +247,7 @@ runModFinalizerRefs pipe rstate qrefs = do
qstateref <- localRef rstate
qstate <- readIORef qstateref
qstate' <- newIORef $ qstate { qsPipe = pipe }
- _ <- runGHCiQ (TH.runQ $ sequence_ qs) qstate'
+ _ <- runGHCiQ (runQinGHCiQ $ sequence_ qs) qstate'
return ()
-- | The implementation of the 'RunTH' message
@@ -272,5 +284,5 @@ runTHQ
runTHQ pipe rstate mb_loc ghciq = do
qstateref <- localRef rstate
modifyIORef' qstateref (\qstate -> qstate { qsLocation = mb_loc, qsPipe = pipe })
- r <- runGHCiQ (TH.runQ ghciq) qstateref
+ r <- runGHCiQ (runQinGHCiQ ghciq) qstateref
return $! LB.toStrict (runPut (put r))
=====================================
libraries/template-haskell/Language/Haskell/TH/Syntax.hs
=====================================
@@ -5,13 +5,17 @@
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE UnboxedTuples #-}
+-- Don't warn for using 'report' from ghc-internal
+{-# OPTIONS_GHC -Wno-warnings-deprecations #-}
module Language.Haskell.TH.Syntax (
Quote (..),
Exp (..),
Match (..),
Clause (..),
- Q (..),
+ Q,
+ -- backwards compatibility
+ Language.Haskell.TH.Syntax.unQ,
Pat (..),
Stmt (..),
Con (..),
@@ -202,11 +206,14 @@ where
import GHC.Boot.TH.Lift
import GHC.Boot.TH.Syntax
-import GHC.Boot.TH.Monad
+import GHC.Boot.TH.Monad hiding (report)
+import qualified GHC.Boot.TH.Monad as Internal
import System.FilePath
import Data.Data hiding (Fixity(..))
import Data.List.NonEmpty (NonEmpty(..))
import GHC.Lexeme ( startsVarSym, startsVarId )
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import System.IO (hPutStrLn, stderr)
-- This module completely re-exports 'GHC.Boot.TH.Syntax',
-- and exports additionally functions that depend on @filepath@ or @System.IO@.
@@ -499,3 +506,195 @@ reassociate the tree as necessary.
-- Subsumed by the more general 'SpecialiseEP' constructor.
pattern SpecialiseP :: Name -> Type -> (Maybe Inline) -> Phases -> Pragma
pattern SpecialiseP nm ty inl phases = SpecialiseEP Nothing [] (SigE (VarE nm) ty) inl phases
+
+unQ :: Q a -> (forall m. Quasi m => m a)
+unQ m = runQ m
+
+-----------------------------------------------------
+--
+-- The Quasi class
+--
+-----------------------------------------------------
+
+class (MonadIO m, MonadFail m) => Quasi m where
+ qRunQ :: Q a -> m a
+ -- | Fresh names. See 'newName'.
+ qNewName :: String -> m Name
+
+ ------- Error reporting and recovery -------
+ -- | Report an error (True) or warning (False)
+ -- ...but carry on; use 'fail' to stop. See 'report'.
+ qReport :: Bool -> String -> m ()
+
+ -- | See 'recover'.
+ qRecover :: m a -- ^ the error handler
+ -> m a -- ^ action which may fail
+ -> m a -- ^ Recover from the monadic 'fail'
+
+ ------- Inspect the type-checker's environment -------
+ -- | True <=> type namespace, False <=> value namespace. See 'lookupName'.
+ qLookupName :: Bool -> String -> m (Maybe Name)
+ -- | See 'reify'.
+ qReify :: Name -> m Info
+ -- | See 'reifyFixity'.
+ qReifyFixity :: Name -> m (Maybe Fixity)
+ -- | See 'reifyType'.
+ qReifyType :: Name -> m Type
+ -- | Is (n tys) an instance? Returns list of matching instance Decs (with
+ -- empty sub-Decs) Works for classes and type functions. See 'reifyInstances'.
+ qReifyInstances :: Name -> [Type] -> m [Dec]
+ -- | See 'reifyRoles'.
+ qReifyRoles :: Name -> m [Role]
+ -- | See 'reifyAnnotations'.
+ qReifyAnnotations :: Data a => AnnLookup -> m [a]
+ -- | See 'reifyModule'.
+ qReifyModule :: Module -> m ModuleInfo
+ -- | See 'reifyConStrictness'.
+ qReifyConStrictness :: Name -> m [DecidedStrictness]
+
+ -- | See 'location'.
+ qLocation :: m Loc
+
+ -- | Input/output (dangerous). See 'runIO'.
+ qRunIO :: IO a -> m a
+ qRunIO = liftIO
+ -- | See 'getPackageRoot'.
+ qGetPackageRoot :: m FilePath
+
+ -- | See 'addDependentFile'.
+ qAddDependentFile :: FilePath -> m ()
+
+ -- | See 'addDependentDirectory'.
+ qAddDependentDirectory :: FilePath -> m ()
+
+ -- | See 'addTempFile'.
+ qAddTempFile :: String -> m FilePath
+
+ -- | See 'addTopDecls'.
+ qAddTopDecls :: [Dec] -> m ()
+
+ -- | See 'addForeignFilePath'.
+ qAddForeignFilePath :: ForeignSrcLang -> String -> m ()
+
+ -- | See 'addModFinalizer'.
+ qAddModFinalizer :: Q () -> m ()
+
+ -- | See 'addCorePlugin'.
+ qAddCorePlugin :: String -> m ()
+
+ -- | See 'getQ'.
+ qGetQ :: Typeable a => m (Maybe a)
+
+ -- | See 'putQ'.
+ qPutQ :: Typeable a => a -> m ()
+
+ -- | See 'isExtEnabled'.
+ qIsExtEnabled :: Extension -> m Bool
+ -- | See 'extsEnabled'.
+ qExtsEnabled :: m [Extension]
+
+ -- | See 'putDoc'.
+ qPutDoc :: DocLoc -> String -> m ()
+ -- | See 'getDoc'.
+ qGetDoc :: DocLoc -> m (Maybe String)
+
+-- | \"Runs\" the 'Q' monad. Normal users of Template Haskell
+-- should not need this function, as the splice brackets @$( ... )@
+-- are the usual way of running a 'Q' computation.
+--
+-- This function is primarily used in GHC internals, and for debugging
+-- splices by running them in 'IO'.
+--
+-- Note that many functions in 'Q', such as 'reify' and other compiler
+-- queries, are not supported when running 'Q' in 'IO'; these operations
+-- simply fail at runtime. Indeed, the only operations guaranteed to succeed
+-- are 'newName', 'runIO', 'reportError' and 'reportWarning'.
+runQ :: Quasi m => Q a -> m a
+runQ = qRunQ
+
+-----------------------------------------------------
+-- The IO instance of Quasi
+-----------------------------------------------------
+
+-- | This instance is used only when running a Q
+-- computation in the IO monad, usually just to
+-- print the result. There is no interesting
+-- type environment, so reification isn't going to
+-- work.
+instance Quasi IO where
+ qRunQ (Q m) = m metaHandlersIO
+ qNewName = newNameIO
+
+ qReport True msg = hPutStrLn stderr ("Template Haskell error: " ++ msg)
+ qReport False msg = hPutStrLn stderr ("Template Haskell error: " ++ msg)
+
+ qLookupName _ _ = badIO "lookupName"
+ qReify _ = badIO "reify"
+ qReifyFixity _ = badIO "reifyFixity"
+ qReifyType _ = badIO "reifyFixity"
+ qReifyInstances _ _ = badIO "reifyInstances"
+ qReifyRoles _ = badIO "reifyRoles"
+ qReifyAnnotations _ = badIO "reifyAnnotations"
+ qReifyModule _ = badIO "reifyModule"
+ qReifyConStrictness _ = badIO "reifyConStrictness"
+ qLocation = badIO "currentLocation"
+ qRecover _ _ = badIO "recover" -- Maybe we could fix this?
+ qGetPackageRoot = badIO "getProjectRoot"
+ qAddDependentFile _ = badIO "addDependentFile"
+ qAddTempFile _ = badIO "addTempFile"
+ qAddTopDecls _ = badIO "addTopDecls"
+ qAddForeignFilePath _ _ = badIO "addForeignFilePath"
+ qAddModFinalizer _ = badIO "addModFinalizer"
+ qAddCorePlugin _ = badIO "addCorePlugin"
+ qGetQ = badIO "getQ"
+ qPutQ _ = badIO "putQ"
+ qIsExtEnabled _ = badIO "isExtEnabled"
+ qExtsEnabled = badIO "extsEnabled"
+ qPutDoc _ _ = badIO "putDoc"
+ qGetDoc _ = badIO "getDoc"
+ qAddDependentDirectory _ = badIO "AddDependentDirectory"
+
+instance Quasi Q where
+ qRunQ = id
+ qNewName = newName
+ qReport = report
+ qRecover = recover
+ qReify = reify
+ qReifyFixity = reifyFixity
+ qReifyType = reifyType
+ qReifyInstances = reifyInstances
+ qReifyRoles = reifyRoles
+ qReifyAnnotations = reifyAnnotations
+ qReifyModule = reifyModule
+ qReifyConStrictness = reifyConStrictness
+ qLookupName = lookupName
+ qLocation = location
+ qGetPackageRoot = getPackageRoot
+ qAddDependentFile = addDependentFile
+ qAddDependentDirectory = addDependentDirectory
+ qAddTempFile = addTempFile
+ qAddTopDecls = addTopDecls
+ qAddForeignFilePath = addForeignFilePath
+ qAddModFinalizer = addModFinalizer
+ qAddCorePlugin = addCorePlugin
+ qGetQ = getQ
+ qPutQ = putQ
+ qIsExtEnabled = isExtEnabled
+ qExtsEnabled = extsEnabled
+ qPutDoc = putDoc
+ qGetDoc = getDoc
+
+
+-- | Report an error (True) or warning (False),
+-- but carry on; use 'fail' to stop.
+report :: Bool -> String -> Q ()
+report = Internal.report
+{-# DEPRECATED report "Use reportError or reportWarning instead" #-} -- deprecated in 7.6
+
+-- | Report an error to the user, but allow the current splice's computation to carry on. To abort the computation, use 'fail'.
+reportError :: String -> Q ()
+reportError = report True
+
+-- | Report a warning to the user, and carry on.
+reportWarning :: String -> Q ()
+reportWarning = report False
=====================================
testsuite/tests/interface-stability/template-haskell-exports.stdout
=====================================
@@ -354,7 +354,6 @@ module Language.Haskell.TH where
type Pred = Type
type PredQ :: *
type PredQ = Q Pred
- type role Q nominal
type Q :: * -> *
newtype Q a = ...
type Quote :: (* -> *) -> Constraint
@@ -655,7 +654,7 @@ module Language.Haskell.TH where
roleAnnotD :: forall (m :: * -> *). Quote m => Name -> [GHC.Internal.TH.Lib.Role] -> m Dec
ruleVar :: forall (m :: * -> *). Quote m => Name -> m RuleBndr
runIO :: forall a. GHC.Internal.Types.IO a -> Q a
- runQ :: forall (m :: * -> *) a. GHC.Internal.TH.Monad.Quasi m => Q a -> m a
+ runQ :: forall (m :: * -> *) a. Language.Haskell.TH.Syntax.Quasi m => Q a -> m a
safe :: Safety
sectionL :: forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
sectionR :: forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
@@ -1703,11 +1702,11 @@ module Language.Haskell.TH.Syntax where
data Pragma = InlineP Name Inline RuleMatch Phases | OpaqueP Name | SpecialiseEP (GHC.Internal.Maybe.Maybe [TyVarBndr ()]) [RuleBndr] Exp (GHC.Internal.Maybe.Maybe Inline) Phases | SpecialiseInstP Type | RuleP GHC.Internal.Base.String (GHC.Internal.Maybe.Maybe [TyVarBndr ()]) [RuleBndr] Exp Exp Phases | AnnP AnnTarget Exp | LineP GHC.Internal.Types.Int GHC.Internal.Base.String | CompleteP [Name] (GHC.Internal.Maybe.Maybe Name) | SCCP Name (GHC.Internal.Maybe.Maybe GHC.Internal.Base.String)
type Pred :: *
type Pred = Type
- type role Q nominal
type Q :: * -> *
- newtype Q a = Q {unQ :: forall (m :: * -> *). Quasi m => m a}
+ newtype Q a = ...
type Quasi :: (* -> *) -> Constraint
class (GHC.Internal.Control.Monad.IO.Class.MonadIO m, GHC.Internal.Control.Monad.Fail.MonadFail m) => Quasi m where
+ qRunQ :: forall a. Q a -> m a
qNewName :: GHC.Internal.Base.String -> m Name
qReport :: GHC.Internal.Types.Bool -> GHC.Internal.Base.String -> m ()
qRecover :: forall a. m a -> m a -> m a
@@ -1730,13 +1729,13 @@ module Language.Haskell.TH.Syntax where
qAddForeignFilePath :: ForeignSrcLang -> GHC.Internal.Base.String -> m ()
qAddModFinalizer :: Q () -> m ()
qAddCorePlugin :: GHC.Internal.Base.String -> m ()
- qGetQ :: forall a. ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a => m (GHC.Internal.Maybe.Maybe a)
- qPutQ :: forall a. ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a => a -> m ()
+ qGetQ :: forall a. ghc-internal-10.100.0:GHC.Internal.Data.Typeable.Internal.Typeable a => m (GHC.Internal.Maybe.Maybe a)
+ qPutQ :: forall a. ghc-internal-10.100.0:GHC.Internal.Data.Typeable.Internal.Typeable a => a -> m ()
qIsExtEnabled :: Extension -> m GHC.Internal.Types.Bool
qExtsEnabled :: m [Extension]
qPutDoc :: DocLoc -> GHC.Internal.Base.String -> m ()
qGetDoc :: DocLoc -> m (GHC.Internal.Maybe.Maybe GHC.Internal.Base.String)
- {-# MINIMAL qNewName, qReport, qRecover, qLookupName, qReify, qReifyFixity, qReifyType, qReifyInstances, qReifyRoles, qReifyAnnotations, qReifyModule, qReifyConStrictness, qLocation, qGetPackageRoot, qAddDependentFile, qAddDependentDirectory, qAddTempFile, qAddTopDecls, qAddForeignFilePath, qAddModFinalizer, qAddCorePlugin, qGetQ, qPutQ, qIsExtEnabled, qExtsEnabled, qPutDoc, qGetDoc #-}
+ {-# MINIMAL qRunQ, qNewName, qReport, qRecover, qLookupName, qReify, qReifyFixity, qReifyType, qReifyInstances, qReifyRoles, qReifyAnnotations, qReifyModule, qReifyConStrictness, qLocation, qGetPackageRoot, qAddDependentFile, qAddDependentDirectory, qAddTempFile, qAddTopDecls, qAddForeignFilePath, qAddModFinalizer, qAddCorePlugin, qGetQ, qPutQ, qIsExtEnabled, qExtsEnabled, qPutDoc, qGetDoc #-}
type Quote :: (* -> *) -> Constraint
class GHC.Internal.Base.Monad m => Quote m where
newName :: GHC.Internal.Base.String -> m Name
@@ -1814,7 +1813,7 @@ module Language.Haskell.TH.Syntax where
falseName :: Name
getDoc :: DocLoc -> Q (GHC.Internal.Maybe.Maybe GHC.Internal.Base.String)
getPackageRoot :: Q GHC.Internal.IO.FilePath
- getQ :: forall a. ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a => Q (GHC.Internal.Maybe.Maybe a)
+ getQ :: forall a. ghc-internal-10.100.0:GHC.Internal.Data.Typeable.Internal.Typeable a => Q (GHC.Internal.Maybe.Maybe a)
get_cons_names :: Con -> [Name]
hoistCode :: forall (m :: * -> *) (n :: * -> *) (r :: GHC.Internal.Types.RuntimeRep) (a :: TYPE r). GHC.Internal.Base.Monad m => (forall x. m x -> n x) -> Code m a -> Code n a
isExtEnabled :: Extension -> Q GHC.Internal.Types.Bool
@@ -1861,7 +1860,7 @@ module Language.Haskell.TH.Syntax where
oneName :: Name
pkgString :: PkgName -> GHC.Internal.Base.String
putDoc :: DocLoc -> GHC.Internal.Base.String -> Q ()
- putQ :: forall a. ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a => a -> Q ()
+ putQ :: forall a. ghc-internal-10.100.0:GHC.Internal.Data.Typeable.Internal.Typeable a => a -> Q ()
recover :: forall a. Q a -> Q a -> Q a
reify :: Name -> Q Info
reifyAnnotations :: forall a. GHC.Internal.Data.Data.Data a => AnnLookup -> Q [a]
@@ -1884,6 +1883,7 @@ module Language.Haskell.TH.Syntax where
trueName :: Name
tupleDataName :: GHC.Internal.Types.Int -> Name
tupleTypeName :: GHC.Internal.Types.Int -> Name
+ unQ :: forall a. Q a -> forall (m :: * -> *). Quasi m => m a
unTypeCode :: forall (r :: GHC.Internal.Types.RuntimeRep) (a :: TYPE r) (m :: * -> *). Quote m => Code m a -> m Exp
unTypeQ :: forall (r :: GHC.Internal.Types.RuntimeRep) (a :: TYPE r) (m :: * -> *). Quote m => m (TExp a) -> m Exp
unboxedSumDataName :: SumAlt -> SumArity -> Name
@@ -2289,10 +2289,10 @@ instance forall a b c d e f g. (GHC.Internal.TH.Lift.Lift a, GHC.Internal.TH.Lif
instance GHC.Internal.TH.Lift.Lift (# #) -- Defined in ‘GHC.Internal.TH.Lift’
instance GHC.Internal.TH.Lift.Lift GHC.Internal.Prim.Char# -- Defined in ‘GHC.Internal.TH.Lift’
instance GHC.Internal.TH.Lift.Lift GHC.Internal.Prim.Word# -- Defined in ‘GHC.Internal.TH.Lift’
-instance GHC.Internal.TH.Monad.Quasi GHC.Internal.Types.IO -- Defined in ‘GHC.Internal.TH.Monad’
-instance GHC.Internal.TH.Monad.Quasi GHC.Internal.TH.Monad.Q -- Defined in ‘GHC.Internal.TH.Monad’
instance GHC.Internal.TH.Monad.Quote GHC.Internal.Types.IO -- Defined in ‘GHC.Internal.TH.Monad’
instance GHC.Internal.TH.Monad.Quote GHC.Internal.TH.Monad.Q -- Defined in ‘GHC.Internal.TH.Monad’
instance [safe] Language.Haskell.TH.Lib.DefaultBndrFlag GHC.Internal.TH.Syntax.BndrVis -- Defined in ‘Language.Haskell.TH.Lib’
instance [safe] Language.Haskell.TH.Lib.DefaultBndrFlag GHC.Internal.TH.Syntax.Specificity -- Defined in ‘Language.Haskell.TH.Lib’
instance [safe] Language.Haskell.TH.Lib.DefaultBndrFlag () -- Defined in ‘Language.Haskell.TH.Lib’
+instance Language.Haskell.TH.Syntax.Quasi GHC.Internal.Types.IO -- Defined in ‘Language.Haskell.TH.Syntax’
+instance Language.Haskell.TH.Syntax.Quasi GHC.Internal.TH.Monad.Q -- Defined in ‘Language.Haskell.TH.Syntax’
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/dd433ad08a2b8e3aceb22c0d4e02ddd…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/dd433ad08a2b8e3aceb22c0d4e02ddd…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
Zubin pushed new branch wip/10.0.1-backports at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/10.0.1-backports
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/davide/hadrian_avoid_response_files_2] Hadrian: avoid response files when command line is short enough
by David Eichmann (＠DavidEichmann) 09 Jun '26
by David Eichmann (＠DavidEichmann) 09 Jun '26
09 Jun '26
David Eichmann pushed to branch wip/davide/hadrian_avoid_response_files_2 at Glasgow Haskell Compiler / GHC
Commits:
2abd08de by David Eichmann at 2026-06-09T11:09:15+01:00
Hadrian: avoid response files when command line is short enough
This replaces the logic of always using response files on Windows.
With the new condition based on command line lenght, reponse files
can be avoided in many more cases (on windows).
Now that response files are only used in a small number of cases,
response files are always kept and the -r / --keep-response-files
command line options have been removed
The response file paths are nolonger randomized. They are placed in the
`_build/rsp` directory. This ensures they are ignored by git and we
that Hadrian reuses response file paths when rebuilding rather than
leaving stale response files around.
Update user guide putting response files in its own section
- - - - -
6 changed files:
- changelog.d/hadrian-response-files.md
- docs/users_guide/using.rst
- hadrian/src/Builder.hs
- hadrian/src/CommandLine.hs
- hadrian/src/Hadrian/Builder/Ar.hs
- hadrian/src/Hadrian/Utilities.hs
Changes:
=====================================
changelog.d/hadrian-response-files.md
=====================================
@@ -1,9 +1,15 @@
section: packaging
-synopsis: Add a flag to tell Hadrian to keep response files
-issues: #27184
-mrs: !15906
+synopsis: Improved Hadrian's use of response files
+issues: #27230
+mrs: !15906 !16134
description:
- Hadrian can now be instructed to keep response files with the new
- --keep-response-files command line flag. This is helpful when debugging a
- build failure, as it allows re-running the failing command line invocation
- without an error due to a missing response file.
+ Response files are files that contain command-line arguments. Hadrian uses
+ response files to shorten command-line lengths. This is important on Windows
+ where command-line lengths are limited.
+
+ Hadrian now supports response files when invoking GHC. In order to support
+ manually rerunning commands issued by Hadrian, response files are no longer
+ deleted. Instead they are stored under `_build/rsp`. Response files are now
+ only used when the corresponding command-line is too long for the host
+ platform. This greatly reduces the use of response files and avoids excessive
+ file usage. Response files are overwritten on subsequent Hadrian builds.
=====================================
docs/users_guide/using.rst
=====================================
@@ -85,17 +85,6 @@ all files; you cannot, for example, invoke
``ghc -c -O1 Foo.hs -O2 Bar.hs`` to apply different optimisation levels
to the files ``Foo.hs`` and ``Bar.hs``.
-In addition to passing arguments via the command-line, arguments can be passed
-via GNU-style response files. For instance,
-
-.. code-block:: bash
-
- $ cat response-file
- -O1
- Hello.hs
- -o Hello
- $ ghc @response-file
-
.. note::
.. index::
@@ -118,9 +107,24 @@ via GNU-style response files. For instance,
``-fspecialise`` will not be enabled, since the ``-fno-specialise``
overrides the ``-fspecialise`` implied by ``-O1``.
+
+Command-line arguments in response files
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+In addition to passing arguments via the command-line, arguments can be passed
+via GNU-style response files. For instance,
+
+.. code-block:: bash
+
+ $ cat response-file
+ -O1
+ Hello.hs
+ -o Hello
+ $ ghc @response-file
+
.. _source-file-options:
-Command line options in source files
+Command-line options in source files
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
.. index::
=====================================
hadrian/src/Builder.hs
=====================================
@@ -304,7 +304,7 @@ instance H.Builder Builder where
case builder of
Ar Pack stg -> do
useTempFile <- arSupportsAtFile stg
- if useTempFile then runAr path buildArgs buildInputs buildOptions
+ if useTempFile then runAr output path buildArgs buildInputs buildOptions
else runArWithoutTempFile path buildArgs buildInputs buildOptions
Ar Unpack _ -> cmd' [Cwd output] [path] buildArgs buildOptions
@@ -343,7 +343,7 @@ instance H.Builder Builder where
Exit _ <- cmd' [path] (buildArgs ++ [input]) buildOptions
return ()
- Haddock BuildPackage -> runHaddock path buildArgs buildInputs
+ Haddock BuildPackage -> runHaddock output path buildArgs buildInputs
Ghc _ _ ->
-- Use a response file for ghc invocations to avoid issues with command line
@@ -351,9 +351,11 @@ instance H.Builder Builder where
-- NB: we can't put the buildArgs in a response file, because some flags require
-- empty arguments (such as the -dep-suffix flag), but that isn't supported
-- yet due to #26560.
- withResponseFileOnWindows
- (\buildInputs' -> cmd [path] buildArgs buildInputs' buildOptions)
+ withResponseFileIfLongCmd
+ output
+ (toCmdArgument [path] <> toCmdArgument buildArgs)
buildInputs
+ (toCmdArgument buildOptions)
HsCpp -> captureStdout
@@ -389,13 +391,16 @@ instance H.Builder Builder where
-- | Invoke @haddock@ given a path to it and a list of arguments. On Windows,
-- the input file arguments are passed as a response file.
-runHaddock :: FilePath -- ^ path to @haddock@
+runHaddock :: FilePath -- ^ base name to use for response file
+ -> FilePath -- ^ path to @haddock@
-> [String]
-> [FilePath] -- ^ input file paths
-> Action ()
-runHaddock haddockPath flagArgs fileInputs = withResponseFileOnWindows
- (cmd [haddockPath] flagArgs)
+runHaddock outputFilePath haddockPath flagArgs fileInputs = withResponseFileIfLongCmd
+ outputFilePath
+ (toCmdArgument [haddockPath] <> toCmdArgument flagArgs)
fileInputs
+ (CmdArgument [])
-- TODO: Some builders are required only on certain platforms. For example,
-- 'Objdump' is only required on OpenBSD and AIX. Add support for platform
=====================================
hadrian/src/CommandLine.hs
=====================================
@@ -3,8 +3,7 @@ module CommandLine (
lookupBignum,
cmdBignum, cmdProgressInfo, cmdCompleteSetting,
cmdDocsArgs, cmdUnitIdHash, lookupBuildRoot, TestArgs(..), TestSpeed(..), defaultTestArgs,
- cmdPrefix, cmdChangelogVersion, DocArgs(..), defaultDocArgs,
- cmdKeepResponseFiles
+ cmdPrefix, cmdChangelogVersion, DocArgs(..), defaultDocArgs
) where
import Data.Either
@@ -12,7 +11,7 @@ import qualified Data.HashMap.Strict as Map
import Data.List.Extra
import Development.Shake hiding (Normal)
import Flavour (DocTargets, DocTarget(..))
-import Hadrian.Utilities hiding (buildRoot, keepResponseFiles)
+import Hadrian.Utilities hiding (buildRoot)
import Settings.Parser
import System.Console.GetOpt
import System.Environment
@@ -37,7 +36,6 @@ data CommandLineArgs = CommandLineArgs
, testArgs :: TestArgs
, docsArgs :: DocArgs
, docTargets :: DocTargets
- , keepResponseFiles :: Bool
, prefix :: Maybe FilePath
, changelogVersion :: Maybe String
, completeStg :: Maybe String }
@@ -58,7 +56,6 @@ defaultCommandLineArgs = CommandLineArgs
, testArgs = defaultTestArgs
, docsArgs = defaultDocArgs
, docTargets = Set.fromList [minBound..maxBound]
- , keepResponseFiles = False
, prefix = Nothing
, changelogVersion = Nothing
, completeStg = Nothing }
@@ -141,9 +138,6 @@ readFreeze1 = Right $ \flags -> flags { freeze1 = True }
readFreeze2 = Right $ \flags -> flags { freeze1 = True, freeze2 = True }
readSkipDepends = Right $ \flags -> flags { skipDepends = True }
-readKeepResponseFiles :: Either String (CommandLineArgs -> CommandLineArgs)
-readKeepResponseFiles = Right $ \flags -> flags { keepResponseFiles = True }
-
readUnitIdHash :: Either String (CommandLineArgs -> CommandLineArgs)
readUnitIdHash = Right $ \flags ->
trace "--hash-unit-ids is deprecated. It is enabled by release flavour or +hash_unit_ids flavour transformer" $
@@ -302,8 +296,6 @@ optDescrs =
"Progress info style (None, Brief, Normal or Unicorn)."
, Option [] ["docs"] (ReqArg readDocsArg "TARGET")
"Strip down docs targets (none, no-haddocks, no-sphinx[-{html, pdfs, man}]."
- , Option ['r'] ["keep-response-files"] (NoArg readKeepResponseFiles)
- "Keep response files created during the build (for debugging)."
, Option ['k'] ["keep-test-files"] (NoArg readTestKeepFiles)
"Keep all the files generated when running the testsuite."
, Option [] ["test-compiler"] (ReqArg readTestCompiler "TEST_COMPILER")
@@ -382,7 +374,6 @@ cmdLineArgsMap = do
return $ insertExtra (progressInfo args) -- Accessed by Hadrian.Utilities
$ insertExtra (buildRoot args) -- Accessed by Hadrian.Utilities
- $ insertExtra (KeepResponseFiles $ keepResponseFiles args) -- Accessed by Hadrian.Utilities
$ insertExtra (testArgs args) -- Accessed by Settings.Builders.RunTest
$ insertExtra (docsArgs args) -- Accessed by Rules.Documentation
$ insertExtra allSettings -- Accessed by Settings
@@ -424,9 +415,6 @@ cmdUnitIdHash = unitIdHash <$> cmdLineArgs
cmdBignum :: Action (Maybe String)
cmdBignum = bignum <$> cmdLineArgs
-cmdKeepResponseFiles :: Action Bool
-cmdKeepResponseFiles = keepResponseFiles <$> cmdLineArgs
-
cmdProgressInfo :: Action ProgressInfo
cmdProgressInfo = progressInfo <$> cmdLineArgs
=====================================
hadrian/src/Hadrian/Builder/Ar.hs
=====================================
@@ -35,14 +35,16 @@ instance NFData ArMode
-- to be archived is passed via a temporary response file. Passing arguments
-- via a response file is not supported by some versions of @ar@, in which
-- case you should use 'runArWithoutTempFile' instead.
-runAr :: FilePath -- ^ path to @ar@
+runAr :: FilePath -- ^ base name to use for response files
+ -> FilePath -- ^ path to @ar@
-> [String] -- ^ other arguments
-> [FilePath] -- ^ input file paths
-> [CmdOption] -- ^ Additional options
-> Action ()
-runAr arPath flagArgs fileArgs buildOptions = withResponseFile $ \tmp -> do
- writeFile' tmp $ unwords fileArgs
- cmd [arPath] flagArgs ('@' : tmp) buildOptions
+runAr outputFilePath arPath flagArgs fileArgs buildOptions = do
+ rspFile <- responseFilePath outputFilePath
+ writeFile' rspFile $ unwords fileArgs
+ cmd [arPath] flagArgs ('@' : rspFile) buildOptions
-- | Invoke @ar@ given a path to it and a list of arguments. Note that @ar@
-- will be called multiple times if the list of files to be archived is too
=====================================
hadrian/src/Hadrian/Utilities.hs
=====================================
@@ -1,4 +1,6 @@
+{-# LANGUAGE ImpredicativeTypes #-}
{-# LANGUAGE TypeFamilies #-}
+
module Hadrian.Utilities (
-- * List manipulation
fromSingleton, replaceEq, minusOrd, intersectOrd, lookupAll, chunksOfSize,
@@ -14,7 +16,7 @@ module Hadrian.Utilities (
-- * Paths
BuildRoot (..), buildRoot, buildRootRules, isGeneratedSource,
- KeepResponseFiles (..), keepResponseFiles, withResponseFile, withResponseFileOnWindows,
+ withResponseFileIfLongCmd, responseFilePath,
-- * File system operations
copyFile, copyFileUntracked, createFileLink, fixFile,
@@ -47,11 +49,10 @@ import Data.Maybe
import Data.Typeable (TypeRep, typeOf)
import Development.Shake hiding (Normal)
import Development.Shake.Classes
+import Development.Shake.Command (CmdArgument (..), IsCmdArgument (toCmdArgument))
import Development.Shake.FilePath
import GHC.ResponseFile (escapeArgs)
import System.Environment (lookupEnv)
-import System.Info.Extra (isWindows)
-import System.IO (hClose, openTempFile)
import System.IO.Error (isPermissionError)
import qualified Data.ByteString as BS
@@ -255,13 +256,13 @@ infix 1 %%>
-- library, they can reach 2MB! Some operating systems do not support command
-- lines of such length, and this function can be used to obtain a reasonable
-- approximation of the limit. On Windows, it is theoretically 32768 characters
--- (since Windows 7). In practice we use 31000 to leave some breathing space for
+-- (since Windows 7). In practice we use 30000 to leave some breathing space for
-- the builder path & name, auxiliary flags, and other overheads. On Mac OS X,
-- ARG_MAX is 262144, yet when using @xargs@ on OSX this is reduced by over
-- 20000. Hence, 200000 seems like a sensible limit. On other operating systems
-- we currently use the 4194304 setting.
cmdLineLengthLimit :: Int
-cmdLineLengthLimit | IO.isWindows = 31000
+cmdLineLengthLimit | IO.isWindows = 30000
| IO.isMac = 200000
| otherwise = 4194304
@@ -321,53 +322,35 @@ buildRootRules = do
isGeneratedSource :: FilePath -> Action Bool
isGeneratedSource file = buildRoot <&> (`isPrefixOf` file)
-newtype KeepResponseFiles = KeepResponseFiles Bool deriving (Eq, Show)
-
--- | Whether to retain response files after the build action that created them
--- completes. Mainly useful for debugging.
-keepResponseFiles :: Action Bool
-keepResponseFiles = do
- KeepResponseFiles keep <- userSetting (KeepResponseFiles False)
- return keep
-
--- | Run an action either with command arguments direcly or by, on Windows,
--- placing those arguments into a response file escaped with @GHC.ResponseFile.escapeArgs@.
---
--- With @--keep-response-files@, the file is left on disk (if used)
-withResponseFileOnWindows ::
- ([String] -> Action a) -- ^ Action to perform given arguments (of the form @["\@reponseFilePath"]@ on Windows)
- -> [String] -- ^ Command arguments
- -> Action a
-withResponseFileOnWindows action commandArgs = do
- if isWindows
- then withResponseFile $ \tmp -> do
- writeFile' tmp (escapeArgs commandArgs)
- action ['@' : tmp]
- else action commandArgs
-
--- | Run an action with a response file path.
---
--- With @--keep-response-files@, the file is left on disk.
-withResponseFile :: (FilePath -> Action a) -> Action a
-withResponseFile action = do
- keep <- keepResponseFiles
- let putVerboseResponseFile tmp = do
- verbosity <- getVerbosity
- when (verbosity >= Verbose) $ do
- tmpContent <- liftIO (readFile tmp)
- putVerbose (tmp <> " (use hadrian flag --keep-response-files to keep this file):\n" <> tmpContent)
- if keep
- then do
- (tmp, h) <- liftIO $ openTempFile "." "hadrian-rsp"
- liftIO $ hClose h
- putInfo $ "Keeping response file: " ++ tmp
- result <- action tmp
- putVerboseResponseFile tmp
- return result
- else withTempFile $ \tmp -> do
- result <- action tmp
- putVerboseResponseFile tmp
- return result
+-- | Run an command with the given arguments. If the command is too long then the
+-- response file arguments are placed into a response file and escaped with @GHC.ResponseFile.escapeArgs@.
+withResponseFileIfLongCmd ::
+ CmdResult c
+ => FilePath -- ^ Response base name. The reponse file is placed in @_build/rsp/\<Response base name\>@.
+ -> CmdArgument -- ^ Command and arguments before the response file arguments.
+ -> [String] -- ^ Response file aruguments.
+ -> CmdArgument -- ^ Command arguments after the response file arguments.
+ -> Action c
+withResponseFileIfLongCmd outputFilePath argsPre argsResp argsPost = do
+ let cmdLineLengh = sum
+ [ 1 + length arg -- add one to account for space inbetween arguments
+ | let CmdArgument args = argsPre <> toCmdArgument argsResp <> argsPost
+ , Right arg <- args
+ ]
+ if cmdLineLengh < cmdLineLengthLimit
+ then cmd argsPre argsResp argsPost
+ else do
+ rspFile <- responseFilePath outputFilePath
+ writeFile' rspFile (escapeArgs argsResp)
+ cmd argsPre ['@' : rspFile] argsPost
+
+-- | Convert a command's output file path to a response file path to be used for that command.
+-- Response files are placed in a dedicated @rps@ directory under the build directory. This avoids
+-- clutering the work tree or interfearing with other build directories.
+responseFilePath :: FilePath -> Action FilePath
+responseFilePath outputFilePath = do
+ buildDir <- buildRoot
+ return $ buildDir </> "rsp" </> outputFilePath
-- | Link a file tracking the link target. Create the target directory if
-- missing.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2abd08deaf7c2816d763b6cb71a4a27…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2abd08deaf7c2816d763b6cb71a4a27…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/sjakobi/T26964] 10 commits: fix typo : compete with performance, not complete
by Simon Jakobi (＠sjakobi2) 09 Jun '26
by Simon Jakobi (＠sjakobi2) 09 Jun '26
09 Jun '26
Simon Jakobi pushed to branch wip/sjakobi/T26964 at Glasgow Haskell Compiler / GHC
Commits:
f2f5c6ba by Nikita Efremov at 2026-06-02T16:04:54+00:00
fix typo : compete with performance, not complete
- - - - -
5524ea0e by Wolfgang Jeltsch at 2026-06-03T08:01:26-04:00
Make the current `base` buildable with GHC 9.14
This comprises the following changes:
* Disable some imports into `GHC.Base` for GHC 9.14
* Disable some imports into `Prelude` for GHC 9.14
* Disable separate `ArrowLoop` import for GHC 9.14
* Disable `GHC.Internal.STM` import for GHC 9.14
* Disable `GHC.Internal.Unicode.Version` import for GHC 9.14
* Disable `GHC.Internal.TH.Monad` import for GHC 9.14
* Add alternative `fixIO` import for GHC 9.14
* Add alternative `unsafeCodeCoerce` import for GHC 9.14
* Disable hiding of imported SIMD operations for GHC 9.14
* Disable use of GHC 9.14’s `printToHandleFinalizerExceptionHandler`
* Enable use of `getFileHash` from `ghc-internal` for GHC 9.14
* Make `thenA` available for GHC 9.14
* Make `thenM` available for GHC 9.14
* Disable translation of `IoManagerFlagPoll` for GHC 9.14
* Add `hGetNewlineMode` for GHC 9.14
- - - - -
d3438055 by Enrico Maria De Angelis at 2026-06-03T08:02:17-04:00
Fix #27067 - Clarify haddocks on `minusNaturalMaybe`
- - - - -
f9bcfac2 by sheaf at 2026-06-03T14:47:19-04:00
Avoid mkTick in Core Prep breaking ANF
As discovered in #27182, mkTick can break ANF. This patch introduces a
variant of mkTick that skips the single optimisation that could break
ANF. This is preferrable over switching to the raw Tick constructor,
as the latter may introduce spurious cost centres in profiling reports.
This is a temporary measure until we more thoroughly refactor how
mkTick works (see #27141).
See Note [mkTick breaks ANF] in GHC.CoreToStg.Prep.
Fixes #27182
- - - - -
cf1fd661 by Artem Pelenitsyn at 2026-06-03T14:48:09-04:00
clarify comment for getSizeofMutableByteArray#: we get the size in bytes, not "elements"
- - - - -
a3b431f3 by David Eichmann at 2026-06-04T10:10:19+00:00
Hadrian: convert env variable ACLOCAL_PATH to unix paths.
Convert ACLOCAL_PATH to a unix style path when invoking autoreconf.
Autoreconf doesn't handle windows paths.
See Note [Autoreconf unix paths from ACLOCAL_PATH].
Fixes #27311
- - - - -
18f6138a by Simon Jakobi at 2026-06-04T20:20:31-04:00
testsuite: Deduplicate --only test names
config.only is assumed to be a set, but supplying --only overwrote it
with the (list) argparse result, which can contain duplicates. When a
test ran, config.only.remove(name) dropped only the first occurrence,
so a duplicated name lingered and was later misreported as a
"test not found" framework failure. Store it as a set instead.
Fixes #27322
Co-Authored-By: Claude Opus 4.7 <noreply(a)anthropic.com>
- - - - -
2f3cc9ff by Simon Jakobi at 2026-06-08T07:55:49-04:00
testsuite: detect fast bignum via ghc-internal, not removed ghc-bignum
The ghc-bignum package was merged into ghc-internal, so the BIGNUM_GMP
probe in test.mk ran `ghc-pkg field ghc-bignum exposed-modules`, which
fails with "cannot find package ghc-bignum". That error went to stderr
and leaked into the captured stderr of every makefile_test, causing
spurious [bad stderr] failures across the suite. The probe also silently
returned empty, so config.have_fast_bignum was wrongly False even on GMP
builds.
Probe ghc-internal's extra-libraries for the gmp library instead: the
GMP backend module is an other-module (not exposed), but GMP_LIBS adds
gmp to extra-libraries only on a GMP build, so this distinguishes the
backends. Redirect stderr to keep any future missing-package error off
the harness's stderr.
This also removes a stale comment as per suggestion from hsyl20.
Co-Authored-By: Claude Opus 4.7 <noreply(a)anthropic.com>
- - - - -
eb3bf6e7 by Alan Zimmerman at 2026-06-08T07:56:32-04:00
EPA: Rename Transform.anchorEof to addModuleCommentOrigDeltas
This now matches what it actually does.
- - - - -
a9bbd128 by Simon Jakobi at 2026-06-09T11:11:31+02:00
Improve -fcheck-prim-bounds error messages
When an array access instrumented by -fcheck-prim-bounds fails at runtime,
report the failing primop, the offending index, the array size, and the
module being compiled, then exit with a normal failure status, e.g.
readSmallArray#: array access out of bounds in module Main:
index -1 is not within [0, 5).
Previously the program aborted via barf with an "internal error" framed as a
GHC bug, even though such failures are almost always caused by incorrect use
of unsafe primops in user or library code.
The primop and module names are threaded to the RTS failure handlers
(rtsOutOfBoundsAccess, rtsMemcpyRangeOverlap) from StgToCmm. The primop name
is stashed once in cmmPrimOpApp via a new fcs_prim_op field in FCodeState, so
the bounds-check sites are unchanged; the module is stgToCmmThisModule.
Fixes #26964, #24617.
Co-Authored-By: Claude Opus 4.8 <noreply(a)anthropic.com>
- - - - -
48 changed files:
- boot
- + changelog.d/T27182.md
- + changelog.d/improve-check-prim-bounds-messages
- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/Core/Utils.hs
- compiler/GHC/CoreToStg/Prep.hs
- compiler/GHC/StgToCmm/Monad.hs
- compiler/GHC/StgToCmm/Prim.hs
- docs/users_guide/debugging.rst
- docs/users_guide/javascript.rst
- hadrian/src/Hadrian/Oracles/Path.hs
- hadrian/src/Rules/BinaryDist.hs
- libraries/base/src/Control/Applicative.hs
- libraries/base/src/Control/Arrow.hs
- libraries/base/src/Control/Monad.hs
- libraries/base/src/Data/Array/Byte.hs
- libraries/base/src/Data/Fixed.hs
- libraries/base/src/GHC/Base.hs
- libraries/base/src/GHC/Conc.hs
- libraries/base/src/GHC/Conc/Sync.hs
- libraries/base/src/GHC/Exts.hs
- libraries/base/src/GHC/Fingerprint.hs
- libraries/base/src/GHC/IO/Handle.hs
- libraries/base/src/GHC/RTS/Flags.hs
- libraries/base/src/GHC/Unicode.hs
- libraries/base/src/GHC/Weak.hs
- libraries/base/src/GHC/Weak/Finalize.hs
- libraries/base/src/Prelude.hs
- libraries/base/src/System/IO.hs
- libraries/base/src/System/Mem/Weak.hs
- libraries/ghc-internal/src/GHC/Internal/Natural.hs
- rts/PrimOps.cmm
- rts/RtsMessages.c
- rts/include/rts/Messages.h
- testsuite/driver/runtests.py
- testsuite/mk/test.mk
- + testsuite/tests/codeGen/should_fail/T26964.hs
- + testsuite/tests/codeGen/should_fail/T26964.stderr
- + testsuite/tests/codeGen/should_fail/T26964Module.hs
- + testsuite/tests/codeGen/should_fail/T26964Module.stderr
- + testsuite/tests/codeGen/should_fail/T26964ModuleA.hs
- + testsuite/tests/codeGen/should_fail/T26964b.hs
- + testsuite/tests/codeGen/should_fail/T26964b.stderr
- testsuite/tests/codeGen/should_fail/all.T
- + testsuite/tests/profiling/should_compile/T27182.hs
- testsuite/tests/profiling/should_compile/all.T
- utils/check-exact/Main.hs
- utils/check-exact/Transform.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d841fc919f30a35859cc37b212d216…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d841fc919f30a35859cc37b212d216…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/sjakobi/T27296-stable-simpl] 6 commits: Hadrian: convert env variable ACLOCAL_PATH to unix paths.
by Simon Jakobi (＠sjakobi2) 09 Jun '26
by Simon Jakobi (＠sjakobi2) 09 Jun '26
09 Jun '26
Simon Jakobi pushed to branch wip/sjakobi/T27296-stable-simpl at Glasgow Haskell Compiler / GHC
Commits:
a3b431f3 by David Eichmann at 2026-06-04T10:10:19+00:00
Hadrian: convert env variable ACLOCAL_PATH to unix paths.
Convert ACLOCAL_PATH to a unix style path when invoking autoreconf.
Autoreconf doesn't handle windows paths.
See Note [Autoreconf unix paths from ACLOCAL_PATH].
Fixes #27311
- - - - -
18f6138a by Simon Jakobi at 2026-06-04T20:20:31-04:00
testsuite: Deduplicate --only test names
config.only is assumed to be a set, but supplying --only overwrote it
with the (list) argparse result, which can contain duplicates. When a
test ran, config.only.remove(name) dropped only the first occurrence,
so a duplicated name lingered and was later misreported as a
"test not found" framework failure. Store it as a set instead.
Fixes #27322
Co-Authored-By: Claude Opus 4.7 <noreply(a)anthropic.com>
- - - - -
2f3cc9ff by Simon Jakobi at 2026-06-08T07:55:49-04:00
testsuite: detect fast bignum via ghc-internal, not removed ghc-bignum
The ghc-bignum package was merged into ghc-internal, so the BIGNUM_GMP
probe in test.mk ran `ghc-pkg field ghc-bignum exposed-modules`, which
fails with "cannot find package ghc-bignum". That error went to stderr
and leaked into the captured stderr of every makefile_test, causing
spurious [bad stderr] failures across the suite. The probe also silently
returned empty, so config.have_fast_bignum was wrongly False even on GMP
builds.
Probe ghc-internal's extra-libraries for the gmp library instead: the
GMP backend module is an other-module (not exposed), but GMP_LIBS adds
gmp to extra-libraries only on a GMP build, so this distinguishes the
backends. Redirect stderr to keep any future missing-package error off
the harness's stderr.
This also removes a stale comment as per suggestion from hsyl20.
Co-Authored-By: Claude Opus 4.7 <noreply(a)anthropic.com>
- - - - -
eb3bf6e7 by Alan Zimmerman at 2026-06-08T07:56:32-04:00
EPA: Rename Transform.anchorEof to addModuleCommentOrigDeltas
This now matches what it actually does.
- - - - -
7153ddec by Simon Jakobi at 2026-06-09T10:17:11+02:00
Add -dstable-core-dump-order for stable Core dump ordering (#27296)
The order of top-level bindings in Core dumps (-ddump-simpl etc.) is the
compiler's internal processing order, which is sensitive to Uniques.
Uniques can shift whenever an unrelated upstream module changes, so the
bindings get re-ordered and a textual diff of two dumps fails to line up
the real changes.
This adds an opt-in flag -dstable-core-dump-order that reorders the
top-level bindings of Core dumps routed through dumpPassResult into a
stable, unique-independent order: by source location, then a $-rank so a
derived $w/$s binder sorts before its origin (mirroring GHC's default
dependency order, where the wrapper calls the worker), then the OccName.
Workers and specialisations inherit their origin's source span, so they
cluster next to the binding they come from; anonymous floats (noSrcSpan)
sort to the end; Rec groups are kept intact. Only top-level bindings are
reordered; nested bindings are left as-is. The default order is retained
as it is useful when debugging the compiler itself.
The ordering is unique-independent, so two dumps line up across rebuilds.
See Note [Stable Core dump order] in GHC.Core.Ppr.
Adds test T27296, a small Data.Map-style module whose binders GHC emits
in a non-source order by default, asserting they come out stably ordered
under the flag.
Co-Authored-By: Claude Opus 4.7 <noreply(a)anthropic.com>
- - - - -
6e9658ab by Simon Jakobi at 2026-06-09T10:30:20+02:00
Stabilise anonymous float ordering in untidied Core dumps
Anonymous floats are all built with OccName "lvl" and noSrcSpan
(newLvlVar), so the source-span/name sort key is identical for every
one of them; sortOn then falls back to the unique-driven input order --
the very churn -dstable-core-dump-order is meant to remove. (Tidied
dumps like -ddump-simpl are unaffected, as tidy gives the floats
distinct names lvl, lvl1, ...)
Add a content-based, unique-independent tie-break (rhsKey): the floated
literal, if any, then the RHS size statistics.
Add test T27296b pinning the float ordering in an untidied
-ddump-float-out dump. It is a makefile_test that seds the dump down to
just the bindings (collapsing each pass header to a bare "Float out"
separator and dropping the FOS config / size lines), so the six lvl
floats are asserted to come out ordered by literal value.
Co-Authored-By: Claude Opus 4.7 <noreply(a)anthropic.com>
- - - - -
21 changed files:
- boot
- + changelog.d/stable-core-dump-order-27296
- compiler/GHC/Core/Lint.hs
- compiler/GHC/Core/Ppr.hs
- compiler/GHC/Driver/DynFlags.hs
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Utils/Outputable.hs
- docs/users_guide/debugging.rst
- hadrian/src/Hadrian/Oracles/Path.hs
- hadrian/src/Rules/BinaryDist.hs
- testsuite/driver/runtests.py
- testsuite/mk/test.mk
- testsuite/tests/simplCore/should_compile/Makefile
- + testsuite/tests/simplCore/should_compile/T27296.hs
- + testsuite/tests/simplCore/should_compile/T27296.stdout
- + testsuite/tests/simplCore/should_compile/T27296b.hs
- + testsuite/tests/simplCore/should_compile/T27296b.stdout
- testsuite/tests/simplCore/should_compile/all.T
- utils/check-exact/Main.hs
- utils/check-exact/Transform.hs
Changes:
=====================================
boot
=====================================
@@ -52,9 +52,8 @@ def autoreconf():
# Run autoreconf on everything that needs it.
processes = {}
if os.name == 'nt':
- # Get the normalized ACLOCAL_PATH for Windows
- # This is necessary since on Windows this will be a Windows
- # path, which autoreconf doesn't know doesn't know how to handle.
+ # Convert ACLOCAL_PATH env variable to unix style paths on Windows
+ # See Note [Autoreconf unix paths from ACLOCAL_PATH]
ac_local = os.getenv('ACLOCAL_PATH', '')
ac_local_arg = re.sub(r';', r':', ac_local)
ac_local_arg = re.sub(r'\\', r'/', ac_local_arg)
=====================================
changelog.d/stable-core-dump-order-27296
=====================================
@@ -0,0 +1,4 @@
+section: compiler
+synopsis: Add :ghc-flag:`-dstable-core-dump-order`, a debugging flag that prints top-level Core bindings in a stable, source-location-based order that does not depend on uniques, making intermediate-compiler dumps (e.g. with :ghc-flag:`-ddump-simpl` or :ghc-flag:`-dverbose-core2core`) easier to diff. This affects only the compiler's intermediate output; it does not change generated code.
+issues: #27296
+mrs: !16143
=====================================
compiler/GHC/Core/Lint.hs
=====================================
@@ -327,12 +327,17 @@ dumpPassResult logger dump_core_sizes name_ppr_ctx mb_flag hdr extra_info binds
where
size_doc = sep [text "Result size of" <+> text hdr, nest 2 (equals <+> ppr (coreBindsStats binds))]
+ -- See Note [Stable Core dump order] in GHC.Core.Ppr
+ binds' | sdocStableCoreDumpOrder (log_default_dump_context (logFlags logger))
+ = sortCoreBindingsForDump binds
+ | otherwise = binds
+
dump_doc = vcat [ nest 2 extra_info
, size_doc
, blankLine
, if dump_core_sizes
- then pprCoreBindingsWithSize binds
- else pprCoreBindings binds
+ then pprCoreBindingsWithSize binds'
+ else pprCoreBindings binds'
, ppUnless (null rules) pp_rules ]
pp_rules = vcat [ blankLine
, text "------ Local rules for imported ids --------"
=====================================
compiler/GHC/Core/Ppr.hs
=====================================
@@ -19,6 +19,7 @@ module GHC.Core.Ppr (
pprCoreExpr, pprParendExpr,
pprCoreBinding, pprCoreBindings, pprCoreAlt,
pprCoreBindingWithSize, pprCoreBindingsWithSize,
+ sortCoreBindingsForDump,
pprCoreBinder, pprCoreBinders, pprId, pprIds,
pprRule, pprRules, pprOptCo,
pprOcc, pprOccWithTick
@@ -27,10 +28,10 @@ module GHC.Core.Ppr (
import GHC.Prelude
import GHC.Core
-import GHC.Core.Stats (exprStats)
+import GHC.Core.Stats (CoreStats(..), exprStats)
import GHC.Types.Fixity (LexicalFixity(..))
-import GHC.Types.Literal( pprLiteral )
-import GHC.Types.Name( pprInfixName, pprPrefixName )
+import GHC.Types.Literal( Literal, pprLiteral )
+import GHC.Types.Name( getOccString, getSrcSpan, pprInfixName, pprPrefixName )
import GHC.Types.Var
import GHC.Types.Id
import GHC.Types.Id.Info
@@ -44,9 +45,13 @@ import GHC.Core.Coercion
import GHC.Types.Basic
import GHC.Utils.Misc
import GHC.Utils.Outputable
-import GHC.Types.SrcLoc ( pprUserRealSpan )
+import GHC.Utils.Panic (panic)
+import GHC.Types.SrcLoc ( SrcSpan(..), pprUserRealSpan, srcSpanStartCol
+ , srcSpanStartLine )
import GHC.Types.Tickish
+import Data.List ( sortOn )
+
{-
************************************************************************
* *
@@ -71,6 +76,115 @@ pprCoreBindingWithSize :: CoreBind -> SDoc
pprCoreBindingsWithSize = pprTopBinds sizeAnn
pprCoreBindingWithSize = pprTopBind sizeAnn
+{- Note [Stable Core dump order]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The order of top-level bindings in a Core dump (-ddump-simpl etc.) is the
+compiler's internal processing order, which is sensitive to Uniques. Uniques
+can shift whenever an unrelated upstream module changes, so the bindings get
+re-ordered and a textual diff of two dumps fails to line up the real changes
+(#27296).
+
+With -dstable-core-dump-order we reorder the top-level bindings at dump time into
+a stable order. 'sortCoreBindingsForDump' sorts by a key that is *independent of
+Uniques*, so two dumps line up across rebuilds. The sort key is:
+
+ 1. the binder's source span (real spans in source order; noSrcSpan last).
+ Workers and specialisations inherit their origin's source span (see
+ 'mkWorkerId' and 'newSpecIdSM'), so they cluster next to the binding they
+ come from.
+ 2. a "$-rank" so that within one source span the compiler-derived binders sort
+ *before* the origin they come from (e.g. @$wfoo@ before @foo@), mirroring
+ GHC's default dependency order (the wrapper calls the worker, so the worker
+ comes first; specialisations likewise precede their origin). We rank by
+ whether the OccName *contains* a '$', which marks a derived binder: a worker
+ is @$wfoo@, but a call-site specialisation is tidied to @bar_$sfoo@ (no
+ leading '$'), so a leading-'$' test would miss it.
+ 3. the OccName string, as a lexical, deterministic tie-break.
+ 4. a content-based tie-break on the right-hand side ('rhsKey'): the floated
+ literal, if any, then the RHS size statistics. This matters for the
+ anonymous floats: 'newLvlVar' builds them all with OccName "lvl" and
+ noSrcSpan, so keys 1-3 are identical and without it their order would fall
+ back to the Unique-driven input order -- the churn we set out to remove.
+ (Tidied dumps like -ddump-simpl give the floats distinct names lvl,
+ lvl1, ...; this additionally stabilises untidied dumps such as
+ -ddump-simpl-iterations.) It is only a best-effort tie-break -- RHSs
+ agreeing on both components keep their input order -- and Unique-independent
+ for the numeric CAFs we target (a rubbish literal is the exception: its
+ 'cmpLit' falls back to the Unique-dependent 'nonDetCmpType').
+
+Recursive groups are never split: a 'Rec' is one 'CoreBind', placed as a unit by
+its earliest-source member, with its members sorted by the same key.
+
+Only *top-level* bindings (and the members of a top-level 'Rec') are reordered.
+Bindings nested inside a right-hand side (a 'let'/'letrec' within an expression)
+are left in their original order: their position in the dump is fixed by the
+surrounding expression rather than chosen by a Unique-keyed sort, so they don't
+suffer the cross-module churn this flag addresses.
+
+-dstable-core-dump-order is opt-in; the default order is retained because it is
+useful for debugging the compiler itself.
+-}
+
+-- | The sort key for one top-level binder. The trailing 'RhsKey' is a
+-- content-based tiebreak, used only when two binders agree on everything
+-- before it. See Note [Stable Core dump order].
+type DumpSortKey =
+ ( Int -- source-span bucket: 0 = real span, 1 = noSrcSpan (sorts last)
+ , Int -- source-span start line
+ , Int -- source-span start column
+ , Int -- dollar-rank: 0 = derived ($w/$s) binder, 1 = its origin
+ , String -- the OccName string, a lexical tiebreak
+ , RhsKey -- content-based tiebreak (see 'rhsKey')
+ )
+
+-- | Reorder a 'CoreProgram' into a stable, source-location-driven order for
+-- dumping. See Note [Stable Core dump order]. Used by 'dumpPassResult' when
+-- -dstable-core-dump-order is enabled.
+sortCoreBindingsForDump :: CoreProgram -> CoreProgram
+sortCoreBindingsForDump = sortOn bindKey . map sortRecMembers
+ where
+ sortRecMembers (Rec prs) = Rec (sortOn (uncurry elemKey) prs)
+ sortRecMembers b = b
+
+ -- 'sortRecMembers' runs first, so a 'Rec' is already sorted by 'elemKey'
+ -- when 'bindKey' sees it; its first member is therefore the minimum key.
+ bindKey :: CoreBind -> DumpSortKey
+ bindKey (NonRec b rhs) = elemKey b rhs
+ bindKey (Rec ((b,rhs):_)) = elemKey b rhs
+ bindKey (Rec []) = panic "sortCoreBindingsForDump: empty Rec"
+
+ elemKey :: CoreBndr -> CoreExpr -> DumpSortKey
+ elemKey b rhs = (bucket, line, col, dollar_rank, s, rhsKey rhs)
+ where
+ s = getOccString b
+ (bucket, line, col) = case getSrcSpan b of
+ RealSrcSpan rs _ -> (0, srcSpanStartLine rs, srcSpanStartCol rs)
+ _ -> (1, 0, 0) -- noSrcSpan: sort last
+ -- A '$' anywhere in a tidied top-level OccName marks a compiler-derived
+ -- binder ($wfoo, but also call-site specialisations tidied to
+ -- bar_$sfoo); rank those before their origin within a shared source span,
+ -- mirroring GHC's default dependency order (the wrapper calls the worker,
+ -- so the worker comes first).
+ dollar_rank | '$' `elem` s = 0
+ | otherwise = 1
+
+-- | A content-based tie-break on a binder's right-hand side: see point 4 of
+-- Note [Stable Core dump order].
+type RhsKey =
+ ( Maybe Literal -- the floated literal, if any (Nothing sorts first)
+ , (Int, Int, Int, Int, Int) -- exprStats counts: terms, types, coercions, value binds, join binds
+ )
+
+rhsKey :: CoreExpr -> RhsKey
+rhsKey rhs = (litOf rhs, statsTuple (exprStats rhs))
+ where
+ statsTuple (CS tm ty co vb jb) = (tm, ty, co, vb, jb)
+ litOf (Lit l) = Just l
+ litOf (App f a) = case a of { Lit l -> Just l; _ -> litOf f }
+ litOf (Cast e _) = litOf e
+ litOf (Tick _ e) = litOf e
+ litOf _ = Nothing
+
instance OutputableBndr b => Outputable (Bind b) where
ppr bind = ppr_bind noAnn bind
=====================================
compiler/GHC/Driver/DynFlags.hs
=====================================
@@ -1594,6 +1594,7 @@ initSDocContext dflags style = SDC
, sdocSuppressModulePrefixes = gopt Opt_SuppressModulePrefixes dflags
, sdocSuppressStgExts = gopt Opt_SuppressStgExts dflags
, sdocSuppressStgReps = gopt Opt_SuppressStgReps dflags
+ , sdocStableCoreDumpOrder = gopt Opt_StableCoreDumpOrder dflags
, sdocErrorSpans = gopt Opt_ErrorSpans dflags
, sdocStarIsType = xopt LangExt.StarIsType dflags
, sdocLinearTypes = xopt LangExt.LinearTypes dflags
=====================================
compiler/GHC/Driver/Flags.hs
=====================================
@@ -859,6 +859,10 @@ data GeneralFlag
| Opt_SuppressTimestamps -- ^ Suppress timestamps in dumps
| Opt_SuppressCoreSizes -- ^ Suppress per binding Core size stats in dumps
+ -- | Reorder top-level bindings in Core dumps into a stable, diffable order.
+ -- See Note [Stable Core dump order] in GHC.Core.Ppr.
+ | Opt_StableCoreDumpOrder
+
-- Error message suppression
| Opt_ShowErrorContext
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -2468,6 +2468,7 @@ dFlagsDeps = [
flagSpec "ppr-case-as-let" Opt_PprCaseAsLet,
depFlagSpec' "ppr-ticks" Opt_PprShowTicks
(\turn_on -> useInstead "-d" "suppress-ticks" (not turn_on)),
+ flagSpec "stable-core-dump-order" Opt_StableCoreDumpOrder,
flagSpec "suppress-ticks" Opt_SuppressTicks,
depFlagSpec' "suppress-stg-free-vars" Opt_SuppressStgExts
(useInstead "-d" "suppress-stg-exts"),
=====================================
compiler/GHC/Utils/Outputable.hs
=====================================
@@ -422,6 +422,7 @@ data SDocContext = SDC
, sdocSuppressModulePrefixes :: !Bool
, sdocSuppressStgExts :: !Bool
, sdocSuppressStgReps :: !Bool
+ , sdocStableCoreDumpOrder :: !Bool
, sdocErrorSpans :: !Bool
, sdocStarIsType :: !Bool
, sdocLinearTypes :: !Bool
@@ -490,6 +491,7 @@ defaultSDocContext = SDC
, sdocSuppressModulePrefixes = False
, sdocSuppressStgExts = False
, sdocSuppressStgReps = True
+ , sdocStableCoreDumpOrder = False
, sdocErrorSpans = False
, sdocStarIsType = False
, sdocLinearTypes = False
=====================================
docs/users_guide/debugging.rst
=====================================
@@ -959,6 +959,33 @@ parts that you are not interested in.
has shown you where to look, you can try again without
:ghc-flag:`-dsuppress-uniques`
+.. ghc-flag:: -dstable-core-dump-order
+ :shortdesc: Reorder top-level bindings in Core dumps into a stable,
+ diffable order
+ :type: dynamic
+ :reverse: -dno-stable-core-dump-order
+ :category: verbosity
+
+ :since: 10.2.1
+
+ Normally the order of top-level bindings in a Core dump (such as the
+ output of :ghc-flag:`-ddump-simpl`) reflects the compiler's internal
+ processing order, which depends on ``Unique`` values. Those uniques can
+ shift whenever an unrelated upstream module changes, so the bindings get
+ re-ordered and a textual ``diff`` of two dumps fails to line up the real
+ changes.
+
+ This flag is opt-in and reorders the top-level bindings of Core dumps that
+ go through the pass-result printer (e.g. :ghc-flag:`-ddump-simpl`,
+ :ghc-flag:`-ddump-prep`, :ghc-flag:`-ddump-ds`,
+ :ghc-flag:`-ddump-simpl-iterations`) into a stable, source-location-driven
+ order that does not depend on uniques.
+
+ It is intended to be combined with :ghc-flag:`-dsuppress-uniques` when
+ diffing two dumps, but because the ordering does not depend on uniques the
+ output is also more diffable without it. The default (in-compiler) order is
+ retained because it is useful when debugging the compiler itself.
+
.. ghc-flag:: -dsuppress-idinfo
:shortdesc: Suppress extended information about identifiers where they
are bound
=====================================
hadrian/src/Hadrian/Oracles/Path.hs
=====================================
@@ -1,6 +1,7 @@
{-# LANGUAGE TypeFamilies #-}
module Hadrian.Oracles.Path (
- lookupInPath, fixAbsolutePathOnWindows, pathOracle
+ lookupInPath, fixAbsolutePathOnWindows, fixUnixPathsOnWindows,
+ pathOracle
) where
import Control.Monad
@@ -33,6 +34,14 @@ fixAbsolutePathOnWindows path =
else
return path
+-- | Fix a unix path list on Windows:
+-- * "C:\\foo\\bar;C:\\msys2\\bin" => "/c/foo/bar:/c/msys2/bin"
+fixUnixPathsOnWindows :: FilePath -> Action FilePath
+fixUnixPathsOnWindows paths =
+ if isWindows
+ then askOracle $ UnixPathList paths
+ else return paths
+
newtype LookupInPath = LookupInPath String
deriving (Binary, Eq, Hashable, NFData, Show)
type instance RuleResult LookupInPath = String
@@ -41,6 +50,10 @@ newtype WindowsPath = WindowsPath FilePath
deriving (Binary, Eq, Hashable, NFData, Show)
type instance RuleResult WindowsPath = String
+newtype UnixPathList = UnixPathList FilePath
+ deriving (Binary, Eq, Hashable, NFData, Show)
+type instance RuleResult UnixPathList = String
+
-- | Oracles for looking up paths. These are slow and require caching.
pathOracle :: Rules ()
pathOracle = do
@@ -50,6 +63,12 @@ pathOracle = do
putVerbose $ "| Windows path mapping: " ++ path ++ " => " ++ windowsPath
return windowsPath
+ void $ addOracleCache $ \(UnixPathList paths) -> do
+ Stdout out <- quietly $ cmd ["cygpath", "-p", "-u", paths]
+ let unixPaths = unifyPath $ dropWhileEnd isSpace out
+ putVerbose $ "| Unix path mapping: " ++ paths ++ " => " ++ unixPaths
+ return unixPaths
+
void $ addOracleCache $ \(LookupInPath name) -> do
path <- liftIO getSearchPath
exes <- liftIO (findExecutablesInDirectories path name)
=====================================
hadrian/src/Rules/BinaryDist.hs
=====================================
@@ -3,18 +3,19 @@ module Rules.BinaryDist where
import CommandLine
import Context
+import Data.Either
+import qualified Data.Set as Set
import Expression
+import Hadrian.Oracles.Path (fixUnixPathsOnWindows)
+import Oracles.Flavour
import Oracles.Setting
import Packages
+import Rules.Generate (generateSettings)
import Settings
+import qualified System.Directory.Extra as IO
import Settings.Program (programContext)
import Target
import Utilities
-import qualified System.Directory.Extra as IO
-import Data.Either
-import qualified Data.Set as Set
-import Oracles.Flavour
-import Rules.Generate (generateSettings)
{-
Note [Binary distributions]
@@ -343,7 +344,25 @@ bindistRules = do
ghcRoot <- topDirectory
copyFile (ghcRoot -/- "aclocal.m4") (ghcRoot -/- "distrib" -/- "aclocal.m4")
copyDirectory (ghcRoot -/- "m4") (ghcRoot -/- "distrib")
- buildWithCmdOptions [] $
+
+ -- Note [Autoreconf unix paths from ACLOCAL_PATH]
+ -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ -- On Windows, autoreconf fails when the ACLOCAL_PATH env variable contains Windows-
+ -- style paths. This happens because MSYS2 automatically converts env variables to
+ -- Windows-style paths. To fix this, we convert ACLOCAL_PATH back to Unix style.
+ -- This is done both in the boot Python script and here when building a bindist.
+ win_host <- isWinHost
+ env <- if not win_host
+ then pure []
+ else do
+ aclocalPathMay <- getEnv "ACLOCAL_PATH"
+ case aclocalPathMay of
+ Nothing -> pure []
+ Just aclocalPath -> do
+ unixAclocalPath <- fixUnixPathsOnWindows aclocalPath
+ pure [AddEnv "ACLOCAL_PATH" unixAclocalPath]
+
+ buildWithCmdOptions env $
target (vanillaContext Stage1 ghc) (Autoreconf $ ghcRoot -/- "distrib") [] []
-- We clean after ourselves, moving the configure script we generated in
-- our bindist dir
=====================================
testsuite/driver/runtests.py
=====================================
@@ -133,7 +133,7 @@ if args.unexpected_output_dir:
config.unexpected_output_dir = Path(args.unexpected_output_dir)
if args.only:
- config.only = args.only
+ config.only = set(args.only)
config.run_only_some_tests = True
if args.skip:
=====================================
testsuite/mk/test.mk
=====================================
@@ -109,9 +109,11 @@ endif
HAVE_GDB := $(shell if gdb --version > /dev/null 2> /dev/null; then echo YES; else echo NO; fi)
HAVE_READELF := $(shell if readelf --version > /dev/null 2> /dev/null; then echo YES; else echo NO; fi)
-# we need a better way to find which backend is selected and if --check flag is
-# used
-BIGNUM_GMP := $(shell "$(GHC_PKG)" field ghc-bignum exposed-modules | grep GMP)
+# Detect whether the fast (GMP) bignum backend is in use. The GMP backend module
+# in ghc-internal is hidden, so we look instead for the gmp library it links
+# against: GMP_LIBS adds gmp to ghc-internal's extra-libraries only on a GMP
+# build.
+BIGNUM_GMP := $(shell "$(GHC_PKG)" field ghc-internal extra-libraries 2>/dev/null | grep gmp)
ifeq "$(filter thr, $(GhcRTSWays))" "thr"
RUNTEST_OPTS += -e config.ghc_with_threaded_rts=True
=====================================
testsuite/tests/simplCore/should_compile/Makefile
=====================================
@@ -298,3 +298,36 @@ T17901:
$(RM) -f T17901.o T17901.hi
'$(TEST_HC)' $(TEST_HC_OPTS) -O -c -ddump-simpl -dsuppress-uniques T17901.hs | grep 'wombat'
# All three functions should get their case alternatives combined
+
+# Check -dstable-core-dump-order on a small Data.Map-style module. The
+# sed allow-list prints, deduplicated, the top-level binders we care about in
+# dump order. It inspects names only, so it is insensitive to unrelated
+# Core-format churn.
+#
+# The allow-list covers one binder of each interesting category, so the test
+# exercises the clustering of generated binders next to their origin:
+# * derived instances ($fEqKey/$fOrdKey/$fOrdKey_$ccompare),
+# * a call-site specialisation (findI_$slookupG, from lookupG's SPECIALISE), and
+# * a recursive worker ($wrotate).
+T27296:
+ $(RM) -f T27296.o T27296.hi
+ '$(TEST_HC)' $(TEST_HC_OPTS) -O -c -ddump-simpl -dsuppress-uniques \
+ -dsuppress-idinfo -dsuppress-module-prefixes -dno-typeable-binds \
+ -dstable-core-dump-order T27296.hs 2> /dev/null \
+ | sed -nE 's/^(\$$fEqKey|\$$fOrdKey|\$$fOrdKey_\$$ccompare|size|findI_\$$slookupG|lookupG|member|findI|\$$wrotate|rotate|insertG|insertManyI|insertTwoI|weight|balance|ratios|fromAscI)( .*)?$$/\1/p' \
+ | uniq
+
+# See T27296b.hs for what this pins and why. -ddump-float-out is an untidied
+# dump, so the sed normalises it down to just the bindings: it collapses each
+# pass header to a bare "Float out" separator (dropping the noisy FOS config)
+# and drops the "Result size" and "-- RHS size" lines.
+T27296b:
+ $(RM) -f T27296b.o T27296b.hi
+ '$(TEST_HC)' $(TEST_HC_OPTS) -O -c -ddump-float-out -dsuppress-uniques \
+ -dsuppress-idinfo -dsuppress-module-prefixes -dno-typeable-binds \
+ -dstable-core-dump-order T27296b.hs 2> /dev/null \
+ | sed -E \
+ -e '/^=+ Float out/,/=+$$/c\==================== Float out ====================' \
+ -e '/^Result size of Float out/,/^ = \{terms/d' \
+ -e '/^-- RHS size:/d' \
+ | cat -s
=====================================
testsuite/tests/simplCore/should_compile/T27296.hs
=====================================
@@ -0,0 +1,87 @@
+{-# LANGUAGE BangPatterns #-}
+
+-- See Note [Stable Core dump order] in GHC.Core.Ppr.
+--
+-- A small Data.Map-style module exercising the trickier parts of the stable
+-- dump ordering. Under -O it produces, alongside the user functions:
+-- * derived Eq/Ord instances for a custom Key type ($fEqKey/$fOrdKey/...),
+-- * a call-site specialisation of lookupG (findI_$slookupG), and
+-- * a worker/wrapper split of the recursive, strict rotate ($wrotate).
+-- Each generated binder inherits its origin's source span, so the stable order
+-- clusters it next to that origin. The source order is deliberately neither
+-- alphabetical nor the default dump order (insertG forward-references balance),
+-- so the test pins source-position ordering specifically.
+module T27296
+ ( Key(..), size, lookupG, member, findI, rotate, insertG, insertManyI
+ , insertTwoI, weight, balance, ratios, fromAscI )
+ where
+
+-- A custom key with a derived Ord instance: the derived $fEqKey/$fOrdKey
+-- binders inherit this declaration's source span, so they cluster here.
+data Key = Key Int deriving (Eq, Ord)
+
+data Map k a = Tip | Bin !Int k a !(Map k a) !(Map k a)
+
+data Sizes = Sizes !Int !Int
+
+size :: Map k a -> Int
+size Tip = 0
+size (Bin sz _ _ _ _) = sz
+
+lookupG :: Ord k => k -> Map k a -> Maybe a
+lookupG _ Tip = Nothing
+lookupG k (Bin _ kx x l r) = case compare k kx of
+ LT -> lookupG k l
+ GT -> lookupG k r
+ EQ -> Just x
+{-# SPECIALISE lookupG :: Key -> Map Key a -> Maybe a #-}
+
+member :: Key -> Map Key a -> Bool
+member k m = case lookupG k m of
+ Nothing -> False
+ Just _ -> True
+
+findI :: Key -> Map Key a -> a -> a
+findI k m def = case lookupG k m of
+ Nothing -> def
+ Just v -> v
+
+-- rotate is recursive and strict in the product 'Sizes', so worker/wrapper
+-- unboxes it into a recursive worker ($wrotate). The loop only repackages the
+-- fields (no arithmetic), so the worker is stable across build flavours.
+rotate :: Sizes -> [a] -> Sizes
+rotate s [] = s
+rotate (Sizes a b) (_:xs) = rotate (Sizes b a) xs
+
+-- insertG references 'balance', which is defined further down (forward ref).
+insertG :: Ord k => k -> a -> Map k a -> Map k a
+insertG k x Tip = Bin 1 k x Tip Tip
+insertG k x (Bin sz kx kv l r) = case compare k kx of
+ LT -> balance kx kv (insertG k x l) r
+ GT -> balance kx kv l (insertG k x r)
+ EQ -> Bin sz k x l r
+{-# SPECIALISE insertG :: Key -> a -> Map Key a -> Map Key a #-}
+
+insertManyI :: [(Key, a)] -> Map Key a -> Map Key a
+insertManyI xs m0 = foldr (\(k, x) m -> insertG k x m) m0 xs
+
+insertTwoI :: Key -> Key -> a -> Map Key a
+insertTwoI k1 k2 x = insertG k1 x (insertG k2 x Tip)
+
+-- weight unboxes the strict fields of Sizes -> worker/wrapper $wweight.
+weight :: Sizes -> Int
+weight (Sizes a b) = a * a + 3 * b * b + a * b + 1
+
+balance :: k -> a -> Map k a -> Map k a -> Map k a
+balance k x l r = Bin (weight (Sizes sl sr)) k x l r
+ where
+ sl = size l
+ sr = size r
+
+-- baseRatios is a closed constant under a lambda -> floated to a top-level lvl.
+ratios :: Int -> [Int]
+ratios n = map (n +) baseRatios
+ where baseRatios = [2, 3, 5, 7, 11, 13]
+
+fromAscI :: [(Key, a)] -> Map Key a
+fromAscI = foldr (\(k, x) m -> insertG k x m) Tip
=====================================
testsuite/tests/simplCore/should_compile/T27296.stdout
=====================================
@@ -0,0 +1,17 @@
+$fEqKey
+$fOrdKey
+$fOrdKey_$ccompare
+size
+findI_$slookupG
+lookupG
+member
+findI
+$wrotate
+rotate
+insertG
+insertManyI
+insertTwoI
+weight
+balance
+ratios
+fromAscI
=====================================
testsuite/tests/simplCore/should_compile/T27296b.hs
=====================================
@@ -0,0 +1,21 @@
+-- See Note [Stable Core dump order] in GHC.Core.Ppr.
+--
+-- Companion to T27296 that pins the ordering of *anonymous* top-level floats.
+-- Under -O the boxed Int constants in sel's branches are floated to top level
+-- as separate CAFs, all of which the compiler names "lvl" with noSrcSpan (see
+-- newLvlVar). Before -dstable-core-dump-order their dump order was the
+-- unique-driven processing order; the flag's content-based tie-break (rhsKey)
+-- now orders them by literal value -- here 1000..6000, despite the scrambled
+-- source order. This dump is intentionally *untidied* (-ddump-float-out), the
+-- only place the "lvl" collision is observable; tidied dumps like -ddump-simpl
+-- already give the floats distinct names (lvl, lvl1, ...).
+module T27296b (sel) where
+
+{-# NOINLINE sel #-}
+sel :: Int -> Int
+sel 0 = 5000
+sel 1 = 1000
+sel 2 = 4000
+sel 3 = 2000
+sel 4 = 3000
+sel _ = 6000
=====================================
testsuite/tests/simplCore/should_compile/T27296b.stdout
=====================================
@@ -0,0 +1,54 @@
+
+==================== Float out ====================
+
+sel :: Int -> Int
+sel
+ = \ (ds :: Int) ->
+ case ds of { I# ds ->
+ case ds of {
+ __DEFAULT -> lvl;
+ 0# -> lvl;
+ 1# -> lvl;
+ 2# -> lvl;
+ 3# -> lvl;
+ 4# -> lvl
+ }
+ }
+
+lvl :: Int
+lvl = I# 1000#
+
+lvl :: Int
+lvl = I# 2000#
+
+lvl :: Int
+lvl = I# 3000#
+
+lvl :: Int
+lvl = I# 4000#
+
+lvl :: Int
+lvl = I# 5000#
+
+lvl :: Int
+lvl = I# 6000#
+
+==================== Float out ====================
+
+$wsel :: Int# -> Int#
+$wsel
+ = \ (ww :: Int#) ->
+ case ww of {
+ __DEFAULT -> 6000#;
+ 0# -> 5000#;
+ 1# -> 1000#;
+ 2# -> 4000#;
+ 3# -> 2000#;
+ 4# -> 3000#
+ }
+
+sel :: Int -> Int
+sel
+ = \ (ds :: Int) ->
+ case ds of { I# ww -> case $wsel ww of ww { __DEFAULT -> I# ww } }
+
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -602,3 +602,5 @@ test('T25718b', normal, compile, ['-O -ddump-simpl -dsuppress-uniques -dsuppress
test('T25718c', normal, compile, ['-O -ddump-simpl -dsuppress-uniques -dsuppress-all -dno-typeable-binds'])
test('T19166', normal, compile, ['-O -ddump-simpl -dsuppress-uniques -dsuppress-all -dno-typeable-binds'])
test('T27261', [extra_files(['T27261_aux.hs'])], multimod_compile, ['T27261', '-v0 -O'])
+test('T27296', [], makefile_test, ['T27296'])
+test('T27296b', [], makefile_test, ['T27296b'])
=====================================
utils/check-exact/Main.hs
=====================================
@@ -646,7 +646,7 @@ addLocaLDecl3 :: Changer
addLocaLDecl3 libdir top = do
Right newDecl <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2")
let
- doAddLocal = replaceDecls (anchorEof lp) [parent',d2']
+ doAddLocal = replaceDecls (addModuleCommentOrigDeltas lp) [parent',d2']
where
lp = top
(de1:d2:_) = hsDecls lp
@@ -667,7 +667,7 @@ addLocaLDecl4 libdir lp = do
Right newDecl <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2")
Right newSig <- withDynFlags libdir (\df -> parseDecl df "sig" "nn :: Int")
let
- doAddLocal = replaceDecls (anchorEof lp) (parent':ds)
+ doAddLocal = replaceDecls (addModuleCommentOrigDeltas lp) (parent':ds)
where
(parent:ds) = hsDecls (makeDeltaAst lp)
@@ -781,7 +781,7 @@ rmDecl3 _libdir lp = do
rmDecl4 :: Changer
rmDecl4 _libdir lp = do
let
- doRmDecl = replaceDecls (anchorEof lp) [de1',sd1]
+ doRmDecl = replaceDecls (addModuleCommentOrigDeltas lp) [de1',sd1]
where
[de1] = hsDecls lp
(de1',Just sd1) = modifyValD (getLocA de1) de1 $ \_m [sd1a,sd2] ->
=====================================
utils/check-exact/Transform.hs
=====================================
@@ -65,7 +65,7 @@ module Transform
, balanceComments
, balanceCommentsList
, balanceCommentsListA
- , anchorEof
+ , addModuleCommentOrigDeltas
-- ** Managing lists, pure functions
, captureOrderBinds
@@ -724,8 +724,8 @@ balanceSameLineComments (L la (Match anm mctxt pats (GRHSs x grhss lb)))
-- ---------------------------------------------------------------------
-anchorEof :: ParsedSource -> ParsedSource
-anchorEof (L l m@(HsModule (XModulePs an _lo _ _) _mn _exps _imps _decls)) = L l (m { hsmodExt = (hsmodExt m){ hsmodAnn = an' } })
+addModuleCommentOrigDeltas :: ParsedSource -> ParsedSource
+addModuleCommentOrigDeltas (L l m@(HsModule (XModulePs an _lo _ _) _mn _exps _imps _decls)) = L l (m { hsmodExt = (hsmodExt m){ hsmodAnn = an' } })
where
an' = addCommentOrigDeltasAnn an
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3c83b1d2794a55828567a5b471ea66…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3c83b1d2794a55828567a5b471ea66…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/davide/hadrian_avoid_response_files_2] Hadrian: avoid response files when command line is short enough
by David Eichmann (＠DavidEichmann) 09 Jun '26
by David Eichmann (＠DavidEichmann) 09 Jun '26
09 Jun '26
David Eichmann pushed to branch wip/davide/hadrian_avoid_response_files_2 at Glasgow Haskell Compiler / GHC
Commits:
31fcac5a by David Eichmann at 2026-06-09T09:20:42+01:00
Hadrian: avoid response files when command line is short enough
This replaces the logic of always using response files on Windows.
With the new condition based on command line lenght, reponse files
can be avoided in many more cases (on windows).
Now that response files are only used in a small number of cases,
response files are always kept and the -r / --keep-response-files
command line options have been removed
The response file paths are nolonger randomized. They are placed in the
`_build/rsp` directory. This ensures they are ignored by git and we
that Hadrian reuses response file paths when rebuilding rather than
leaving stale response files around.
Update user guide putting response files in its own section
- - - - -
6 changed files:
- changelog.d/hadrian-response-files.md
- docs/users_guide/using.rst
- hadrian/src/Builder.hs
- hadrian/src/CommandLine.hs
- hadrian/src/Hadrian/Builder/Ar.hs
- hadrian/src/Hadrian/Utilities.hs
Changes:
=====================================
changelog.d/hadrian-response-files.md
=====================================
@@ -1,9 +1,15 @@
section: packaging
-synopsis: Add a flag to tell Hadrian to keep response files
-issues: #27184
-mrs: !15906
+synopsis: Improved Hadrian's use of response files
+issues: #27230
+mrs: !15906 !16134
description:
- Hadrian can now be instructed to keep response files with the new
- --keep-response-files command line flag. This is helpful when debugging a
- build failure, as it allows re-running the failing command line invocation
- without an error due to a missing response file.
+ Response files are files that contain command-line arguments. Hadrian uses
+ response files to shorten command-line lengths. This is important on Windows
+ where command-line lengths are limited.
+
+ Hadrian now supports response files when invoking GHC. In order to support
+ manually rerunning commands issued by Hadrian, response files are no longer
+ deleted. Instead they are stored under `_build/rsp`. Response files are now
+ only used when the corresponding command-line is too long for the host
+ platform. This greatly reduces the use of response files and avoids excessive
+ file usage. Response files are overwritten on subsequent Hadrian builds.
=====================================
docs/users_guide/using.rst
=====================================
@@ -85,17 +85,6 @@ all files; you cannot, for example, invoke
``ghc -c -O1 Foo.hs -O2 Bar.hs`` to apply different optimisation levels
to the files ``Foo.hs`` and ``Bar.hs``.
-In addition to passing arguments via the command-line, arguments can be passed
-via GNU-style response files. For instance,
-
-.. code-block:: bash
-
- $ cat response-file
- -O1
- Hello.hs
- -o Hello
- $ ghc @response-file
-
.. note::
.. index::
@@ -118,9 +107,24 @@ via GNU-style response files. For instance,
``-fspecialise`` will not be enabled, since the ``-fno-specialise``
overrides the ``-fspecialise`` implied by ``-O1``.
+
+Command-line arguments in response files
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+In addition to passing arguments via the command-line, arguments can be passed
+via GNU-style response files. For instance,
+
+.. code-block:: bash
+
+ $ cat response-file
+ -O1
+ Hello.hs
+ -o Hello
+ $ ghc @response-file
+
.. _source-file-options:
-Command line options in source files
+Command-line options in source files
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
.. index::
=====================================
hadrian/src/Builder.hs
=====================================
@@ -304,7 +304,7 @@ instance H.Builder Builder where
case builder of
Ar Pack stg -> do
useTempFile <- arSupportsAtFile stg
- if useTempFile then runAr path buildArgs buildInputs buildOptions
+ if useTempFile then runAr output path buildArgs buildInputs buildOptions
else runArWithoutTempFile path buildArgs buildInputs buildOptions
Ar Unpack _ -> cmd' [Cwd output] [path] buildArgs buildOptions
@@ -343,7 +343,7 @@ instance H.Builder Builder where
Exit _ <- cmd' [path] (buildArgs ++ [input]) buildOptions
return ()
- Haddock BuildPackage -> runHaddock path buildArgs buildInputs
+ Haddock BuildPackage -> runHaddock output path buildArgs buildInputs
Ghc _ _ ->
-- Use a response file for ghc invocations to avoid issues with command line
@@ -351,9 +351,11 @@ instance H.Builder Builder where
-- NB: we can't put the buildArgs in a response file, because some flags require
-- empty arguments (such as the -dep-suffix flag), but that isn't supported
-- yet due to #26560.
- withResponseFileOnWindows
- (\buildInputs' -> cmd [path] buildArgs buildInputs' buildOptions)
+ withResponseFileIfLongCmd
+ output
+ (toCmdArgument [path] <> toCmdArgument buildArgs)
buildInputs
+ (toCmdArgument buildOptions)
HsCpp -> captureStdout
@@ -389,13 +391,16 @@ instance H.Builder Builder where
-- | Invoke @haddock@ given a path to it and a list of arguments. On Windows,
-- the input file arguments are passed as a response file.
-runHaddock :: FilePath -- ^ path to @haddock@
+runHaddock :: FilePath -- ^ base name to use for response file
+ -> FilePath -- ^ path to @haddock@
-> [String]
-> [FilePath] -- ^ input file paths
-> Action ()
-runHaddock haddockPath flagArgs fileInputs = withResponseFileOnWindows
- (cmd [haddockPath] flagArgs)
+runHaddock outputFilePath haddockPath flagArgs fileInputs = withResponseFileIfLongCmd
+ outputFilePath
+ (toCmdArgument [haddockPath] <> toCmdArgument flagArgs)
fileInputs
+ (CmdArgument [])
-- TODO: Some builders are required only on certain platforms. For example,
-- 'Objdump' is only required on OpenBSD and AIX. Add support for platform
=====================================
hadrian/src/CommandLine.hs
=====================================
@@ -3,8 +3,7 @@ module CommandLine (
lookupBignum,
cmdBignum, cmdProgressInfo, cmdCompleteSetting,
cmdDocsArgs, cmdUnitIdHash, lookupBuildRoot, TestArgs(..), TestSpeed(..), defaultTestArgs,
- cmdPrefix, cmdChangelogVersion, DocArgs(..), defaultDocArgs,
- cmdKeepResponseFiles
+ cmdPrefix, cmdChangelogVersion, DocArgs(..), defaultDocArgs
) where
import Data.Either
@@ -12,7 +11,7 @@ import qualified Data.HashMap.Strict as Map
import Data.List.Extra
import Development.Shake hiding (Normal)
import Flavour (DocTargets, DocTarget(..))
-import Hadrian.Utilities hiding (buildRoot, keepResponseFiles)
+import Hadrian.Utilities hiding (buildRoot)
import Settings.Parser
import System.Console.GetOpt
import System.Environment
@@ -37,7 +36,6 @@ data CommandLineArgs = CommandLineArgs
, testArgs :: TestArgs
, docsArgs :: DocArgs
, docTargets :: DocTargets
- , keepResponseFiles :: Bool
, prefix :: Maybe FilePath
, changelogVersion :: Maybe String
, completeStg :: Maybe String }
@@ -58,7 +56,6 @@ defaultCommandLineArgs = CommandLineArgs
, testArgs = defaultTestArgs
, docsArgs = defaultDocArgs
, docTargets = Set.fromList [minBound..maxBound]
- , keepResponseFiles = False
, prefix = Nothing
, changelogVersion = Nothing
, completeStg = Nothing }
@@ -141,9 +138,6 @@ readFreeze1 = Right $ \flags -> flags { freeze1 = True }
readFreeze2 = Right $ \flags -> flags { freeze1 = True, freeze2 = True }
readSkipDepends = Right $ \flags -> flags { skipDepends = True }
-readKeepResponseFiles :: Either String (CommandLineArgs -> CommandLineArgs)
-readKeepResponseFiles = Right $ \flags -> flags { keepResponseFiles = True }
-
readUnitIdHash :: Either String (CommandLineArgs -> CommandLineArgs)
readUnitIdHash = Right $ \flags ->
trace "--hash-unit-ids is deprecated. It is enabled by release flavour or +hash_unit_ids flavour transformer" $
@@ -302,8 +296,6 @@ optDescrs =
"Progress info style (None, Brief, Normal or Unicorn)."
, Option [] ["docs"] (ReqArg readDocsArg "TARGET")
"Strip down docs targets (none, no-haddocks, no-sphinx[-{html, pdfs, man}]."
- , Option ['r'] ["keep-response-files"] (NoArg readKeepResponseFiles)
- "Keep response files created during the build (for debugging)."
, Option ['k'] ["keep-test-files"] (NoArg readTestKeepFiles)
"Keep all the files generated when running the testsuite."
, Option [] ["test-compiler"] (ReqArg readTestCompiler "TEST_COMPILER")
@@ -382,7 +374,6 @@ cmdLineArgsMap = do
return $ insertExtra (progressInfo args) -- Accessed by Hadrian.Utilities
$ insertExtra (buildRoot args) -- Accessed by Hadrian.Utilities
- $ insertExtra (KeepResponseFiles $ keepResponseFiles args) -- Accessed by Hadrian.Utilities
$ insertExtra (testArgs args) -- Accessed by Settings.Builders.RunTest
$ insertExtra (docsArgs args) -- Accessed by Rules.Documentation
$ insertExtra allSettings -- Accessed by Settings
@@ -424,9 +415,6 @@ cmdUnitIdHash = unitIdHash <$> cmdLineArgs
cmdBignum :: Action (Maybe String)
cmdBignum = bignum <$> cmdLineArgs
-cmdKeepResponseFiles :: Action Bool
-cmdKeepResponseFiles = keepResponseFiles <$> cmdLineArgs
-
cmdProgressInfo :: Action ProgressInfo
cmdProgressInfo = progressInfo <$> cmdLineArgs
=====================================
hadrian/src/Hadrian/Builder/Ar.hs
=====================================
@@ -35,14 +35,16 @@ instance NFData ArMode
-- to be archived is passed via a temporary response file. Passing arguments
-- via a response file is not supported by some versions of @ar@, in which
-- case you should use 'runArWithoutTempFile' instead.
-runAr :: FilePath -- ^ path to @ar@
+runAr :: FilePath -- ^ base name to use for response files
+ -> FilePath -- ^ path to @ar@
-> [String] -- ^ other arguments
-> [FilePath] -- ^ input file paths
-> [CmdOption] -- ^ Additional options
-> Action ()
-runAr arPath flagArgs fileArgs buildOptions = withResponseFile $ \tmp -> do
- writeFile' tmp $ unwords fileArgs
- cmd [arPath] flagArgs ('@' : tmp) buildOptions
+runAr outputFilePath arPath flagArgs fileArgs buildOptions = do
+ rspFile <- responseFilePath outputFilePath
+ writeFile' rspFile $ unwords fileArgs
+ cmd [arPath] flagArgs ('@' : rspFile) buildOptions
-- | Invoke @ar@ given a path to it and a list of arguments. Note that @ar@
-- will be called multiple times if the list of files to be archived is too
=====================================
hadrian/src/Hadrian/Utilities.hs
=====================================
@@ -1,4 +1,6 @@
+{-# LANGUAGE ImpredicativeTypes #-}
{-# LANGUAGE TypeFamilies #-}
+
module Hadrian.Utilities (
-- * List manipulation
fromSingleton, replaceEq, minusOrd, intersectOrd, lookupAll, chunksOfSize,
@@ -14,7 +16,7 @@ module Hadrian.Utilities (
-- * Paths
BuildRoot (..), buildRoot, buildRootRules, isGeneratedSource,
- KeepResponseFiles (..), keepResponseFiles, withResponseFile, withResponseFileOnWindows,
+ withResponseFileIfLongCmd, responseFilePath,
-- * File system operations
copyFile, copyFileUntracked, createFileLink, fixFile,
@@ -47,11 +49,10 @@ import Data.Maybe
import Data.Typeable (TypeRep, typeOf)
import Development.Shake hiding (Normal)
import Development.Shake.Classes
+import Development.Shake.Command (CmdArgument (..), IsCmdArgument (toCmdArgument))
import Development.Shake.FilePath
import GHC.ResponseFile (escapeArgs)
import System.Environment (lookupEnv)
-import System.Info.Extra (isWindows)
-import System.IO (hClose, openTempFile)
import System.IO.Error (isPermissionError)
import qualified Data.ByteString as BS
@@ -255,13 +256,13 @@ infix 1 %%>
-- library, they can reach 2MB! Some operating systems do not support command
-- lines of such length, and this function can be used to obtain a reasonable
-- approximation of the limit. On Windows, it is theoretically 32768 characters
--- (since Windows 7). In practice we use 31000 to leave some breathing space for
+-- (since Windows 7). In practice we use 30000 to leave some breathing space for
-- the builder path & name, auxiliary flags, and other overheads. On Mac OS X,
-- ARG_MAX is 262144, yet when using @xargs@ on OSX this is reduced by over
-- 20000. Hence, 200000 seems like a sensible limit. On other operating systems
-- we currently use the 4194304 setting.
cmdLineLengthLimit :: Int
-cmdLineLengthLimit | IO.isWindows = 31000
+cmdLineLengthLimit | IO.isWindows = 30000
| IO.isMac = 200000
| otherwise = 4194304
@@ -321,53 +322,35 @@ buildRootRules = do
isGeneratedSource :: FilePath -> Action Bool
isGeneratedSource file = buildRoot <&> (`isPrefixOf` file)
-newtype KeepResponseFiles = KeepResponseFiles Bool deriving (Eq, Show)
-
--- | Whether to retain response files after the build action that created them
--- completes. Mainly useful for debugging.
-keepResponseFiles :: Action Bool
-keepResponseFiles = do
- KeepResponseFiles keep <- userSetting (KeepResponseFiles False)
- return keep
-
--- | Run an action either with command arguments direcly or by, on Windows,
--- placing those arguments into a response file escaped with @GHC.ResponseFile.escapeArgs@.
---
--- With @--keep-response-files@, the file is left on disk (if used)
-withResponseFileOnWindows ::
- ([String] -> Action a) -- ^ Action to perform given arguments (of the form @["\@reponseFilePath"]@ on Windows)
- -> [String] -- ^ Command arguments
- -> Action a
-withResponseFileOnWindows action commandArgs = do
- if isWindows
- then withResponseFile $ \tmp -> do
- writeFile' tmp (escapeArgs commandArgs)
- action ['@' : tmp]
- else action commandArgs
-
--- | Run an action with a response file path.
---
--- With @--keep-response-files@, the file is left on disk.
-withResponseFile :: (FilePath -> Action a) -> Action a
-withResponseFile action = do
- keep <- keepResponseFiles
- let putVerboseResponseFile tmp = do
- verbosity <- getVerbosity
- when (verbosity >= Verbose) $ do
- tmpContent <- liftIO (readFile tmp)
- putVerbose (tmp <> " (use hadrian flag --keep-response-files to keep this file):\n" <> tmpContent)
- if keep
- then do
- (tmp, h) <- liftIO $ openTempFile "." "hadrian-rsp"
- liftIO $ hClose h
- putInfo $ "Keeping response file: " ++ tmp
- result <- action tmp
- putVerboseResponseFile tmp
- return result
- else withTempFile $ \tmp -> do
- result <- action tmp
- putVerboseResponseFile tmp
- return result
+-- | Run an command with the given arguments. If the command is too long then the
+-- response file arguments are placed into a response file and escaped with @GHC.ResponseFile.escapeArgs@.
+withResponseFileIfLongCmd ::
+ CmdResult c
+ => FilePath -- ^ Response base name. The reponse file is placed in @_build/rsp/\<Response base name\>@.
+ -> CmdArgument -- ^ Command and arguments before the response file arguments.
+ -> [String] -- ^ Response file aruguments.
+ -> CmdArgument -- ^ Command arguments after the response file arguments.
+ -> Action c
+withResponseFileIfLongCmd outputFilePath argsPre argsResp argsPost = do
+ let cmdLineLengh = sum
+ [ 1 + length arg -- add one to account for space inbetween arguments
+ | let CmdArgument args = argsPre <> toCmdArgument argsResp <> argsPost
+ , Right arg <- args
+ ]
+ if cmdLineLengh < cmdLineLengthLimit
+ then cmd argsPre argsResp argsPost
+ else do
+ rspFile <- responseFilePath outputFilePath
+ writeFile' rspFile (escapeArgs argsResp)
+ cmd argsPre ['@' : rspFile] argsPost
+
+-- | Convert a command's output file path to a response file path to be used for that command.
+-- Response files are placed in a dedicated @rps@ directory under the build directory. This avoids
+-- clutering the work tree or interfearing with other build directories.
+responseFilePath :: FilePath -> Action FilePath
+responseFilePath outputFilePath = do
+ buildDir <- buildRoot
+ return $ buildDir </> "rsp" </> outputFilePath
-- | Link a file tracking the link target. Create the target directory if
-- missing.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/31fcac5a3e63d10efb53a5dc174fd0e…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/31fcac5a3e63d10efb53a5dc174fd0e…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/jeltsch/ghc-9-14-building-base] Add installation of GHC 9.14.1
by Wolfgang Jeltsch (＠jeltsch) 09 Jun '26
by Wolfgang Jeltsch (＠jeltsch) 09 Jun '26
09 Jun '26
Wolfgang Jeltsch pushed to branch wip/jeltsch/ghc-9-14-building-base at Glasgow Haskell Compiler / GHC
Commits:
4c6f494e by Wolfgang Jeltsch at 2026-06-08T16:25:20+03:00
Add installation of GHC 9.14.1
- - - - -
1 changed file:
- .gitlab-ci.yml
Changes:
=====================================
.gitlab-ci.yml
=====================================
@@ -1154,15 +1154,23 @@ base-build-with-ghc-914:
- job: release-x86_64-linux-deb13-release
optional: true
dependencies: null
- image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb13:$DOCKER_REV"
+ image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb12:$DOCKER_REV"
tags:
- x86_64-linux
script:
- - printf '%s\n' 'Check for some tools …'
- |
- type ghcup
- type ghc && ghc --version
- type cabal
+ ghc_version=9.14.1
+ url=https://downloads.haskell.org/~ghc/$ghc_version/ghc-$ghc_version-x86_64…
+ curl "$url" >ghc-$ghc_version.tar.xz
+ tar -xJF ghc-$ghc_version.tar.xz
+ cd ghc-$ghc_version
+ ./configure --prefix "$PWD/../ghc"
+ make install
+ cd -
+ printf '%s\n' 'To be continued …'
+ printf '%s\n' 'For now some debug output:'
+ shopt -s globstar
+ ls -l ghc/**/bin
rules:
- *full-ci
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4c6f494e40ad95b5bab2f6c3864ffbf…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4c6f494e40ad95b5bab2f6c3864ffbf…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/az/exactprint-annotation-rationalisation] 2 commits: EPA Remove LocatedLC / LocatedLS
by Alan Zimmerman (＠alanz) 08 Jun '26
by Alan Zimmerman (＠alanz) 08 Jun '26
08 Jun '26
Alan Zimmerman pushed to branch wip/az/exactprint-annotation-rationalisation at Glasgow Haskell Compiler / GHC
Commits:
d18f8202 by Alan Zimmerman at 2026-06-07T22:06:59+01:00
EPA Remove LocatedLC / LocatedLS
LocatedLC/LocatedLS were unused
- - - - -
ce98f3ce by Alan Zimmerman at 2026-06-08T23:15:52+01:00
EPA: Remove LocatedLW from LStmtLR
- - - - -
11 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Parser/Types.hs
- compiler/GHC/Tc/Gen/Match.hs
- testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr
- testsuite/tests/parser/should_compile/DumpSemis.stderr
- utils/check-exact/ExactPrint.hs
- utils/check-exact/Main.hs
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -535,9 +535,6 @@ type instance XPragE (GhcPass _) = NoExtField
type instance XFunRhs = AnnFunRhs
-type instance Anno [LocatedA ((StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr)))))] = SrcSpanAnnLW
-type instance Anno (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) = SrcSpanAnnA
-
mkHsVar :: forall p. IsPass p => LIdP (GhcPass p) -> HsExpr (GhcPass p)
mkHsVar n = HsVar noExtField $
case ghcPass @p of
@@ -2647,8 +2644,10 @@ instance UnXRec p => Outputable (DotFieldOcc p) where
type instance Anno (HsExpr (GhcPass p)) = SrcSpanAnnA
type instance Anno [LocatedA (HsExpr (GhcPass p))] = SrcSpanAnnA
-type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsExpr (GhcPass pr))))] = SrcSpanAnnLW
-type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd (GhcPass pr))))] = SrcSpanAnnLW
+type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsExpr (GhcPass pr))))] = SrcSpanAnnA
+-- type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsExpr (GhcPass pr))))] = SrcSpanAnnLW
+type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd (GhcPass pr))))] = SrcSpanAnnA
+-- type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd (GhcPass pr))))] = SrcSpanAnnLW
type instance Anno (HsCmd (GhcPass p)) = SrcSpanAnnA
@@ -2664,7 +2663,8 @@ type instance Anno (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr
type instance Anno (HsUntypedSplice (GhcPass p)) = SrcSpanAnnA
-type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr))))] = SrcSpanAnnLW
+type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr))))] = SrcSpanAnnA
+-- type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr))))] = SrcSpanAnnLW
type instance Anno (FieldLabelStrings (GhcPass p)) = EpAnnCO
type instance Anno FieldLabelString = SrcSpanAnnN
=====================================
compiler/GHC/Hs/Utils.hs
=====================================
@@ -320,8 +320,10 @@ nlParPat p = noLocA (gParPat p)
mkHsIntegral :: IntegralLit -> HsOverLit GhcPs
mkHsFractional :: FractionalLit -> HsOverLit GhcPs
mkHsIsString :: SourceText -> FastString -> HsOverLit GhcPs
-mkHsDo :: HsDoFlavour -> LocatedLW [ExprLStmt GhcPs] -> HsExpr GhcPs
-mkHsDoAnns :: HsDoFlavour -> LocatedLW [ExprLStmt GhcPs] -> AnnList EpaLocation -> HsExpr GhcPs
+-- mkHsDo :: HsDoFlavour -> LocatedLW [ExprLStmt GhcPs] -> HsExpr GhcPs
+mkHsDo :: HsDoFlavour -> LocatedA [ExprLStmt GhcPs] -> HsExpr GhcPs
+-- mkHsDoAnns :: HsDoFlavour -> LocatedLW [ExprLStmt GhcPs] -> AnnList EpaLocation -> HsExpr GhcPs
+mkHsDoAnns :: HsDoFlavour -> LocatedA [ExprLStmt GhcPs] -> AnnList EpaLocation -> HsExpr GhcPs
mkHsComp :: HsDoFlavour -> [ExprLStmt GhcPs] -> LHsExpr GhcPs
-> HsExpr GhcPs
mkHsCompAnns :: HsDoFlavour -> [ExprLStmt GhcPs] -> LHsExpr GhcPs
@@ -349,12 +351,14 @@ mkTcBindStmt :: LPat GhcTc -> LocatedA (bodyR GhcTc)
emptyRecStmt :: (Anno [GenLocated
(Anno (StmtLR (GhcPass idL) GhcPs bodyR))
(StmtLR (GhcPass idL) GhcPs bodyR)]
- ~ SrcSpanAnnLW)
+ -- ~ SrcSpanAnnLW)
+ ~ SrcSpanAnnA)
=> StmtLR (GhcPass idL) GhcPs bodyR
emptyRecStmtName :: (Anno [GenLocated
(Anno (StmtLR GhcRn GhcRn bodyR))
(StmtLR GhcRn GhcRn bodyR)]
- ~ SrcSpanAnnLW)
+ -- ~ SrcSpanAnnLW)
+ ~ SrcSpanAnnA)
=> StmtLR GhcRn GhcRn bodyR
emptyRecStmtId :: Stmt GhcTc (LocatedA (HsCmd GhcTc))
@@ -362,9 +366,11 @@ mkRecStmt :: forall (idL :: Pass) bodyR.
(Anno [GenLocated
(Anno (StmtLR (GhcPass idL) GhcPs bodyR))
(StmtLR (GhcPass idL) GhcPs bodyR)]
- ~ SrcSpanAnnLW)
+ -- ~ SrcSpanAnnLW)
+ ~ SrcSpanAnnA)
=> AnnList (EpToken "rec")
- -> LocatedLW [LStmtLR (GhcPass idL) GhcPs bodyR]
+ -- -> LocatedLW [LStmtLR (GhcPass idL) GhcPs bodyR]
+ -> LocatedA [LStmtLR (GhcPass idL) GhcPs bodyR]
-> StmtLR (GhcPass idL) GhcPs bodyR
mkRecStmt anns stmts = (emptyRecStmt' anns :: StmtLR (GhcPass idL) GhcPs bodyR)
{ recS_stmts = stmts }
=====================================
compiler/GHC/Parser.y
=====================================
@@ -3144,15 +3144,17 @@ aexp :: { ECP }
return $ ECP $
$2 >>= \ $2 ->
mkHsDoPV (comb2 $1 $2)
+ (stmtlistAnns $2)
(fmap mkModuleNameFS (getDO $1))
- $2
+ (stmtlistStmts $2)
(glR $1)
(glR $2) }
| MDO stmtlist {% hintQualifiedDo $1 >> runPV $2 >>= \ $2 ->
fmap ecpFromExp $
amsA' (L (comb2 $1 $2)
- (mkMDo (MDoExpr $ fmap mkModuleNameFS (getMDO $1))
- $2
+ (mkMDo (stmtlistAnns $2)
+ (MDoExpr $ fmap mkModuleNameFS (getMDO $1))
+ (stmtlistStmts $2)
(glR $1)
(glR $2))) }
| 'proc' aexp '->' exp
@@ -3648,11 +3650,11 @@ apat : aexp {% (checkPattern <=< runPV) (unECP $1) }
-----------------------------------------------------------------------------
-- Statement sequences
-stmtlist :: { forall b. DisambECP b => PV (LocatedLW [LocatedA (Stmt GhcPs (LocatedA b))]) }
+stmtlist :: { forall b. DisambECP b => PV (LocatedA ((EpToken "{", [EpToken ";"], EpToken "}"), [LocatedA (Stmt GhcPs (LocatedA b))])) }
: '{' stmts '}' { $2 >>= \ $2 ->
- amsr (sLL $1 $> (reverse $ snd $ unLoc $2)) (AnnList (stmtsAnchor $2) (ListBraces (epTok $1) (epTok $3)) (fromOL $ fst $ unLoc $2) noAnn []) }
- | vocurly stmts close { $2 >>= \ $2 -> amsr
- (L (stmtsLoc $2) (reverse $ snd $ unLoc $2)) (AnnList (stmtsAnchor $2) ListNone (fromOL $ fst $ unLoc $2) noAnn []) }
+ amsA' (sLL $1 $> ((epTok $1, fromOL $ fst $ unLoc $2, epTok $3), reverse $ snd $ unLoc $2))}
+ | vocurly stmts close { $2 >>= \ $2 ->
+ amsA' (L (stmtsLoc $2) ((NoEpTok, fromOL $ fst $ unLoc $2, NoEpTok), reverse $ snd $ unLoc $2))}
-- do { ;; s ; s ; ; s ;; }
-- The last Stmt should be an expression, but that's hard to enforce
@@ -3694,7 +3696,8 @@ e_stmt :: { LStmt GhcPs (LHsExpr GhcPs) }
stmt :: { forall b. DisambECP b => PV (LStmt GhcPs (LocatedA b)) }
: qual { $1 }
| 'rec' stmtlist { $2 >>= \ $2 ->
- amsA' (sLL $1 $> $ mkRecStmt (hsDoAnn (epTok $1) $2) $2) }
+ amsA' (sLL $1 $> $ mkRecStmt (hsDoAnn (epTok $1) (stmtlistAnns $2) $2)
+ (stmtlistStmts $2)) }
qual :: { forall b. DisambECP b => PV (LStmt GhcPs (LocatedA b)) }
: bindpat '<-' exp { unECP $3 >>= \ $3 ->
@@ -4717,9 +4720,9 @@ commentsPA la@(L l a) = do
!cs <- getPriorCommentsFor (getLocA la)
return (L (addCommentsToEpAnn l cs) a)
-hsDoAnn :: EpToken "rec" -> LocatedAn t b -> AnnList (EpToken "rec")
-hsDoAnn tok (L ll _)
- = AnnList (Just $ spanAsAnchor (locA ll)) ListNone [] tok []
+hsDoAnn :: EpToken "rec" -> (EpToken "{", [EpToken ";"], EpToken "}") -> LocatedAn t b -> AnnList (EpToken "rec")
+hsDoAnn rec (ob, semis, cb) (L ll _)
+ = AnnList (Just $ spanAsAnchor (locA ll)) (ListBraces ob cb) semis rec []
listAsAnchorM :: [LocatedAn t a] -> Maybe EpaLocation
listAsAnchorM [] = Nothing
@@ -4745,6 +4748,16 @@ epExplicitBraces !t1 !t2 = EpExplicitBraces (epTok t1) (epTok t2)
-- -------------------------------------
+stmtlistStmts :: LocatedA (a, [LocatedA (Stmt GhcPs (LocatedA b))])
+ -> LocatedA [LocatedA (Stmt GhcPs (LocatedA b))]
+stmtlistStmts (L la (_,stmts)) = L la stmts
+
+stmtlistAnns :: LocatedA ((EpToken "{", [EpToken ";"], EpToken "}"), a)
+ -> (EpToken "{", [EpToken ";"], EpToken "}")
+stmtlistAnns (L _ (an,_)) = an
+
+-- -------------------------------------
+
addTrailingCommaFBind :: MonadP m => Fbind b -> EpToken "," -> m (Fbind b)
addTrailingCommaFBind (Left b) l = fmap Left (addTrailingCommaA b l)
addTrailingCommaFBind (Right b) l = fmap Right (addTrailingCommaA b l)
=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -28,10 +28,10 @@ module GHC.Parser.Annotation (
-- ** Annotations in 'GenLocated'
LocatedA, LocatedN, LocatedAn, LocatedP,
- LocatedLC, LocatedLS, LocatedLW,
+ LocatedLW,
LocatedE, LocatedBF,
SrcSpanAnnA, SrcSpanAnnP, SrcSpanAnnN,
- SrcSpanAnnLC, SrcSpanAnnLW, SrcSpanAnnLS,
+ SrcSpanAnnLW,
SrcSpanAnnBF,
-- ** Annotation data types used in 'GenLocated'
@@ -432,19 +432,13 @@ emptyComments = EpaComments []
type LocatedA = GenLocated SrcSpanAnnA
type LocatedN = GenLocated SrcSpanAnnN
--- type LocatedL = GenLocated SrcSpanAnnL
-type LocatedLC = GenLocated SrcSpanAnnLC
-type LocatedLS = GenLocated SrcSpanAnnLS
type LocatedLW = GenLocated SrcSpanAnnLW
type LocatedP = GenLocated SrcSpanAnnP
--- type LocatedC = GenLocated SrcSpanAnnC
type LocatedBF = GenLocated SrcSpanAnnBF
type SrcSpanAnnA = EpAnn AnnListItem
type SrcSpanAnnN = EpAnn NameAnn
-type SrcSpanAnnLC = EpAnn (AnnList [EpToken ","])
-type SrcSpanAnnLS = EpAnn (AnnList ())
type SrcSpanAnnLW = EpAnn (AnnList (EpToken "where"))
type SrcSpanAnnP = EpAnn AnnPragma
type SrcSpanAnnBF = EpAnn AnnBooleanFormula
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -436,9 +436,10 @@ mkRoleAnnotDecl loc tycon roles anns
addFatalError $ mkPlainErrorMsgEnvelope loc_role $
(PsErrIllegalRoleName role nearby)
-mkMDo :: HsDoFlavour -> LocatedLW [ExprLStmt GhcPs] -> EpaLocation -> EpaLocation -> HsExpr GhcPs
-mkMDo ctxt stmts tok loc
- = mkHsDoAnns ctxt stmts (AnnList (Just loc) ListNone [] tok [])
+-- mkMDo :: HsDoFlavour -> LocatedLW [ExprLStmt GhcPs] -> EpaLocation -> EpaLocation -> HsExpr GhcPs
+mkMDo :: (EpToken "{", [EpToken ";"], EpToken "}") -> HsDoFlavour -> LocatedA [ExprLStmt GhcPs] -> EpaLocation -> EpaLocation -> HsExpr GhcPs
+mkMDo (ob, semis, cb) ctxt stmts tok loc
+ = mkHsDoAnns ctxt stmts (AnnList (Just loc) (ListBraces ob cb) semis tok [])
-- | Converts a list of 'LHsTyVarBndr's annotated with their 'Specificity' to
-- binders without annotations. Only accepts specified variables, and errors if
@@ -1733,7 +1734,8 @@ type AnnoBody b
, Anno (Match GhcPs (LocatedA (Body b GhcPs))) ~ SrcSpanAnnA
, Anno (StmtLR GhcPs GhcPs (LocatedA (Body (Body b GhcPs) GhcPs))) ~ SrcSpanAnnA
, Anno [LocatedA (StmtLR GhcPs GhcPs
- (LocatedA (Body (Body (Body b GhcPs) GhcPs) GhcPs)))] ~ SrcSpanAnnLW
+ -- (LocatedA (Body (Body (Body b GhcPs) GhcPs) GhcPs)))] ~ SrcSpanAnnLW
+ (LocatedA (Body (Body (Body b GhcPs) GhcPs) GhcPs)))] ~ SrcSpanAnnA
)
-- | Disambiguate constructs that may appear when we do not know ahead of time whether we are
@@ -1795,8 +1797,10 @@ class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where
-- | Disambiguate "do { ... }" (do notation)
mkHsDoPV ::
SrcSpan ->
+ (EpToken "{", [EpToken ";"], EpToken "}") ->
Maybe ModuleName ->
- LocatedLW [LStmt GhcPs (LocatedA b)] ->
+ -- LocatedLW [LStmt GhcPs (LocatedA b)] ->
+ LocatedA [LStmt GhcPs (LocatedA b)] ->
EpaLocation -> -- Token
EpaLocation -> -- Anchor
PV (LocatedA b)
@@ -1948,10 +1952,10 @@ instance DisambECP (HsCmd GhcPs) where
checkDoAndIfThenElse PsErrSemiColonsInCondCmd c semi1 a semi2 b
!cs <- getCommentsFor l
return $ L (EpAnn (spanAsAnchor l) noAnn cs) (mkHsCmdIf c a b anns)
- mkHsDoPV l Nothing stmts tok_loc anc = do
+ mkHsDoPV l (ob,semis,cb) Nothing stmts tok_loc anc = do
!cs <- getCommentsFor l
- return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdDo (AnnList (Just anc) ListNone [] tok_loc []) stmts)
- mkHsDoPV l (Just m) _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrQualifiedDoInCmd m
+ return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdDo (AnnList (Just anc) (ListBraces ob cb) semis tok_loc []) stmts)
+ mkHsDoPV l _ (Just m) _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrQualifiedDoInCmd m
mkHsParPV l lpar c rpar = do
!cs <- getCommentsFor l
return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdPar (lpar, rpar) c)
@@ -2047,9 +2051,9 @@ instance DisambECP (HsExpr GhcPs) where
checkDoAndIfThenElse PsErrSemiColonsInCondExpr c semi1 a semi2 b
!cs <- getCommentsFor l
return $ L (EpAnn (spanAsAnchor l) noAnn cs) (mkHsIf c a b anns)
- mkHsDoPV l mod stmts loc_tok anc = do
+ mkHsDoPV l (ob,semis,cb) mod stmts loc_tok anc = do
!cs <- getCommentsFor l
- return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsDo (AnnList (Just anc) ListNone [] loc_tok []) (DoExpr mod) stmts)
+ return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsDo (AnnList (Just anc) (ListBraces ob cb) semis loc_tok []) (DoExpr mod) stmts)
mkHsParPV l lpar e rpar = do
!cs <- getCommentsFor l
return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsPar (lpar, rpar) e)
@@ -2145,7 +2149,7 @@ instance DisambECP (PatBuilder GhcPs) where
!cs <- getCommentsFor (locA l)
return $ L (addCommentsToEpAnn l cs) (PatBuilderAppType p at (mkHsTyPat t))
mkHsIfPV l _ _ _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrIfThenElseInPat
- mkHsDoPV l _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrDoNotationInPat
+ mkHsDoPV l _ _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrDoNotationInPat
mkHsParPV l lpar p rpar = return $ L (noAnnSrcSpan l) (PatBuilderPar lpar p rpar)
mkHsVarPV v@(getLoc -> l) = return $ L (l2l l) (PatBuilderVar v)
mkHsLitPV lit@(L l a) = do
=====================================
compiler/GHC/Parser/Types.hs
=====================================
@@ -110,7 +110,8 @@ instance Outputable DataConBuilder where
ppr (InfixDataConBuilder lhs data_con rhs) =
ppr lhs <+> ppr data_con <+> ppr rhs
-type instance Anno [LocatedA (StmtLR GhcPs GhcPs (LocatedA (PatBuilder GhcPs)))] = SrcSpanAnnLW
+-- type instance Anno [LocatedA (StmtLR GhcPs GhcPs (LocatedA (PatBuilder GhcPs)))] = SrcSpanAnnLW
+type instance Anno [LocatedA (StmtLR GhcPs GhcPs (LocatedA (PatBuilder GhcPs)))] = SrcSpanAnnA
data ExplicitNamespaceKeyword
= ExplicitTypeNamespace !(EpToken "type")
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -376,7 +376,8 @@ tcGRHSNE ctxt tc_body grhss res_ty
-}
tcDoStmts :: HsDoFlavour
- -> LocatedLW [LStmt GhcRn (LHsExpr GhcRn)]
+ -- -> LocatedLW [LStmt GhcRn (LHsExpr GhcRn)]
+ -> LocatedA [LStmt GhcRn (LHsExpr GhcRn)]
-> ExpRhoType
-> TcM (HsExpr GhcTc) -- Returns a HsDo
tcDoStmts ListComp (L l stmts) res_ty
=====================================
testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr
=====================================
@@ -287,7 +287,9 @@
(AnnList
(Just
(EpaSpan { DumpParsedAstComments.hs:16:3 }))
- (ListNone)
+ (ListBraces
+ (NoEpTok)
+ (NoEpTok))
[]
(EpaSpan { DumpParsedAstComments.hs:14:7-8 })
[])
@@ -296,12 +298,7 @@
(L
(EpAnn
(EpaSpan { DumpParsedAstComments.hs:16:3 })
- (AnnList
- (Just
- (EpaSpan { DumpParsedAstComments.hs:16:3 }))
- (ListNone)
- []
- (NoEpTok)
+ (AnnListItem
[])
(EpaComments
[]))
=====================================
testsuite/tests/parser/should_compile/DumpSemis.stderr
=====================================
@@ -337,7 +337,9 @@
(AnnList
(Just
(EpaSpan { DumpSemis.hs:(11,3)-(12,3) }))
- (ListNone)
+ (ListBraces
+ (NoEpTok)
+ (NoEpTok))
[]
(EpaSpan { DumpSemis.hs:10:7-8 })
[])
@@ -346,12 +348,7 @@
(L
(EpAnn
(EpaSpan { DumpSemis.hs:(11,3)-(12,3) })
- (AnnList
- (Just
- (EpaSpan { DumpSemis.hs:(11,3)-(12,3) }))
- (ListNone)
- []
- (NoEpTok)
+ (AnnListItem
[])
(EpaComments
[]))
@@ -375,8 +372,17 @@
(AnnList
(Just
(EpaSpan { DumpSemis.hs:11:6-15 }))
- (ListNone)
- []
+ (ListBraces
+ (EpTok (EpaSpan { DumpSemis.hs:11:6 }))
+ (EpTok (EpaSpan { DumpSemis.hs:11:15 })))
+ [(EpTok
+ (EpaSpan { DumpSemis.hs:11:8 }))
+ ,(EpTok
+ (EpaSpan { DumpSemis.hs:11:9 }))
+ ,(EpTok
+ (EpaSpan { DumpSemis.hs:11:10 }))
+ ,(EpTok
+ (EpaSpan { DumpSemis.hs:11:11 }))]
(EpaSpan { DumpSemis.hs:11:3-4 })
[])
(DoExpr
@@ -384,21 +390,7 @@
(L
(EpAnn
(EpaSpan { DumpSemis.hs:11:6-15 })
- (AnnList
- (Just
- (EpaSpan { DumpSemis.hs:11:8-13 }))
- (ListBraces
- (EpTok (EpaSpan { DumpSemis.hs:11:6 }))
- (EpTok (EpaSpan { DumpSemis.hs:11:15 })))
- [(EpTok
- (EpaSpan { DumpSemis.hs:11:8 }))
- ,(EpTok
- (EpaSpan { DumpSemis.hs:11:9 }))
- ,(EpTok
- (EpaSpan { DumpSemis.hs:11:10 }))
- ,(EpTok
- (EpaSpan { DumpSemis.hs:11:11 }))]
- (NoEpTok)
+ (AnnListItem
[])
(EpaComments
[]))
@@ -649,8 +641,13 @@
(AnnList
(Just
(EpaSpan { DumpSemis.hs:(16,3)-(19,3) }))
- (ListNone)
- []
+ (ListBraces
+ (EpTok (EpaSpan { DumpSemis.hs:16:3 }))
+ (EpTok (EpaSpan { DumpSemis.hs:19:3 })))
+ [(EpTok
+ (EpaSpan { DumpSemis.hs:16:5 }))
+ ,(EpTok
+ (EpaSpan { DumpSemis.hs:16:8 }))]
(EpaSpan { DumpSemis.hs:15:7-8 })
[])
(DoExpr
@@ -658,17 +655,7 @@
(L
(EpAnn
(EpaSpan { DumpSemis.hs:(16,3)-(19,3) })
- (AnnList
- (Just
- (EpaSpan { DumpSemis.hs:(16,5)-(18,5) }))
- (ListBraces
- (EpTok (EpaSpan { DumpSemis.hs:16:3 }))
- (EpTok (EpaSpan { DumpSemis.hs:19:3 })))
- [(EpTok
- (EpaSpan { DumpSemis.hs:16:5 }))
- ,(EpTok
- (EpaSpan { DumpSemis.hs:16:8 }))]
- (NoEpTok)
+ (AnnListItem
[])
(EpaComments
[]))
@@ -913,8 +900,13 @@
(AnnList
(Just
(EpaSpan { DumpSemis.hs:22:10-30 }))
- (ListNone)
- []
+ (ListBraces
+ (EpTok (EpaSpan { DumpSemis.hs:22:10 }))
+ (EpTok (EpaSpan { DumpSemis.hs:22:30 })))
+ [(EpTok
+ (EpaSpan { DumpSemis.hs:22:12 }))
+ ,(EpTok
+ (EpaSpan { DumpSemis.hs:22:13 }))]
(EpaSpan { DumpSemis.hs:22:7-8 })
[])
(DoExpr
@@ -922,17 +914,7 @@
(L
(EpAnn
(EpaSpan { DumpSemis.hs:22:10-30 })
- (AnnList
- (Just
- (EpaSpan { DumpSemis.hs:22:12-28 }))
- (ListBraces
- (EpTok (EpaSpan { DumpSemis.hs:22:10 }))
- (EpTok (EpaSpan { DumpSemis.hs:22:30 })))
- [(EpTok
- (EpaSpan { DumpSemis.hs:22:12 }))
- ,(EpTok
- (EpaSpan { DumpSemis.hs:22:13 }))]
- (NoEpTok)
+ (AnnListItem
[])
(EpaComments
[]))
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -1447,10 +1447,14 @@ instance (ExactPrint a) => ExactPrint (LocatedAn NoEpAnns a) where
a' <- markAnnotated a
return (L la a')
-instance (ExactPrint a) => ExactPrint [a] where
- getAnnotationEntry = const NoEntryVal
- setAnnotationAnchor ls _ _ _ = ls
- exact ls = mapM markAnnotated ls
+-- ---------------------------------------------------------------------
+
+-- instance (ExactPrint a) => ExactPrint [a] where
+-- getAnnotationEntry = const NoEntryVal
+-- setAnnotationAnchor ls _ _ _ = ls
+-- exact ls = mapM markAnnotated ls
+
+-- ---------------------------------------------------------------------
instance (ExactPrint a) => ExactPrint (Maybe a) where
getAnnotationEntry = const NoEntryVal
@@ -1489,7 +1493,7 @@ instance ExactPrint (HsModule GhcPs) where
Just exps -> do
let (op,cp,tcs) = am_exports $ anns an0
op' <- markEpToken op
- exps' <- markAnnotated exps
+ exps' <- mapM markAnnotated exps
tcs' <- mapM markEpToken tcs
cp' <- markEpToken cp
return (Just exps', an0 { anns = (anns an0) { am_exports = (op',cp',tcs')}})
@@ -1570,7 +1574,7 @@ instance ExactPrint (LocatedP (WarningTxt GhcPs)) where
o' <- markAnnOpen'' o src "{-# WARNING"
mb_cat' <- markAnnotated mb_cat
os' <- markEpToken os
- ws' <- markAnnotated ws
+ ws' <- mapM markAnnotated ws
cs' <- markEpToken cs
c' <- markEpToken c
return (L (EpAnn l (AnnPragma o' c' (os',cs') l1 l2 t m) css) (WarningTxt src mb_cat' ws'))
@@ -1578,7 +1582,7 @@ instance ExactPrint (LocatedP (WarningTxt GhcPs)) where
exact (L (EpAnn l (AnnPragma o c (os,cs) l1 l2 t m) css) (DeprecatedTxt src ws)) = do
o' <- markAnnOpen'' o src "{-# DEPRECATED"
os' <- markEpToken os
- ws' <- markAnnotated ws
+ ws' <- mapM markAnnotated ws
cs' <- markEpToken cs
c' <- markEpToken c
return (L (EpAnn l (AnnPragma o' c' (os',cs') l1 l2 t m) css) (DeprecatedTxt src ws'))
@@ -1706,7 +1710,7 @@ instance ExactPrint HsDocString where
pe <- getPriorEndD
debugM $ "MultiLineDocString: (pe,x)=" ++ showAst (pe,x)
x' <- markAnnotated x
- xs' <- markAnnotated (map dedentDocChunk xs)
+ xs' <- mapM markAnnotated (map dedentDocChunk xs)
return (MultiLineDocString decorator (x' :| xs'))
exact x = do
-- TODO: can this happen?
@@ -1929,7 +1933,7 @@ instance ExactPrint (WarnDecls GhcPs) where
exact (Warnings ((o,c),src) warns) = do
o' <- markAnnOpen'' o src "{-# WARNING" -- Note: might be {-# DEPRECATED
- warns' <- markAnnotated warns
+ warns' <- mapM markAnnotated warns
c' <- markEpToken c
return (Warnings ((o',c'),src) warns')
@@ -1942,17 +1946,17 @@ instance ExactPrint (WarnDecl GhcPs) where
exact (Warning (o,c) ns_spec lns (WarningTxt src mb_cat ls )) = do
mb_cat' <- markAnnotated mb_cat
ns_spec' <- exactNsSpec ns_spec
- lns' <- markAnnotated lns
+ lns' <- mapM markAnnotated lns
o' <- markEpToken o
- ls' <- markAnnotated ls
+ ls' <- mapM markAnnotated ls
c' <- markEpToken c
return (Warning (o',c') ns_spec' lns' (WarningTxt src mb_cat' ls'))
exact (Warning (o,c) ns_spec lns (DeprecatedTxt src ls)) = do
ns_spec' <- exactNsSpec ns_spec
- lns' <- markAnnotated lns
+ lns' <- mapM markAnnotated lns
o' <- markEpToken o
- ls' <- markAnnotated ls
+ ls' <- mapM markAnnotated ls
c' <- markEpToken c
return (Warning (o',c') ns_spec' lns' (DeprecatedTxt src ls'))
@@ -1996,7 +2000,7 @@ instance ExactPrint (RuleDecls GhcPs) where
case src of
NoSourceText -> printStringAtAA o "{-# RULES"
SourceText srcTxt -> printStringAtAA o (unpackFS srcTxt)
- rules' <- markAnnotated rules
+ rules' <- mapM markAnnotated rules
c' <- markEpToken c
return (HsRules ((o',c'),src) rules')
@@ -2188,7 +2192,7 @@ exactHsFamInstLHS ops cps thing bndrs typats fixity mb_ctxt = do
exact_pats ops0 cps0 pats = do
ops' <- mapM markEpToken ops0
thing' <- markAnnotated thing
- pats' <- markAnnotated pats
+ pats' <- mapM markAnnotated pats
cps' <- mapM markEpToken cps0
return (ops', cps', thing', pats')
@@ -2318,7 +2322,7 @@ instance ExactPrint (HsBind GhcPs) where
return (FunBind x fun_id' matches')
exact (PatBind x pat q grhss) = do
- q' <- markAnnotated q
+ q' <- mapM markAnnotated q
pat' <- markAnnotated pat
grhss' <- markAnnotated grhss
return (PatBind x pat' q' grhss')
@@ -2348,12 +2352,12 @@ instance ExactPrint (PatSynBind GhcPs GhcPs) where
return (psyn', InfixCon x v1' v2')
PrefixCon x vs -> do
psyn' <- markAnnotated psyn
- vs' <- markAnnotated vs
+ vs' <- mapM markAnnotated vs
return (psyn', PrefixCon x vs')
RecCon (ao,ac) vs -> do
psyn' <- markAnnotated psyn
ao' <- markEpToken ao
- vs' <- markAnnotated vs
+ vs' <- mapM markAnnotated vs
ac' <- markEpToken ac
return (psyn', RecCon (ao',ac') vs')
@@ -2424,7 +2428,7 @@ exactMatch (Match an mctxt pats grhss) = do
epTokensToComments "(" opens
epTokensToComments ")" closes
fun' <- markAnnotated fun
- pats' <- markAnnotated pats
+ pats' <- (mapM . mapM) markAnnotated pats
return (FunRhs fun' fixity strictness (AnnFunRhs strict' [] []), pats')
Infix ->
case pats of
@@ -2445,11 +2449,11 @@ exactMatch (Match an mctxt pats grhss) = do
_ -> panic "FunRhs"
LamAlt v -> do
- pats' <- markAnnotated pats
+ pats' <- (mapM . mapM) markAnnotated pats
return (LamAlt v, pats')
CaseAlt -> do
- pats' <- markAnnotated pats
+ pats' <- (mapM . mapM) markAnnotated pats
return (CaseAlt, pats')
_ -> do
@@ -2548,7 +2552,7 @@ instance ExactPrint (HsIPBinds GhcPs) where
setAnnotationAnchor a _ _ _ = a
exact (IPBinds x binds) = setLayoutBoth $ do
- binds' <- markAnnotated binds
+ binds' <- mapM markAnnotated binds
return (IPBinds x binds')
-- ---------------------------------------------------------------------
@@ -2617,13 +2621,13 @@ instance ExactPrint (Sig GhcPs) where
setAnnotationAnchor a _ _ _ = a
exact (TypeSig (AnnSig dc mp md) mods vars ty) = do
- mods' <- markAnnotated mods
+ mods' <- mapM markAnnotated mods
(dc', vars', ty') <- exactVarSig dc vars ty
return (TypeSig (AnnSig dc' mp md) mods' vars' ty')
exact (PatSynSig (AnnSig dc mp md) lns typ) = do
mp' <- mapM markEpToken mp
- lns' <- markAnnotated lns
+ lns' <- mapM markAnnotated lns
dc' <- markEpUniToken dc
typ' <- markAnnotated typ
return (PatSynSig (AnnSig dc' mp' md) lns' typ')
@@ -2645,7 +2649,7 @@ instance ExactPrint (Sig GhcPs) where
af' <- printStringAtAA af fixstr
ma' <- mapM (\l -> printStringAtAA l (sourceTextToString src (show v))) ma
ns' <- markAnnotated ns
- names' <- markAnnotated names
+ names' <- mapM markAnnotated names
return (FixSig ((af',ma'),src) (FixitySig noExtField ns' names' (Fixity v fdir)))
exact (InlineSig (o,c,act) ln inl) = do
@@ -2660,7 +2664,7 @@ instance ExactPrint (Sig GhcPs) where
act' <- markActivation act (inlinePragmaActivation inl)
ln' <- markAnnotated ln
dc' <- traverse markEpUniToken dc
- typs' <- markAnnotated typs
+ typs' <- mapM markAnnotated typs
c' <- markEpToken c
return (SpecSig (AnnSpecSig o' c' dc' act') ln' typs' inl)
@@ -2749,11 +2753,11 @@ instance ExactPrint (DefaultDecl GhcPs) where
setAnnotationAnchor a _ _ _ = a
exact (DefaultDecl (d,op,cp) mods cl tys) = do
- mods' <- markAnnotated mods
+ mods' <- mapM markAnnotated mods
d' <- markEpToken d
cl' <- markAnnotated cl
op' <- markEpToken op
- tys' <- markAnnotated tys
+ tys' <- mapM markAnnotated tys
cp' <- markEpToken cp
return (DefaultDecl (d',op',cp') mods' cl' tys')
@@ -2792,10 +2796,10 @@ instance ExactPrint (BF.BooleanFormula GhcPs) where
x' <- markAnnotated x
return (BF.Var x')
exact (BF.Or ls) = do
- ls' <- markAnnotated ls
+ ls' <- mapM markAnnotated ls
return (BF.Or ls')
exact (BF.And ls) = do
- ls' <- markAnnotated ls
+ ls' <- mapM markAnnotated ls
return (BF.And ls')
exact (BF.Parens x) = do
x' <- markAnnotated x
@@ -2992,13 +2996,13 @@ instance ExactPrint (HsExpr GhcPs) where
exact (HsDo an do_or_list_comp stmts) = do
debugM $ "HsDo"
- (an',stmts') <- markAnnListA' an $ \a -> exactDo a do_or_list_comp stmts
+ (an',stmts') <- markAnnListA' an0 $ \a -> exactDo a do_or_list_comp stmts
return (HsDo an' do_or_list_comp stmts')
exact (ExplicitList an es) = do
debugM $ "ExplicitList start"
an0 <- markLensBracketsO' an lal_brackets
- es' <- markAnnotated es
+ es' <- mapM markAnnotated es
an1 <- markLensBracketsC' an0 lal_brackets
debugM $ "ExplicitList end"
return (ExplicitList an1 es')
@@ -3081,7 +3085,7 @@ instance ExactPrint (HsExpr GhcPs) where
exact (HsUntypedBracket a (DecBrL (o,c, (oc,cc)) e)) = do
o' <- markEpToken o
oc' <- markEpToken oc
- e' <- markAnnotated e
+ e' <- mapM markAnnotated e
cc' <- markEpToken cc
c' <- markEpUniToken c
return (HsUntypedBracket a (DecBrL (o',c',(oc',cc')) e'))
@@ -3151,7 +3155,7 @@ instance ExactPrint (HsExpr GhcPs) where
exact (HsQual (op,cp,da) ctxt body) = do
op' <- mapM markEpToken op
- ctxt' <- markAnnotated ctxt
+ ctxt' <- mapM markAnnotated ctxt
cp' <- mapM markEpToken cp
da' <- markEpUniToken da
body' <- markAnnotated body
@@ -3277,7 +3281,7 @@ instance (ExactPrint body) => ExactPrint (HsRecFields GhcPs body) where
setAnnotationAnchor a _ _ _ = a
exact (HsRecFields (oc,cc) fields mdot) = do
oc' <- markEpToken oc
- fields' <- markAnnotated fields
+ fields' <- mapM markAnnotated fields
mdot' <- case mdot of
Nothing -> return Nothing
Just (L ss d) -> do
@@ -3329,11 +3333,11 @@ instance ExactPrint (LHsRecUpdFields GhcPs) where
exact flds@(RegularRecUpdFields { recUpdFields = rbinds }) = do
debugM $ "RegularRecUpdFields"
- rbinds' <- markAnnotated rbinds
+ rbinds' <- mapM markAnnotated rbinds
return $ flds { recUpdFields = rbinds' }
exact flds@(OverloadedRecUpdFields { olRecUpdFields = pbinds }) = do
debugM $ "OverloadedRecUpdFields"
- pbinds' <- markAnnotated pbinds
+ pbinds' <- mapM markAnnotated pbinds
return $ flds { olRecUpdFields = pbinds' }
-- ---------------------------------------------------------------------
@@ -3419,11 +3423,11 @@ instance ExactPrint (HsCmd GhcPs) where
(Infix, (arg1:argrest)) -> do
arg1' <- markAnnotated arg1
e' <- markAnnotated e
- argrest' <- markAnnotated argrest
+ argrest' <- mapM markAnnotated argrest
return (e', arg1':argrest')
(Prefix, _) -> do
e' <- markAnnotated e
- cs' <- markAnnotated cs
+ cs' <- mapM markAnnotated cs
return (e', cs')
(Infix, []) -> error "Not possible"
an1 <- markLensBracketsC' an0 lal_brackets
@@ -3475,19 +3479,24 @@ instance ExactPrint (HsCmd GhcPs) where
e' <- markAnnotated e
return (HsCmdLet (tkLet', tkIn') binds' e')
- exact (HsCmdDo an es) = do
+ exact (HsCmdDo an (L l es)) = do
debugM $ "HsCmdDo"
- an0 <- markLensFun an lal_rest (\l -> printStringAtAA l "do")
- es' <- markAnnotated es
- return (HsCmdDo an0 es')
+ an0 <- markLensFun an lal_rest (\ll -> printStringAtAA ll "do")
+ (an1,es') <- markAnnList' an0 $ do
+ ee <- mapM markAnnotated es
+ return ee
+ -- es' <- mapM markAnnotated es
+ return (HsCmdDo an1 (L l es'))
-- ---------------------------------------------------------------------
instance (
ExactPrint (LocatedA (body GhcPs)),
Anno (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))) ~ SrcSpanAnnA,
- Anno [GenLocated SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))] ~ SrcSpanAnnLW,
- (ExactPrint (LocatedLW [LocatedA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))])))
+ -- Anno [GenLocated SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))] ~ SrcSpanAnnLW,
+ Anno [GenLocated SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))] ~ SrcSpanAnnA,
+ -- (ExactPrint (LocatedLW [LocatedA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))])))
+ (ExactPrint (LocatedA [LocatedA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))])))
=> ExactPrint (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))) where
getAnnotationEntry _ = NoEntryVal
setAnnotationAnchor a _ _ _s = a
@@ -3657,7 +3666,7 @@ instance ExactPrint (TyClDecl GhcPs) where
tcdModifiers = mods'})
where
top_matter = do
- mods' <- markAnnotated mods
+ mods' <- mapM markAnnotated mods
epTokensToComments "(" ops
epTokensToComments ")" cps
c' <- markEpToken c
@@ -3666,7 +3675,7 @@ instance ExactPrint (TyClDecl GhcPs) where
then return (vb, fds)
else do
vb' <- markEpToken vb
- fds' <- markAnnotated fds
+ fds' <- mapM markAnnotated fds
return (vb', fds')
w' <- markEpToken w
return (mods', c', w', vb', fds', lclas', tyvars',context')
@@ -3679,9 +3688,9 @@ instance ExactPrint (FunDep GhcPs) where
setAnnotationAnchor a _ _ _ = a
exact (FunDep an ls rs') = do
- ls' <- markAnnotated ls
+ ls' <- mapM markAnnotated ls
an0 <- markEpUniToken an
- rs'' <- markAnnotated rs'
+ rs'' <- mapM markAnnotated rs'
return (FunDep an0 ls' rs'')
-- ---------------------------------------------------------------------
@@ -3723,7 +3732,7 @@ instance ExactPrint (FamilyDecl GhcPs) where
dd' <- markEpToken dd
return (dd', mb_eqns)
Just eqns -> do
- eqns' <- markAnnotated eqns
+ eqns' <- mapM markAnnotated eqns
return (dd, Just eqns')
cc' <- markEpToken cc
return (w',oc',dd',cc', ClosedTypeFamily mb_eqns')
@@ -3844,12 +3853,12 @@ exactVanillaDeclHead thing tvs@(HsQTvs { hsq_explicit = tyvars }) fixity context
varl' <- markAnnotated varl
thing' <- markAnnotated thing
hvarsr' <- markAnnotated hvarsr
- tvarsr' <- markAnnotated tvarsr
+ tvarsr' <- mapM markAnnotated tvarsr
return (thing', varl':hvarsr':tvarsr')
| fixity == Infix = do
varl' <- markAnnotated varl
thing' <- markAnnotated thing
- varsr' <- markAnnotated varsr
+ varsr' <- mapM markAnnotated varsr
return (thing', varl':varsr')
| otherwise = do
thing' <- markAnnotated thing
@@ -3984,12 +3993,12 @@ instance ExactPrint (HsType GhcPs) where
return (HsListTy (o',c') t')
exact (HsTupleTy an con tys) = do
an0 <- markOpeningParen an
- tys' <- markAnnotated tys
+ tys' <- mapM markAnnotated tys
an1 <- markClosingParen an0
return (HsTupleTy an1 con tys')
exact (HsSumTy an tys) = do
an0 <- markOpeningParen an
- tys' <- markAnnotated tys
+ tys' <- mapM markAnnotated tys
an1 <- markClosingParen an0
return (HsSumTy an1 tys')
exact (HsOpTy x t1 lo t2) = do
@@ -4030,7 +4039,7 @@ instance ExactPrint (HsType GhcPs) where
then markEpToken sq
else return sq
o' <- markEpToken o
- tys' <- markAnnotated tys
+ tys' <- mapM markAnnotated tys
c' <- markEpToken c
return (HsExplicitListTy (sq',o',c') prom tys')
exact (HsExplicitTupleTy (sq, an) prom tys) = do
@@ -4038,7 +4047,7 @@ instance ExactPrint (HsType GhcPs) where
then markEpToken sq
else return sq
an0 <- markOpeningParen an
- tys' <- markAnnotated tys
+ tys' <- mapM markAnnotated tys
an1 <- markClosingParen an0
return (HsExplicitTupleTy (sq', an1) prom tys')
exact (HsTyLit an lit) = do
@@ -4060,13 +4069,13 @@ instance ExactPrint (HsForAllTelescope GhcPs) where
exact (HsForAllVis (EpAnn l (f,r) cs) bndrs) = do
f' <- markEpUniToken f
- bndrs' <- markAnnotated bndrs
+ bndrs' <- mapM markAnnotated bndrs
r' <- markEpUniToken r
return (HsForAllVis (EpAnn l (f',r') cs) bndrs')
exact (HsForAllInvis (EpAnn l (f,d) cs) bndrs) = do
f' <- markEpUniToken f
- bndrs' <- markAnnotated bndrs
+ bndrs' <- mapM markAnnotated bndrs
d' <- markEpToken d
return (HsForAllInvis (EpAnn l (f',d') cs) bndrs')
@@ -4119,7 +4128,7 @@ instance (ExactPrint a) => ExactPrint (HsContextDetails GhcPs a) where
exact (HsContext (opens, closes) tys) = do
opens' <- mapM markEpToken opens
- tys' <- markAnnotated tys
+ tys' <- mapM markAnnotated tys
closes' <- mapM markEpToken closes
return (HsContext (opens', closes') tys')
@@ -4135,7 +4144,7 @@ instance ExactPrint (DerivClauseTys GhcPs) where
return (DctSingle x ty')
exact (DctMulti (op,cp) tys) = do
op' <- markEpToken op
- tys' <- markAnnotated tys
+ tys' <- mapM markAnnotated tys
cp' <- markEpToken cp
return (DctMulti (op',cp') tys')
@@ -4326,12 +4335,12 @@ instance ExactPrint (ConDecl GhcPs) where
return (con', InfixCon x t1' t2')
exact_details (PrefixCon x tys) = do
con' <- markAnnotated con
- tys' <- markAnnotated tys
+ tys' <- mapM markAnnotated tys
return (con', PrefixCon x tys')
exact_details (RecCon (oc,cc) (L an fields)) = do
con' <- markAnnotated con
oc' <- markEpToken oc
- fields' <- markAnnotated fields
+ fields' <- mapM markAnnotated fields
cc' <- markEpToken cc
return (con', RecCon (oc',cc') (L an fields'))
@@ -4365,7 +4374,7 @@ instance ExactPrint (ConDecl GhcPs) where
return (PrefixConGADT x args0')
(RecConGADT (oc,cc,rarr) (L an fields)) -> do
oc' <- markEpToken oc
- fields' <- markAnnotated fields
+ fields' <- mapM markAnnotated fields
cc' <- markEpToken cc
rarr' <- markEpUniToken rarr
return (RecConGADT (oc',cc',rarr') (L an fields'))
@@ -4397,7 +4406,7 @@ instance ExactPrintTVFlag flag => ExactPrint (HsOuterTyVarBndrs flag GhcPs) wher
exact b@(HsOuterImplicit _) = pure b
exact (HsOuterExplicit (EpAnn l (f,d) cs) bndrs) = do
f' <- markEpUniToken f
- bndrs' <- markAnnotated bndrs
+ bndrs' <- mapM markAnnotated bndrs
d' <- markEpToken d
return (HsOuterExplicit (EpAnn l (f',d') cs) bndrs')
@@ -4408,7 +4417,7 @@ instance ExactPrint (HsConDeclRecField GhcPs) where
setAnnotationAnchor a _ _ _ = a
exact (HsConDeclRecField _ names ftype) = do
- names' <- markAnnotated names
+ names' <- mapM markAnnotated names
ftype' <- markAnnotated ftype
return (HsConDeclRecField noExtField names' ftype')
@@ -4436,7 +4445,7 @@ markModifiedFunArrOf :: (Monad m, Monoid w, ExactPrint a)
-> EP w m (HsModifiedFunArrOf a GhcPs, b)
markModifiedFunArrOf (HsModifiedFunArr _ mods arr) tyM = do
ty' <- if isColon then pure (Left ()) else Right <$> tyM
- mods' <- markAnnotated mods
+ mods' <- mapM markAnnotated mods
arr' <- case arr of
HsStandardArr (EpArrow a) -> HsStandardArr . EpArrow <$> markEpUniToken a
HsStandardArr (EpColon c) -> HsStandardArr . EpColon <$> markEpUniToken c
@@ -4530,35 +4539,78 @@ instance (ExactPrint (Match GhcPs (LocatedA body)))
an0 <- markLensFun' an lal_rest markEpToken
an1 <- markLensBracketsO an0 lal_brackets
an2 <- markEpAnnAllLT an1 lal_semis
- a' <- markAnnotated a
+ a' <- mapM markAnnotated a
an3 <- markLensBracketsC an2 lal_brackets
return (L an3 a')
-instance ExactPrint (LocatedLW [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]) where
- getAnnotationEntry = entryFromLocatedA
- setAnnotationAnchor = setAnchorAn
- exact (L an stmts) = do
+-- instance ExactPrint (LocatedA [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]) where
+-- getAnnotationEntry = entryFromLocatedA
+-- setAnnotationAnchor = setAnchorAn
+-- exact (L an stmts) = do
+-- debugM $ "LocatedL [ExprLStmt"
+-- (an'', stmts') <- markAnnList an $ do
+-- case snocView stmts of
+-- Just (initStmts, ls@(L _ (LastStmt _ _body _ _))) -> do
+-- debugM $ "LocatedL [ExprLStmt: snocView"
+-- ls' <- markAnnotated ls
+-- initStmts' <- markAnnotated initStmts
+-- return (initStmts' ++ [ls'])
+-- _ -> do
+-- markAnnotated stmts
+-- return (L an'' stmts')
+
+instance ExactPrint [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))] where
+ getAnnotationEntry _ = NoEntryVal
+ setAnnotationAnchor a _ _ _ = a
+ exact stmts = do
debugM $ "LocatedL [ExprLStmt"
- (an'', stmts') <- markAnnList an $ do
- case snocView stmts of
- Just (initStmts, ls@(L _ (LastStmt _ _body _ _))) -> do
- debugM $ "LocatedL [ExprLStmt: snocView"
- ls' <- markAnnotated ls
- initStmts' <- markAnnotated initStmts
- return (initStmts' ++ [ls'])
- _ -> do
- markAnnotated stmts
- return (L an'' stmts')
-
-instance ExactPrint (LocatedLW [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsCmd GhcPs)))]) where
- getAnnotationEntry = entryFromLocatedA
- setAnnotationAnchor = setAnchorAn
- exact (L ann es) = do
- debugM $ "LocatedL [CmdLStmt"
- an0 <- markLensBracketsO ann lal_brackets
- es' <- mapM markAnnotated es
- an1 <- markLensBracketsC an0 lal_brackets
- return (L an1 es')
+ -- (an'', stmts') <- markAnnList an $ do
+ case snocView stmts of
+ Just (initStmts, ls@(L _ (LastStmt _ _body _ _))) -> do
+ debugM $ "LocatedL [ExprLStmt: snocView"
+ ls' <- markAnnotated ls
+ initStmts' <- markAnnotated initStmts
+ return (initStmts' ++ [ls'])
+ _ -> do
+ stmts' <- mapM markAnnotated stmts
+ return stmts'
+
+-- TODO: harmonise with prior, on payload
+instance ExactPrint [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsCmd GhcPs)))] where
+ getAnnotationEntry _ = NoEntryVal
+ setAnnotationAnchor a _ _ _ = a
+ exact stmts = do
+ debugM $ "LocatedL [ExprLStmt"
+ -- (an'', stmts') <- markAnnList an $ do
+ case snocView stmts of
+ Just (initStmts, ls@(L _ (LastStmt _ _body _ _))) -> do
+ debugM $ "LocatedL [ExprLStmt: snocView"
+ ls' <- markAnnotated ls
+ initStmts' <- markAnnotated initStmts
+ return (initStmts' ++ [ls'])
+ _ -> do
+ stmts' <- markAnnotated stmts
+ return stmts'
+
+-- instance ExactPrint (LocatedA [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsCmd GhcPs)))]) where
+-- getAnnotationEntry = entryFromLocatedA
+-- setAnnotationAnchor = setAnchorAn
+-- exact (L ann es) = do
+-- debugM $ "LocatedL [CmdLStmt"
+-- -- an0 <- markLensBracketsO ann lal_brackets
+-- es' <- mapM markAnnotated es
+-- -- an1 <- markLensBracketsC an0 lal_brackets
+-- return (L ann es')
+
+-- instance ExactPrint (LocatedA [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsCmd GhcPs)))]) where
+-- getAnnotationEntry = entryFromLocatedA
+-- setAnnotationAnchor = setAnchorAn
+-- exact (L ann es) = do
+-- debugM $ "LocatedL [CmdLStmt"
+-- an0 <- markLensBracketsO ann lal_brackets
+-- es' <- mapM markAnnotated es
+-- an1 <- markLensBracketsC an0 lal_brackets
+-- return (L an1 es')
instance ExactPrint (LocatedA [LocatedA (HsConDeclRecField GhcPs)]) where
getAnnotationEntry = entryFromLocatedA
@@ -4619,14 +4671,14 @@ instance ExactPrint (IE GhcPs) where
(dd',c', wc', withs') <-
case wc of
NoIEWildcard -> do
- withs'' <- markAnnotated withs
+ withs'' <- mapM markAnnotated withs
return (dd, c, wc, withs'')
IEWildcard pos -> do
let (bs, as) = splitAt pos withs
- bs' <- markAnnotated bs
+ bs' <- mapM markAnnotated bs
dd' <- markEpToken dd
c' <- markEpToken c
- as' <- markAnnotated as
+ as' <- mapM markAnnotated as
return (dd',c', wc, bs'++as')
cp' <- markEpToken cp
doc' <- markAnnotated doc
@@ -4719,12 +4771,12 @@ instance ExactPrint (Pat GhcPs) where
return (BangPat an0 pat')
exact (ListPat an pats) = do
- (an', pats') <- markAnnList' an (markAnnotated pats)
+ (an', pats') <- markAnnList' an (mapM markAnnotated pats)
return (ListPat an' pats')
exact (TuplePat an pats boxity) = do
an0 <- markOpeningParen an
- pats' <- markAnnotated pats
+ pats' <- mapM markAnnotated pats
an1 <- markClosingParen an0
return (TuplePat an1 pats' boxity)
@@ -4737,7 +4789,7 @@ instance ExactPrint (Pat GhcPs) where
return (SumPat an3 pat' alt arity)
exact (OrPat an pats) = do
- pats' <- markAnnotated (NE.toList pats)
+ pats' <- mapM markAnnotated (NE.toList pats)
return (OrPat an (NE.fromList pats'))
exact (ConPat x con details) = do
@@ -4783,7 +4835,7 @@ instance ExactPrint (Pat GhcPs) where
pure (InvisPat (tokat', spec) tp')
exact (ModifiedPat x mods pat) = do
- mods' <- markAnnotated mods
+ mods' <- mapM markAnnotated mods
pat' <- markAnnotated pat
return (ModifiedPat x mods' pat')
@@ -4878,7 +4930,7 @@ exactUserCon c details = do
exactConArgs :: (Monad m, Monoid w)
=> HsConPatDetails GhcPs -> EP w m (HsConPatDetails GhcPs)
exactConArgs (PrefixCon x pats) = do
- pats' <- markAnnotated pats
+ pats' <- mapM markAnnotated pats
return (PrefixCon x pats')
exactConArgs (InfixCon x p1 p2) = do
p1' <- markAnnotated p1
=====================================
utils/check-exact/Main.hs
=====================================
@@ -101,7 +101,7 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/
-- "../../testsuite/tests/printer/Ppr007.hs" Nothing
-- "../../testsuite/tests/printer/Ppr008.hs" Nothing
-- "../../testsuite/tests/printer/Ppr009.hs" Nothing
- "../../testsuite/tests/printer/Ppr011.hs" Nothing
+ -- "../../testsuite/tests/printer/Ppr011.hs" Nothing
-- "../../testsuite/tests/printer/Ppr011a.hs" Nothing
-- "../../testsuite/tests/printer/Ppr012.hs" Nothing
-- "../../testsuite/tests/printer/Ppr013.hs" Nothing
@@ -124,7 +124,7 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/
-- "../../testsuite/tests/printer/Ppr030.hs" Nothing
-- "../../testsuite/tests/printer/Ppr031.hs" Nothing
-- "../../testsuite/tests/printer/Ppr032.hs" Nothing
- -- "../../testsuite/tests/printer/Ppr033.hs" Nothing
+ "../../testsuite/tests/printer/Ppr033.hs" Nothing
-- "../../testsuite/tests/printer/Ppr034.hs" Nothing
-- "../../testsuite/tests/printer/Ppr035.hs" Nothing
-- "../../testsuite/tests/printer/Ppr036.hs" Nothing
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d87dd8eae9d1f5e336a3ba07497cdf…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d87dd8eae9d1f5e336a3ba07497cdf…
You're receiving this email because of your account on gitlab.haskell.org.
1
0