[Git][ghc/ghc][wip/andreask/ghc_par] 3 commits: Group into limited number of build units
by Andreas Klebinger (＠AndreasK) 15 Mar '26
by Andreas Klebinger (＠AndreasK) 15 Mar '26
15 Mar '26
Andreas Klebinger pushed to branch wip/andreask/ghc_par at Glasgow Haskell Compiler / GHC
Commits:
28582e8f by Andreas Klebinger at 2026-03-10T18:19:40+00:00
Group into limited number of build units
- - - - -
e4a8b165 by Andreas Klebinger at 2026-03-12T01:56:04+00:00
Don't split for another rule wrinkle.
Also removed pointless OccAnal call
- - - - -
f49aa675 by Andreas Klebinger at 2026-03-12T15:08:37+00:00
Adjust dumps for timings
- - - - -
11 changed files:
- compiler/GHC/Core/Opt/CSE.hs
- compiler/GHC/Core/Opt/CallArity.hs
- compiler/GHC/Core/Opt/CompUnit.hs
- compiler/GHC/Core/Opt/CprAnal.hs
- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/Core/Opt/Exitify.hs
- compiler/GHC/Core/Opt/FloatIn.hs
- compiler/GHC/Core/Opt/LiberateCase.hs
- compiler/GHC/Core/Opt/Pipeline.hs
- compiler/GHC/Core/Opt/Simplify.hs
- compiler/GHC/Core/Opt/Split.hs
Changes:
=====================================
compiler/GHC/Core/Opt/CSE.hs
=====================================
@@ -25,6 +25,7 @@ import GHC.Core.Map.Expr
import GHC.Core.Opt.CompUnit (parMapCompUnits)
import GHC.Utils.Misc ( filterOut, equalLength )
import GHC.Utils.Panic
+import GHC.Utils.Logger (Logger)
import Data.Functor.Identity ( Identity (..) )
import Data.List ( mapAccumL )
@@ -380,8 +381,8 @@ body/rest of the module.
************************************************************************
-}
-cseProgram :: CoreProgram -> CoreProgram
-cseProgram = parMapCompUnits cseCoreCompUnit
+cseProgram :: Logger -> CoreProgram -> CoreProgram
+cseProgram logger = parMapCompUnits logger "CommonSubExpr" cseCoreCompUnit
cseCoreCompUnit :: CoreCompUnit -> CoreCompUnit
cseCoreCompUnit (CoreCompUnit unit_binds unit_rules)
=====================================
compiler/GHC/Core/Opt/CallArity.hs
=====================================
@@ -21,6 +21,7 @@ import GHC.Core.Opt.CompUnit (parMapCompUnits)
import GHC.Core.Utils ( exprIsCheap, exprIsTrivial )
import GHC.Data.Graph.UnVar
import GHC.Types.Demand
+import GHC.Utils.Logger (Logger)
import GHC.Utils.Misc
import Control.Arrow ( first, second )
@@ -434,8 +435,8 @@ choice, and hence Call Arity sets the call arity for join points as well.
-- Main entry point
-callArityAnalProgram :: CoreProgram -> CoreProgram
-callArityAnalProgram = parMapCompUnits callArityCompUnit
+callArityAnalProgram :: Logger -> CoreProgram -> CoreProgram
+callArityAnalProgram logger = parMapCompUnits logger "CallArity" callArityCompUnit
where
callArityCompUnit (CoreCompUnit binds unit_rules)
= let (_ae, binds') = callArityTopLvl [] emptyVarSet binds
=====================================
compiler/GHC/Core/Opt/CompUnit.hs
=====================================
@@ -1,22 +1,61 @@
module GHC.Core.Opt.CompUnit
( parMapCompUnits
+ , coreCompUnitTimingDoc
+ , forceCompUnit
) where
import GHC.Prelude
-import GHC.Conc (par, pseq)
+import Control.Concurrent (forkIO, newEmptyMVar, putMVar, takeMVar)
+import Control.Exception (SomeException, evaluate, throwIO, try)
+import System.IO.Unsafe (unsafePerformIO)
+import GHC.Driver.Flags (DumpFlag(Opt_D_dump_timings))
import GHC.Core
-import GHC.Core.Seq (seqBinds)
+import GHC.Core.Stats (coreBindsSize)
+import GHC.Core.Seq (seqBinds, seqRules)
+import GHC.Utils.Error (withTiming)
+import GHC.Utils.Logger (Logger, logHasDumpFlag)
+import GHC.Utils.Outputable
+import Debug.Trace (traceEventIO)
-parMapCompUnits :: (CoreCompUnit -> CoreCompUnit) -> CoreProgram -> CoreProgram
-parMapCompUnits f = go
+parMapCompUnits :: Logger -> String -> (CoreCompUnit -> CoreCompUnit) -> CoreProgram -> CoreProgram
+parMapCompUnits logger pass_name f units = unsafePerformIO $ do
+ result_vars <- mapM (uncurry fork_unit) (zip [1 :: Int ..] units)
+ mapM take_unit result_vars
where
- go [] = []
- go (unit:units) = unit' `par` (units' `pseq` (unit' : units'))
- where
- unit' = forceCompUnit (f unit)
- units' = go units
-
- forceCompUnit unit@(CoreCompUnit unit_binds _unit_rules) =
- seqBinds unit_binds `seq` unit
+ total_units = length units
+ do_timings = total_units > 1 && logHasDumpFlag logger Opt_D_dump_timings
+
+ fork_unit unit_no unit = do
+ result_var <- newEmptyMVar
+ _ <- forkIO $ do
+ traceEventIO ("parMapCompUnits: Start(" ++ (show unit_no) ++ "): " ++ pass_name)
+ result <- try $
+ if do_timings
+ then withTiming logger (coreCompUnitTimingDoc pass_name unit_no total_units unit) forceCompUnit $
+ evaluate $ let unit' = f unit in forceCompUnit unit' `seq` unit'
+ else evaluate $ let unit' = f unit in forceCompUnit unit' `seq` unit'
+ putMVar result_var result
+ traceEventIO ("parMapCompUnits: End(" ++ (show unit_no) ++ "): " ++ pass_name)
+ pure result_var
+
+ take_unit result_var = do
+ result <- takeMVar result_var
+ case result of
+ Left err -> throwIO (err :: SomeException)
+ Right unit -> pure unit
+
+forceCompUnit :: CoreCompUnit -> ()
+forceCompUnit (CoreCompUnit unit_binds unit_rules) =
+ seqBinds unit_binds `seq` seqRules unit_rules `seq` ()
+
+coreCompUnitTimingDoc :: String -> Int -> Int -> CoreCompUnit -> SDoc
+coreCompUnitTimingDoc pass_name unit_no total_units (CoreCompUnit unit_binds unit_rules) =
+ text pass_name
+ <+> parens
+ (text "unit"
+ <+> int unit_no <> char '/' <> int total_units <> comma
+ <+> text "binds=" <> int (length unit_binds) <> comma
+ <+> text "rules=" <> int (length unit_rules) <> comma
+ <+> text "size=" <> int (coreBindsSize unit_binds))
=====================================
compiler/GHC/Core/Opt/CprAnal.hs
=====================================
@@ -182,7 +182,7 @@ So currently we have
cprAnalProgram :: Logger -> FamInstEnvs -> CoreProgram -> IO CoreProgram
cprAnalProgram logger fam_envs comp_units = do
- let binds_plus_cpr = parMapCompUnits (cprAnalCompUnit (emptyAnalEnv fam_envs)) comp_units
+ let binds_plus_cpr = parMapCompUnits logger "CprAnal" (cprAnalCompUnit (emptyAnalEnv fam_envs)) comp_units
putDumpFileMaybe logger Opt_D_dump_cpr_signatures "Cpr signatures" FormatText $
dumpIdInfoOfProgram False (ppr . cprSigInfo) binds_plus_cpr
-- See Note [Stamp out space leaks in demand analysis] in GHC.Core.Opt.DmdAnal
=====================================
compiler/GHC/Core/Opt/DmdAnal.hs
=====================================
@@ -38,6 +38,7 @@ import GHC.Builtin.PrimOps
import GHC.Builtin.Types.Prim ( realWorldStatePrimTy )
import GHC.Types.Unique.Set
+import GHC.Utils.Logger (Logger)
import GHC.Types.Unique.MemoFun
import GHC.Types.RepType
import GHC.Types.ForeignCall ( isSafeForeignCall )
@@ -91,9 +92,9 @@ data DmdResult a b = R !a !b
--
-- Note: use `seqBinds` on the result to avoid leaks due to laziness (cf Note
-- [Stamp out space leaks in demand analysis])
-dmdAnalProgram :: DmdAnalOpts -> FamInstEnvs -> [CoreRule] -> CoreProgram -> CoreProgram
-dmdAnalProgram opts fam_envs rules binds
- = parMapCompUnits dmd_anal_comp_unit binds
+dmdAnalProgram :: Logger -> DmdAnalOpts -> FamInstEnvs -> [CoreRule] -> CoreProgram -> CoreProgram
+dmdAnalProgram logger opts fam_envs rules binds
+ = parMapCompUnits logger "DmdAnal" dmd_anal_comp_unit binds
where
dmd_anal_comp_unit (CoreCompUnit unit_binds unit_rules)
= let WithDmdType _unit_ty unit_binds' = go_unit (emptyAnalEnv opts fam_envs) [] unit_binds
=====================================
compiler/GHC/Core/Opt/Exitify.hs
=====================================
@@ -39,6 +39,7 @@ import GHC.Prelude
import GHC.Builtin.Uniques
import GHC.Core
import GHC.Core.Opt.CompUnit (parMapCompUnits)
+import GHC.Utils.Logger (Logger)
import GHC.Core.Utils
import GHC.Core.FVs
import GHC.Core.Type
@@ -60,8 +61,8 @@ import Control.Monad
-- | Traverses the AST, simply to find all joinrecs and call 'exitify' on them.
-- The really interesting function is exitifyRec
-exitifyProgram :: CoreProgram -> CoreProgram
-exitifyProgram comp_units = parMapCompUnits exitifyCompUnit comp_units
+exitifyProgram :: Logger -> CoreProgram -> CoreProgram
+exitifyProgram logger comp_units = parMapCompUnits logger "Exitify" exitifyCompUnit comp_units
where
exitifyCompUnit (CoreCompUnit binds unit_rules) =
CoreCompUnit (map goTopLvl binds) unit_rules
=====================================
compiler/GHC/Core/Opt/FloatIn.hs
=====================================
@@ -35,6 +35,7 @@ import GHC.Types.Tickish
import GHC.Types.Var
import GHC.Types.Var.Set
+import GHC.Utils.Logger (Logger)
import GHC.Utils.Misc
import GHC.Utils.Panic.Plain
@@ -47,8 +48,8 @@ Top-level interface function, @floatInwards@. Note that we do not
actually float any bindings downwards from the top-level.
-}
-floatInwards :: Platform -> CoreProgram -> CoreProgram
-floatInwards platform = parMapCompUnits floatCompUnit
+floatInwards :: Logger -> Platform -> CoreProgram -> CoreProgram
+floatInwards logger platform = parMapCompUnits logger "FloatInwards" floatCompUnit
where
floatCompUnit (CoreCompUnit binds unit_rules) =
CoreCompUnit (map (fi_top_bind platform) binds) unit_rules
=====================================
compiler/GHC/Core/Opt/LiberateCase.hs
=====================================
@@ -19,6 +19,7 @@ import GHC.Core.Opt.Simplify.Inline
import GHC.Builtin.Types ( unitDataConId )
import GHC.Types.Id
import GHC.Types.Var.Env
+import GHC.Utils.Logger (Logger)
import GHC.Utils.Misc ( notNull )
{-
@@ -105,8 +106,8 @@ and the level of @h@ is zero (NB not one).
************************************************************************
-}
-liberateCase :: LibCaseOpts -> CoreProgram -> CoreProgram
-liberateCase opts = parMapCompUnits liberateCaseCompUnit
+liberateCase :: Logger -> LibCaseOpts -> CoreProgram -> CoreProgram
+liberateCase logger opts = parMapCompUnits logger "LiberateCase" liberateCaseCompUnit
where
liberateCaseCompUnit (CoreCompUnit binds unit_rules) =
CoreCompUnit (snd (do_unit (initLiberateCaseEnv opts) binds)) unit_rules
=====================================
compiler/GHC/Core/Opt/Pipeline.hs
=====================================
@@ -66,6 +66,7 @@ import GHC.Types.Unique.Supply ( UniqueTag(..) )
import Control.Monad
import GHC.Unit.Module
+import GHC.Conc (getNumCapabilities)
{-
************************************************************************
@@ -484,7 +485,8 @@ doCorePass pass guts = do
updateBindsAndRulesM (desugarOpt dflags logger (mg_module guts))
CoreSplit -> {-# SCC "CoreSplit" #-}
- do { let split_res = map (splitCompUnit (mg_module guts) (mg_boot_exports guts) (mg_rules guts)) (mg_binds guts)
+ do { n_threads <- liftIO getNumCapabilities
+ ; let split_res = map (splitCompUnit n_threads (mg_module guts) (mg_boot_exports guts) (mg_rules guts)) (mg_binds guts)
binds' = concatMap fst split_res
rules' = mg_rules guts ++ concatMap snd split_res
; return guts { mg_binds = binds', mg_rules = rules' } }
@@ -537,13 +539,13 @@ doCorePass pass guts = do
liftIOWithCount $ simplifyPgm logger (hsc_unit_env hsc_env) name_ppr_ctx opts guts
CoreCSE -> {-# SCC "CommonSubExpr" #-}
- updateBinds cseProgram
+ updateBinds (cseProgram logger)
CoreLiberateCase -> {-# SCC "LiberateCase" #-}
- updateBinds (liberateCase (initLiberateCaseOpts dflags))
+ updateBinds (liberateCase logger (initLiberateCaseOpts dflags))
CoreDoFloatInwards -> {-# SCC "FloatInwards" #-}
- updateBinds (floatInwards platform)
+ updateBinds (floatInwards logger platform)
CoreDoFloatOutwards f -> {-# SCC "FloatOutwards" #-}
updateBindsM $ \units -> liftIO $
@@ -556,10 +558,10 @@ doCorePass pass guts = do
updateBinds (doStaticArgs us)
CoreDoCallArity -> {-# SCC "CallArity" #-}
- updateBinds callArityAnalProgram
+ updateBinds (callArityAnalProgram logger)
CoreDoExitify -> {-# SCC "Exitify" #-}
- updateBinds exitifyProgram
+ updateBinds (exitifyProgram logger)
CoreDoDemand before_ww -> {-# SCC "DmdAnal" #-}
updateBindsM (liftIO . dmdAnal logger before_ww dflags fam_envs (mg_rules guts))
@@ -632,7 +634,7 @@ dmdAnal logger before_ww dflags fam_envs rules binds = do
, dmd_unbox_width = dmdUnboxWidth dflags
, dmd_max_worker_args = maxWorkerArgs dflags
}
- binds_plus_dmds = dmdAnalProgram opts fam_envs rules binds
+ binds_plus_dmds = dmdAnalProgram logger opts fam_envs rules binds
Logger.putDumpFileMaybe logger Opt_D_dump_dmd_signatures "Demand signatures" FormatText $
dumpIdInfoOfProgram (hasPprDebug dflags) (ppr . zapDmdEnvSig . dmdSigInfo) binds_plus_dmds
-- See Note [Stamp out space leaks in demand analysis] in GHC.Core.Opt.DmdAnal
=====================================
compiler/GHC/Core/Opt/Simplify.hs
=====================================
@@ -13,6 +13,7 @@ import GHC.Core
import GHC.Core.FVs (ruleFreeVars)
import GHC.Core.Rules
import GHC.Core.Ppr ( pprCoreBindings, pprCoreExpr )
+import GHC.Core.Opt.CompUnit (coreCompUnitTimingDoc, forceCompUnit)
import GHC.Core.Opt.OccurAnal ( occurAnalyseCompUnit, occurAnalyseExpr )
import GHC.Core.Stats ( coreBindsSize, coreBindsStats, exprSize )
import GHC.Core.Utils ( mkTicks, stripTicksTop )
@@ -230,17 +231,33 @@ simplifyPgm' logger unit_env name_ppr_ctx opts
zero_counts = zeroSimplCount $ logHasDumpFlag logger Opt_D_dump_simpl_stats
- run_units :: (CoreCompUnit -> IO a) -> [CoreCompUnit] -> IO [a]
+ run_units
+ :: (CoreCompUnit -> IO (CoreCompUnit, (String, Int), SimplCount))
+ -> [CoreCompUnit]
+ -> IO [(CoreCompUnit, (String, Int), SimplCount)]
run_units f units
- | parallel_units = mapParallelIO f units
+ | parallel_units = mapParallelIO timed_f (zip [1 :: Int ..] units)
| otherwise = mapM f units
where
+ total_units = length units
parallel_units = length units > 1 && not disable_parallel
disable_parallel =
logHasDumpFlag logger Opt_D_dump_occur_anal
|| logHasDumpFlag logger Opt_D_dump_simpl_iterations
+ timed_f (unit_no, unit)
+ | logHasDumpFlag logger Opt_D_dump_timings
+ = withTiming logger
+ (coreCompUnitTimingDoc "Simplify" unit_no total_units unit)
+ force_unit_result
+ (f unit)
+ | otherwise
+ = f unit
+
+ force_unit_result (unit', _, count) =
+ forceCompUnit unit' `seq` count `seq` ()
+
mapParallelIO :: (a -> IO b) -> [a] -> IO [b]
mapParallelIO f xs = mask $ \restore -> do
workers <- forM xs $ \x -> do
=====================================
compiler/GHC/Core/Opt/Split.hs
=====================================
@@ -9,15 +9,15 @@ import GHC.Prelude hiding ( head, init, last )
import GHC.Core
import GHC.Core.FVs
-import GHC.Core.Opt.OccurAnal (occurAnalyseCompUnit)
+import GHC.Core.Ppr (pprRule)
import GHC.Core.Stats (coreBindsSize)
import GHC.Data.Graph.Directed (SCC(..), Node(..), stronglyConnCompFromEdgedVerticesUniq)
-import GHC.Data.Maybe (orElse)
+import GHC.Data.Maybe (mapMaybe, orElse)
import GHC.Types.Unique.Set
import GHC.Types.Name (Name, isExternalName, nameModule)
-import GHC.Types.Name.Set (NameSet, isEmptyNameSet)
+import GHC.Types.Name.Set (NameSet, elemNameSet, isEmptyNameSet, mkNameSet)
import GHC.Types.Var.Set
import GHC.Types.Var.Env
import GHC.Types.Var
@@ -27,6 +27,8 @@ import GHC.Utils.Panic
import GHC.Unit.Module (Module)
+import Data.List (foldl', sortOn)
+import Data.Ord (Down(..))
import qualified Data.IntMap.Strict as IntMap
import qualified Data.IntSet as IntSet
@@ -96,6 +98,57 @@ scope. So we must ensure `fa1` and fa2 end up in the same compilation unit.
But for now I think I will just disable splitting if there is a boot module.
+--------------------------------
+
+Another wrinkle involving rules:
+Consider this:
+
+module A where
+
+{-# INLINE[1] foo #-}
+A.f1 x = 42
+A.f2 = A.f1
+-------------------
+module B where
+
+{-# RULES "rule-foo-bar" forall x. A.f1 x = bar x #-}
+
+foo x = A.f2 x
+
+bar x = 16
+
+
+Here rule-foo-bar only mentions one local binder so naively we would assume foo and bar are independent as the rule doesn't connect any two local binders directly.
+However consider this sequence of events:
+
+foo x = A.f2 x
+
+=> inline f2
+foo x = A.f1 x
+
+=> fire rule
+foo x = bar x
+
+
+Suddenly those two binders are not so independent anymore! The main point here is we might need to follow arbitrarily
+deep chains of imported unfoldings to avoid this. But doing so I think is prohibitively expensive especially if we don't
+know if we can actually uncover much parallelism for doing so.
+Where does this leave us?
+
+If a rule mentions zero local binders we can ignore it.
+If a rule mentions a local binder on both sides it's just an edge between those two binders. (easy)
+If a rule mentions a local binder on the lhs we can ignore it.
+If a rule mentions a single local binder on the rhs then unless we do a deep traversal of imported unfoldings we have to
+treat any imported bindings as potentially linking back to that local binder. (hard)
+
+We could the simple thing and say such a rule just makes splitting core unviable and compile any module with such a rule as a
+single compilation unit. And while rules of the last kind are rare specialzation rules are a notable exception:
+In particular if we have: imported :: C a => a -> T2 and {-# SPECIALISE imported :: T1 -> T2 #-} GHC translates this to a
+RULE `imported @T1 $dCT1 = $simported`; The exact shape the last point is talking about!
+It's unclear how to handle this. Do the unfolding traversel only if there are such rules? Might still be quite expensive.
+Especially with aggressive unfolding flags it could end up inspecting every unfolding in a project! Just give up on parallelism
+if there are such rules? Specialization pragmas aren't that rare, so seems like a big loss. Tricky!
+
-}
data DepGraphNode
@@ -121,6 +174,29 @@ maybeRuleEdges this_module rule =
where
local_fvs = filter (varFromModule this_module) (nonDetEltsUniqSet (ruleFreeVars rule))
+data UnifyingRule = UnifyingRule
+ { unifyingRule :: !CoreRule
+ , unifyingRuleRhsFvs :: ![Var]
+ }
+
+findUnifyingRule :: VarSet -> NameSet -> CoreRule -> Maybe UnifyingRule
+findUnifyingRule local_top_bndrs local_top_names rule
+ | lhs_has_no_local_binder && not (null rhs_local_fvs)
+ = Just (UnifyingRule rule rhs_local_fvs)
+ | otherwise
+ = Nothing
+ where
+ lhs_local_fvs = ruleLhsFreeIds rule `intersectVarSet` local_top_bndrs
+ lhs_has_no_local_binder =
+ isEmptyVarSet lhs_local_fvs && not (ruleHeadIsLocal local_top_names rule)
+
+ rhs_local_fvs =
+ nonDetEltsUniqSet (ruleRhsFreeVars rule `intersectVarSet` local_top_bndrs)
+
+ruleHeadIsLocal :: NameSet -> CoreRule -> Bool
+ruleHeadIsLocal local_top_names Rule { ru_fn = fn } = fn `elemNameSet` local_top_names
+ruleHeadIsLocal _ BuiltinRule {} = False
+
bindNode :: VarSet -> CoreBind -> ([DepGraphNode], [Edge])
bindNode local_top_bndrs bind =
case bindersOf bind of
@@ -197,7 +273,7 @@ assignLocalRules unit_rules binder_components =
[] -> (rule_map, rule : no_comp_rules)
is -> pprPanic "splitCompUnit"
( text "Rule free vars span multiple components"
- $$ text "rule:" <+> ppr rule
+ $$ text "rule:" <+> pprRule rule
$$ text "components:" <+> ppr is
$$ text "rule_fvs:" <+> pprVarsWithModule (nonDetEltsUniqSet (ruleFreeVars rule))
$$ vcat [ text "component" <+> int i <> colon <+> pprVarsWithModule hits
@@ -236,20 +312,26 @@ pprVarWithModule v
-- After optimizations a rule might no longer reference binders from this module.
-- In these cases we return them here and then add them to mg_rules.
-splitCompUnit :: Module -> NameSet -> [CoreRule] -> CoreCompUnit -> ([CoreCompUnit], [CoreRule])
-splitCompUnit this_module boot_exported imp_rules unit
+splitCompUnit :: Int -> Module -> NameSet -> [CoreRule] -> CoreCompUnit -> ([CoreCompUnit], [CoreRule])
+splitCompUnit n_threads this_module boot_exported _imp_rules unit
+ | n_threads <= 1 = single_comp_unit
| not boot_exported_is_empty = single_comp_unit
+ | unifying_rule : _ <- unifying_rules
+ = pprTrace "splitCompUnit"
+ ( text "Not splitting build unit due to unifying rule"
+ $$ text "rule:" <+> pprRule (unifyingRule unifying_rule)
+ $$ text "local rhs binders:" <+> pprVarsWithModule (unifyingRuleRhsFvs unifying_rule) )
+ single_comp_unit
| otherwise
- = let comp_units = map mk_comp_unit components_with_rules
+ = let comp_units = combineCompUnits max_units (map mk_comp_unit components_with_rules)
result = (comp_units, rules_for_imps ++ rules_without_component)
in -- pprTrace "CoreSplitTrace" (pprSplitTrace comp_units) $
checkNameClashes comp_units `seq`
result
where
- CoreCompUnit occ_binds unit_rules =
- occurAnalyseCompUnit this_module (const True) (const True) imp_rules unit
+ CoreCompUnit unit_binds unit_rules = unit
- top_level_bndrs = bindersOfBinds occ_binds
+ top_level_bndrs = bindersOfBinds unit_binds
checked_bndrs =
assertPpr (all isLocalVar top_level_bndrs)
( text "splitCompUnit: non-local top-level binder(s)"
@@ -257,8 +339,9 @@ splitCompUnit this_module boot_exported imp_rules unit
top_level_bndrs
local_top_bndrs = mkVarSet checked_bndrs
+ local_top_names = mkNameSet (map varName checked_bndrs)
- bind_node_info = checked_bndrs `seq` map (bindNode local_top_bndrs) occ_binds
+ bind_node_info = checked_bndrs `seq` map (bindNode local_top_bndrs) unit_binds
bind_nodes = concatMap fst bind_node_info
bind_edges = concatMap snd bind_node_info
@@ -266,6 +349,8 @@ splitCompUnit this_module boot_exported imp_rules unit
rule_edges = concat [ es | (_, Just es) <- rule_edge_pairs ]
rules_for_imps = [ r | (r, Nothing) <- rule_edge_pairs ]
unit_rules_local = [ r | (r, Just _) <- rule_edge_pairs ]
+ unifying_rules =
+ mapMaybe (findUnifyingRule local_top_bndrs local_top_names) unit_rules
all_edges = bind_edges ++ rule_edges
binder_components = splitCoreBinders bind_nodes all_edges
@@ -275,9 +360,60 @@ splitCompUnit this_module boot_exported imp_rules unit
mk_comp_unit (_, binds, rules) = CoreCompUnit binds rules
boot_exported_is_empty = isEmptyNameSet boot_exported
+ max_units = n_threads + 1
single_comp_unit = ([unit], [])
+combineCompUnits :: Int -> [CoreCompUnit] -> [CoreCompUnit]
+combineCompUnits max_units units
+ | length units <= max_units = units
+ | otherwise = map finishBucket (IntMap.elems final_buckets)
+ where
+ initial_buckets =
+ IntMap.fromDistinctAscList
+ [ (i, Bucket 0 [] [])
+ | i <- [0 .. max_units - 1]
+ ]
+
+ final_buckets =
+ foldl' assignUnit initial_buckets sorted_units
+
+ sorted_units =
+ sortOn (Down . unitSize . snd) (zip [0 :: Int ..] units)
+
+ assignUnit buckets (_, unit) =
+ IntMap.adjust (addUnit unit) target_bucket buckets
+ where
+ target_bucket = smallestBucket buckets
+
+ smallestBucket buckets =
+ case IntMap.toAscList buckets of
+ [] -> panic "combineCompUnits.smallestBucket: empty bucket map"
+ b : bs -> fst (foldl' choose_bucket b bs)
+
+ choose_bucket best@(i1, b1) candidate@(i2, b2)
+ | (bucketSize b2, i2) < (bucketSize b1, i1) = candidate
+ | otherwise = best
+
+ finishBucket (Bucket _ binds_acc rules_acc) =
+ CoreCompUnit (reverse binds_acc) (reverse rules_acc)
+
+ unitSize = coreBindsSize . coreCompUnitBinds
+
+data Bucket = Bucket
+ { bucketSize :: !Int
+ , bucketBinds :: [CoreBind]
+ , bucketRules :: [CoreRule]
+ }
+
+addUnit :: CoreCompUnit -> Bucket -> Bucket
+addUnit (CoreCompUnit binds rules) (Bucket sz binds_acc rules_acc) =
+ Bucket
+ { bucketSize = sz + coreBindsSize binds
+ , bucketBinds = foldl' (flip (:)) binds_acc binds
+ , bucketRules = foldl' (flip (:)) rules_acc rules
+ }
+
checkNameClashes :: [CoreCompUnit] -> ()
checkNameClashes comp_units
| null dup_bndrs = ()
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a1fc32627c98b1e2406360eb38342b…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a1fc32627c98b1e2406360eb38342b…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
15 Mar '26
Simon Peyton Jones pushed to branch wip/spj-reinstallable-base at Glasgow Haskell Compiler / GHC
Commits:
88d760d9 by Simon Peyton Jones at 2026-03-15T00:53:33+00:00
Progress
It compiles
- - - - -
28 changed files:
- compiler/GHC/Builtin/Names.hs
- compiler/GHC/Builtin/Names/TH.hs
- compiler/GHC/Builtin/Utils.hs
- compiler/GHC/Driver/Env/KnotVars.hs
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/HsToCore/Monad.hs
- compiler/GHC/HsToCore/Pmc/Desugar.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Iface/Env.hs
- − compiler/GHC/Iface/Env.hs-boot
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Iface/Tidy.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Rename/Env.hs
- compiler/GHC/Tc/Deriv/Generics.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/Tc/Instance/Typeable.hs
- compiler/GHC/Tc/TyCl/Build.hs
- compiler/GHC/Tc/Types.hs
- compiler/GHC/Tc/Utils/Env.hs
- compiler/GHC/Tc/Utils/Instantiate.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Types/Name/Cache.hs
- compiler/GHC/Unit/External.hs
- libraries/base/base.cabal.in
- libraries/ghc-internal/ghc-internal.cabal.in
- libraries/ghc-internal/src/GHC/Internal/LanguageExtensions.hs
- libraries/ghc-internal/src/GHC/Internal/Real.hs
Changes:
=====================================
compiler/GHC/Builtin/Names.hs
=====================================
@@ -188,8 +188,8 @@ names with uniques. These ones are the *non* wired-in ones. The
wired in ones are defined in GHC.Builtin.Types etc.
-}
-basicKnownKeyOccs :: [(OccName, Unique)]
-basicKnownKeyOccs
+basicKnownKeyTable :: [(OccName, Unique)]
+basicKnownKeyTable
= [ (mkTcOcc "Rational", rationalTyConKey) ]
basicKnownKeyNames :: [Name] -- See Note [Known-key names]
=====================================
compiler/GHC/Builtin/Names/TH.hs
=====================================
@@ -25,8 +25,8 @@ import Language.Haskell.Syntax.Module.Name
-- 2) Make a "Name"
-- 3) Add the name to templateHaskellNames
-templateHaskellOccs :: [(OccName,Unique)]
-templateHaskellOccs = []
+thKnownKeyTable :: [(OccName,Unique)]
+thKnownKeyTable = []
templateHaskellNames :: [Name]
-- The names that are implicitly mentioned by ``bracket''
=====================================
compiler/GHC/Builtin/Utils.hs
=====================================
@@ -28,7 +28,7 @@ module GHC.Builtin.Utils (
-- if you find yourself wanting to look at it you might consider using
-- 'lookupKnownKeyName' or 'isKnownKeyName'.
knownKeyNames,
- KnownKeyOccMap, knownKeyOccMap,
+ knownKeyOccMap, knownKeyUniqMap,
-- * Miscellaneous
wiredInIds, ghcPrimIds,
@@ -54,7 +54,7 @@ import GHC.Builtin.PrimOps.Ids
import GHC.Builtin.Types
import GHC.Builtin.Types.Literals ( typeNatTyCons )
import GHC.Builtin.Types.Prim
-import GHC.Builtin.Names.TH ( templateHaskellNames, templateHaskellOccs )
+import GHC.Builtin.Names.TH ( templateHaskellNames, thKnownKeyTable )
import GHC.Builtin.Names
import GHC.Core.ConLike ( ConLike(..) )
@@ -205,12 +205,13 @@ isKnownKeyName :: Name -> Bool
isKnownKeyName n =
isJust (knownUniqueName $ nameUnique n) || elemUFM n knownKeysMap
-type KnownKeyOccMap = OccEnv Name
- -- See Note [Overview of known-key Names]
-
-- | `knownKeyOccMap` maps the OccName of a known-key to its Unique
knownKeyOccMap :: OccEnv Unique
-knownKeyOccMap = mkOccEnv (basicKnownKeyOccs ++ templateHaskellOccs)
+knownKeyOccMap = mkOccEnv (basicKnownKeyTable ++ thKnownKeyTable)
+
+knownKeyUniqMap :: UniqFM Unique OccName
+knownKeyUniqMap = listToUFM [ (uniq, occ)
+ | (occ, uniq) <- basicKnownKeyTable ++ thKnownKeyTable ]
-- | Maps 'Unique's to known-key names.
--
=====================================
compiler/GHC/Driver/Env/KnotVars.hs
=====================================
@@ -16,9 +16,12 @@ import GHC.Utils.Outputable
-- See Note [Why is KnotVars not a ModuleEnv]
-- See Note [KnotVars invariants]
-data KnotVars a = KnotVars { kv_domain :: [Module] -- Domain of the function , Note [KnotVars: Why store the domain?]
- -- Invariant: kv_lookup is surjective relative to kv_domain
+data KnotVars a = KnotVars { kv_domain :: [Module]
+ -- Domain of kv_lookup
+ -- See Note [KnotVars: Why store the domain?]
+
, kv_lookup :: Module -> Maybe a -- Lookup function
+ -- Invariant: kv_lookup is surjective relative to kv_domain
}
| NoKnotVars
deriving Functor
=====================================
compiler/GHC/Driver/Flags.hs
=====================================
@@ -150,6 +150,7 @@ extensionName = \case
LangExt.ImplicitParams -> "ImplicitParams"
LangExt.ImplicitPrelude -> "ImplicitPrelude"
LangExt.ImplicitKnownKeyNames -> "ImplicitKnownKeyNames"
+ LangExt.DefinesKnownKeyNames -> "DefinesKnownKeyNames"
LangExt.ScopedTypeVariables -> "ScopedTypeVariables"
LangExt.AllowAmbiguousTypes -> "AllowAmbiguousTypes"
LangExt.UnboxedTuples -> "UnboxedTuples"
=====================================
compiler/GHC/HsToCore/Monad.hs
=====================================
@@ -81,6 +81,7 @@ import GHC.Core.Type
import GHC.Core.Multiplicity
import GHC.IfaceToCore
+import GHC.Iface.Load( lookupKnownKeyThing )
import GHC.Tc.Utils.Monad
@@ -117,7 +118,11 @@ import GHC.Utils.Error
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Misc( HasDebugCallStack )
+
+import qualified GHC.LanguageExtensions as LangExt
+
import qualified GHC.Data.Strict as Strict
+import GHC.Data.Maybe
import GHC.Data.OrdList
import Data.IORef
@@ -396,16 +401,22 @@ mkDsEnvs :: UnitEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
mkDsEnvs unit_env mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var
statics_var next_wrapper_num complete_matches
= let if_genv = IfGblEnv { if_doc = text "mkDsEnvs"
- -- Failing tests here are `ghci` and `T11985` if you get this wrong.
- -- this is very very "at a distance" because the reason for this check is that the type_env in interactive
- -- mode is the smushed together of all the interactive modules.
- -- See Note [Why is KnotVars not a ModuleEnv]
- , if_rec_types = KnotVars [mod] (\that_mod -> if that_mod == mod || isInteractiveModule mod
- then Just (return type_env)
- else Nothing) }
+ , if_rec_types = KnotVars [mod] knot_var_fun }
+ -- Failing tests here are `ghci` and `T11985` if you get this wrong.
+ -- This is very very "at a distance" because the reason for this check
+ -- is that the type_env in interactive mode is the smushed together
+ -- of all the interactive modules.
+ -- See Note [Why is KnotVars not a ModuleEnv]
+
+ knot_var_fun :: Module -> Maybe (IfG TypeEnv)
+ knot_var_fun that_mod
+ | that_mod == mod || isInteractiveModule mod = Just (return type_env)
+ | otherwise = Nothing
+
if_lenv = mkIfLclEnv mod (text "GHC error in desugarer lookup in" <+> ppr mod)
NotBoot
real_span = realSrcLocSpan (mkRealSrcLoc (moduleNameFS (moduleName mod)) 1 1)
+
gbl_env = DsGblEnv { ds_mod = mod
, ds_fam_inst_env = fam_inst_env
, ds_gbl_rdr_env = rdr_env
@@ -426,7 +437,7 @@ mkDsEnvs unit_env mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var
dsToIfL :: IfL a -> DsM a
-- Run an Iface action in the Ds monad
-dsToIfl iface_action
+dsToIfL iface_action
= do { env <- getGblEnv
; setEnvs (ds_if_env env) iface_action }
@@ -554,28 +565,21 @@ mkNamePprCtxDs = ds_name_ppr_ctx <$> getGblEnv
instance MonadThings (IOEnv (Env DsGblEnv DsLclEnv)) where
lookupThing = dsLookupGlobal
-dsLookupKnownKey :: OccName -> DsM TyThing
-dsLookupKnownKey occ
- = do { normal_path <- xoptM ImplicitKnownKeyNames
- ; if normal_path
- then dsToIfL $
- lookupImportedKnownKey occ
- else
- lookupKnownKeyOcc occ
- }
-
-dsLookupKnownKeyOcc :: OccName -> DsM TyThing
--- Look up the known-key OccName in the current top-level GlobalRdrEnv
--- If we get a unique hit, use it; if not, panic.
-dsLookupKnownKeyOcc occ
- = do { gbl_rdr_env <- dsGetGlobalRdrEnv
- ; case lookupGRE gbl_rdr_env (lookupOccName occ SameNameSpace) of
- [name] -> dsLookupGlobal name
- gres -> pprPanic "lookupKnownKeyOcc" (ppr occ $$ ppr gres) }
-
-dsLookupKnownKeyTyCon :: Name -> DsM TyCon
-dsLookupKnownKeyTyCon name
- = tyThingTyCon <$> dsLookupKnownKey name
+dsLookupKnownKey :: Unique -> DsM TyThing
+dsLookupKnownKey uniq
+ = do { normal_path <- xoptM LangExt.ImplicitKnownKeyNames
+ ; mb_rdr_env <- if normal_path
+ then return Nothing
+ else Just <$> dsGetGlobalRdrEnv
+ ; dsToIfL $
+ do { mb_res <- lookupKnownKeyThing mb_rdr_env uniq
+ ; case mb_res of
+ Succeeded thing -> return thing
+ Failed msg -> failIfM (pprDiagnostic msg) } }
+
+dsLookupKnownKeyTyCon :: Unique -> DsM TyCon
+dsLookupKnownKeyTyCon uniq
+ = tyThingTyCon <$> dsLookupKnownKey uniq
dsLookupGlobal :: Name -> DsM TyThing
-- Very like GHC.Tc.Utils.Env.tcLookupGlobal
=====================================
compiler/GHC/HsToCore/Pmc/Desugar.hs
=====================================
@@ -21,7 +21,7 @@ import GHC.Types.Id
import GHC.Core.ConLike
import GHC.Types.Name
import GHC.Builtin.Types
-import GHC.Builtin.Names (rationalTyConName, toListName)
+import GHC.Builtin.Names (rationalTyConKey, toListName)
import GHC.Types.SrcLoc
import GHC.Utils.Outputable
import GHC.Utils.Panic
@@ -253,7 +253,7 @@ desugarPat x pat = case pat of
, (HsFractional f) <- val
, negates <- if fl_neg f then 1 else 0
-> do
- rat_tc <- dsLookupTyCon rationalTyConName
+ rat_tc <- dsLookupKnownKeyTyCon rationalTyConKey
let rat_ty = mkTyConTy rat_tc
return $ Just $ PmLit rat_ty (PmLitOverRat negates f)
| otherwise
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -2351,6 +2351,12 @@ lookupType :: Name -- Name of type constructor (e.g. (M TH.Exp))
lookupType tc_name = do { tc <- lift $ dsLookupTyCon tc_name ;
return (mkTyConApp tc []) }
+lookupKnownKeyType :: Unique -- Unique of type constructor (e.g. (M TH.Exp))
+ -> MetaM Type -- The type
+lookupKnownKeyType tc_key
+ = do { tc <- lift $ dsLookupKnownKeyTyCon tc_key
+ ; return (mkTyConApp tc []) }
+
wrapGenSyms :: [GenSymBind]
-> Core (M a) -> MetaM (Core (M a))
-- wrapGenSyms [(nm1,id1), (nm2,id2)] y
@@ -3086,7 +3092,7 @@ mk_integer :: Integer -> MetaM (HsLit GhcTc)
mk_integer i = return $ XLit $ HsInteger NoSourceText i integerTy
mk_rational :: FractionalLit -> MetaM (HsLit GhcTc)
-mk_rational r = do rat_ty <- lookupType rationalTyConName
+mk_rational r = do rat_ty <- lookupKnownKeyType rationalTyConKey
return $ XLit $ HsRat r rat_ty
mk_string :: FastString -> MetaM (HsLit GhcRn)
=====================================
compiler/GHC/Iface/Env.hs
=====================================
@@ -41,7 +41,10 @@ import GHC.Types.Avail
import GHC.Types.Name.Cache
import GHC.Types.Unique.Supply
import GHC.Types.SrcLoc
+import GHC.Types.Unique
+import GHC.Utils.Misc( HasDebugCallStack )
+import GHC.Utils.Panic( callStackDoc )
import GHC.Utils.Outputable
import GHC.Utils.Error
import GHC.Utils.Logger
@@ -59,20 +62,21 @@ import Control.Monad
See Also: Note [The Name Cache] in GHC.Types.Name.Cache
-}
-newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name
+newGlobalBinder :: HasDebugCallStack => Module -> OccName -> Maybe Unique
+ -> SrcSpan -> TcRnIf a b Name
-- Used for source code and interface files, to make the
-- Name for a thing, given its Module and OccName
-- See Note [The Name Cache] in GHC.Types.Name.Cache
--
-- The cache may already have a binding for this thing,
--- because we may have seen an occurrence before, but now is the
+-- because we may have seen an /occurrence/ before, but now is the
-- moment when we know its Module and SrcLoc in their full glory
-newGlobalBinder mod occ loc
+newGlobalBinder mod occ mb_uniq loc
= do { hsc_env <- getTopEnv
- ; name <- liftIO $ allocateGlobalBinder (hsc_NC hsc_env) mod occ loc
+ ; name <- liftIO $ allocateGlobalBinder (hsc_NC hsc_env) mod occ mb_uniq loc
; traceIf (text "newGlobalBinder" <+>
- (vcat [ ppr mod <+> ppr occ <+> ppr loc, ppr name]))
+ vcat [ ppr mod <+> ppr occ <+> ppr loc, ppr name, callStackDoc])
; return name }
newInteractiveBinder :: HscEnv -> OccName -> SrcSpan -> IO Name
@@ -80,14 +84,14 @@ newInteractiveBinder :: HscEnv -> OccName -> SrcSpan -> IO Name
-- from the interactive context
newInteractiveBinder hsc_env occ loc = do
let mod = icInteractiveModule (hsc_IC hsc_env)
- allocateGlobalBinder (hsc_NC hsc_env) mod occ loc
+ allocateGlobalBinder (hsc_NC hsc_env) mod occ Nothing loc
allocateGlobalBinder
:: NameCache
- -> Module -> OccName -> SrcSpan
+ -> Module -> OccName -> Maybe Unique -> SrcSpan
-> IO Name
-- See Note [The Name Cache] in GHC.Types.Name.Cache
-allocateGlobalBinder nc mod occ loc
+allocateGlobalBinder nc mod occ mb_uniq loc
= updateNameCache nc mod occ $ \cache0 -> do
case lookupOrigNameCache cache0 mod occ of
-- A hit in the cache! We are at the binding site of the name.
@@ -109,17 +113,23 @@ allocateGlobalBinder nc mod occ loc
Just name | isWiredInName name
-> pure (cache0, name)
| otherwise
- -> pure (new_cache, name')
+ -> warnPprTrace wrong_unique "allocateGlobalBinder" (ppr mb_uniq $$ ppr name) $
+ pure (new_cache, name')
where
uniq = nameUnique name
name' = mkExternalName uniq mod occ loc
-- name' is like name, but with the right SrcSpan
new_cache = extendOrigNameCache cache0 mod occ name'
+ wrong_unique = case mb_uniq of
+ Nothing -> False
+ Just kn_uniq -> kn_uniq /= uniq
-- Miss in the cache!
-- Build a completely new Name, and put it in the cache
_ -> do
- uniq <- takeUniqFromNameCache nc
+ uniq <- case mb_uniq of
+ Just uniq -> return uniq
+ Nothing -> takeUniqFromNameCache nc
let name = mkExternalName uniq mod occ loc
let new_cache = extendOrigNameCache cache0 mod occ name
pure (new_cache, name)
@@ -178,7 +188,7 @@ externaliseName mod name
setNameModule :: Maybe Module -> Name -> TcRnIf m n Name
setNameModule Nothing n = return n
setNameModule (Just m) n =
- newGlobalBinder m (nameOccName n) (nameSrcSpan n)
+ newGlobalBinder m (nameOccName n) Nothing (nameSrcSpan n)
{-
************************************************************************
=====================================
compiler/GHC/Iface/Env.hs-boot deleted
=====================================
@@ -1,9 +0,0 @@
-module GHC.Iface.Env where
-
-import GHC.Unit.Module
-import GHC.Types.Name.Occurrence
-import GHC.Tc.Utils.Monad
-import GHC.Types.Name
-import GHC.Types.SrcLoc
-
-newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name
=====================================
compiler/GHC/Iface/Load.hs
=====================================
@@ -9,13 +9,14 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE ScopedTypeVariables #-}
-- | Loading interface files
module GHC.Iface.Load (
-- Importing one thing
- tcLookupImported_maybe, importDecl,
+ importDecl,
checkWiredInTyCon, ifCheckWiredInThing,
- lookupImportedKnownKey,
+ lookupKnownKeyThing, loadGlobalName,
-- RnM/TcM functions
loadModuleInterface, loadModuleInterfaces,
@@ -71,6 +72,7 @@ import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import GHC.Utils.Constants (debugIsOn)
import GHC.Utils.Logger
+import GHC.Utils.Misc( HasDebugCallStack )
import GHC.Settings.Constants
@@ -86,6 +88,7 @@ import GHC.Types.Annotations
import GHC.Types.Name
import GHC.Types.Name.Cache
import GHC.Types.Name.Env
+import GHC.Types.Name.Reader
import GHC.Types.Avail
import GHC.Types.Fixity
import GHC.Types.Fixity.Env
@@ -94,6 +97,7 @@ import GHC.Types.SourceFile
import GHC.Types.SafeHaskell
import GHC.Types.TypeEnv
import GHC.Types.Unique.DSet
+import GHC.Types.Unique.FM( listToUFM, lookupUFM )
import GHC.Types.SrcLoc
import GHC.Types.TyThing
import GHC.Types.PkgQual
@@ -122,10 +126,158 @@ import Data.Function ((&))
import GHC.Unit.Module.Graph
import qualified GHC.Unit.Home.Graph as HUG
+
+{- *********************************************************************
+* *
+* Known-key things *
+* *
+********************************************************************* -}
+
+lookupKnownKeyThing :: HasDebugCallStack
+ => Maybe GlobalRdrEnv -> Unique
+ -> IfM lcl (MaybeErr IfaceMessage TyThing)
+lookupKnownKeyThing Nothing uniq
+ = do { known_key_name_map <- loadKnownKeyOccMap
+ ; let name = lookupUFM known_key_name_map uniq
+ `orElse` pprPanic "lookupKnownKeyThing" (ppr uniq)
+ ; lookupGlobalName name }
+
+lookupKnownKeyThing (Just gbl_rdr_env) uniq
+ -- Look up the known-key OccName in the current top-level GlobalRdrEnv
+ -- If we get a unique hit, use it; if not, panic.
+ = case lookupGRE gbl_rdr_env (LookupOccName occ SameNameSpace) of
+ [gre] -> lookupGlobalName (greName gre)
+ gres -> pprPanic "lookupKnownKeyOcc" (ppr occ $$ ppr gres)
+ where
+ occ = lookupUFM knownKeyUniqMap uniq
+ `orElse` pprPanic "lookupKnownKeyThing" (ppr uniq)
+
+loadKnownKeyOccMap :: IfM lcl KnownKeyNameMap
+loadKnownKeyOccMap
+ = do { eps <- getEps
+ ; case eps_known_keys eps of {
+ Just occ_map -> return occ_map ;
+ Nothing ->
+
+ -- We don't have a KnownKeyOccMap yet, so create it
+ -- from the interface file for KnownKeyName
+ do { hsc_env <- getTopEnv
+ ; mb_res <- liftIO $ findImportedModule hsc_env kNOWN_KEY_NAMES NoPkgQual
+ ; iface <- case mb_res of
+ Found _ mod -> loadInterfaceWithException doc mod ImportBySystem
+ _ -> panic "loadKnownKeyOccMap" -- ToDo tidy up
+
+ ; let occ_map :: KnownKeyNameMap
+ occ_map = listToUFM [ (getUnique nm, nm)
+ | avail <- mi_exports iface
+ , nm <- availNames avail ]
+
+ -- Record the KnownKeyOccMap in the EPS, so we will find it next time
+ ; updateEps_ (\eps -> eps { eps_known_keys = Just occ_map })
+
+ ; return occ_map } } }
+ where
+ doc = text "Need interface for KnonwKeyNames"
+
+
+{- *********************************************************************
+* *
+* Global things
+* *
+********************************************************************* -}
+
+lookupGlobalName :: Name -> IfM lcl (MaybeErr IfaceMessage TyThing)
+-- Only works for External Names that have a Module
+lookupGlobalName name = loadGlobalName name (nameModule name)
+
+loadGlobalName :: forall lcl.
+ Name
+ -> Module -- Use this for non-External Names (maybe Backpack-related?)
+ -> IfM lcl (MaybeErr IfaceMessage TyThing)
+loadGlobalName name mod
+ = do { env <- getGblEnv
+ ; case lookupKnotVars (if_rec_types env) mod of
+ -- Note [Tying the knot]
+ Just get_type_env
+ -> do -- It's defined in a module in the hs-boot loop
+ { type_env <- setLclEnv () get_type_env -- yuk
+ ; case lookupNameEnv type_env name of
+ Just thing -> return (Succeeded thing)
+ -- See Note [Knot-tying fallback on boot]
+ Nothing -> via_external
+ }
+
+ _ -> via_external }
+ where
+ via_external = do { hsc_env <- getTopEnv
+ ; mb_thing <- liftIO (lookupType hsc_env name)
+ ; case mb_thing of
+ Just thing -> return (Succeeded thing)
+ Nothing -> importDecl name }
+
+-- Note [Tying the knot]
+-- ~~~~~~~~~~~~~~~~~~~~~
+-- The if_rec_types field is used when we are compiling M.hs, which indirectly
+-- imports Foo.hi, which mentions M.T Then we look up M.T in M's type
+-- environment, which is splatted into if_rec_types after we've built M's type
+-- envt.
+--
+-- This is a dark and complicated part of GHC type checking, with a lot
+-- of moving parts. Interested readers should also look at:
+--
+-- * Note [Knot-tying typecheckIface]
+-- * Note [DFun knot-tying]
+-- * Note [hsc_type_env_var hack]
+-- * Note [Knot-tying fallback on boot]
+-- * Note [Hydrating Modules]
+--
+-- There is also a wiki page on the subject, see:
+--
+-- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/tying-the-knot
+
+-- Note [Knot-tying fallback on boot]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- Suppose that you are typechecking A.hs, which transitively imports,
+-- via B.hs, A.hs-boot. When we poke on B.hs and discover that it
+-- has a reference to a type T from A, what TyThing should we wire
+-- it up with? Clearly, if we have already typechecked T and
+-- added it into the type environment, we should go ahead and use that
+-- type. But what if we haven't typechecked it yet?
+--
+-- For the longest time, GHC adopted the policy that this was
+-- *an error condition*; that you MUST NEVER poke on B.hs's reference
+-- to a T defined in A.hs until A.hs has gotten around to kind-checking
+-- T and adding it to the env. However, actually ensuring this is the
+-- case has proven to be a bug farm, because it's really difficult to
+-- actually ensure this never happens. The problem was especially poignant
+-- with type family consistency checks, which eagerly happen before any
+-- typechecking takes place.
+--
+-- Today, we take a different strategy: if we ever try to access
+-- an entity from A which doesn't exist, we just fall back on the
+-- definition of A from the hs-boot file. This is complicated in
+-- its own way: it means that you may end up with a mix of A.hs and
+-- A.hs-boot TyThings during the course of typechecking. We don't
+-- think (and have not observed) any cases where this would cause
+-- problems, but the hypothetical situation one might worry about
+-- is something along these lines in Core:
+--
+-- case x of
+-- A -> e1
+-- B -> e2
+--
+-- If, when typechecking this, we find x :: T, and the T we are hooked
+-- up with is the abstract one from the hs-boot file, rather than the
+-- one defined in this module with constructors A and B. But it's hard
+-- to see how this could happen, especially because the reference to
+-- the constructor (A and B) means that GHC will always typecheck
+-- this expression *after* typechecking T.
+
+
{-
************************************************************************
* *
-* tcImportDecl is the key function for "faulting in" *
+* importDecl is the key function for "faulting in" *
* imported things
* *
************************************************************************
@@ -148,61 +300,8 @@ where the code that e1 expands to might import some defns that
also turn out to be needed by the code that e2 expands to.
-}
-tcLookupImported_maybe :: Name -> TcM (MaybeErr IfaceMessage TyThing)
--- Returns (Failed err) if we can't find the interface file for the thing
-tcLookupImported_maybe name
- = do { hsc_env <- getTopEnv
- ; mb_thing <- liftIO (lookupType hsc_env name)
- ; case mb_thing of
- Just thing -> return (Succeeded thing)
- Nothing -> tcImportDecl_maybe name }
-
-tcImportDecl_maybe :: Name -> TcM (MaybeErr IfaceMessage TyThing)
--- Entry point for *source-code* uses of importDecl
-tcImportDecl_maybe name
- | Just thing <- wiredInNameTyThing_maybe name
- = do { when (needWiredInHomeIface thing)
- (initIfaceTcRn (loadWiredInHomeIface name))
- -- See Note [Loading instances for wired-in things]
- ; return (Succeeded thing) }
- | otherwise
- = initIfaceTcRn (importDecl name)
-
-lookupImportedKnownKey :: OccName -> IfM lcl (MaybeErr IfaceMessage TyThing)
-lookupImportedKnownKey occ
- = do { known_key_occ_map <- loadKnownKeyOccMap
- ; let name = lookupOccEnv known_key_occ_map occ
- `orElse` pprPanic "lookupImportedKnownKey" (ppr occ)
- ; importDecl name }
-
-loadKnownKeyOccMap :: IfM lcl KnownKeyOccMap
-loadKnownKeyOccMap
- = do { eps <- getEps
- ; case eps_known_keys eps of {
- Just occ_map -> return occ_map ;
- Nothing ->
-
- -- We don't have a KnownKeyOccMap yet, so created it
- -- from the interface file for KnownKeyName
- do { hsc_env <- getTopEnv
- ; mb_res <- liftIO $ findImportedModule hsc_env kNOWN_KEY_NAMES NoPkgQual
- ; iface <- case mb_res of
- Found _ mod -> loadInterfaceWithException doc mod ImportBySystem
- _ -> panic "loadKnownKeyOccMap" -- ToDo tidy up
-
- ; let occ_map :: KnownKeyOccMap
- occ_map = mkOccEnv [ (getOccName nm, nm)
- | avail <- mi_exports iface
- , nm <- availNames avail ]
-
- -- Record the KnownKeyOccMap in the EPS, so we will find it next time
- ; updateEps_ (\eps -> eps { eps_known_keys = Just occ_map })
-
- ; return occ_map } } }
- where
- doc = text "Need interface for KnonwKeyNames"
-importDecl :: Name -> IfM lcl (MaybeErr IfaceMessage TyThing)
+importDecl :: HasDebugCallStack => Name -> IfM lcl (MaybeErr IfaceMessage TyThing)
-- Get the TyThing for this Name from an interface file
-- It's not a wired-in thing -- the caller caught that
importDecl name
@@ -222,7 +321,8 @@ importDecl name
{ eps <- getEps
; case lookupTypeEnv (eps_PTE eps) name of
Just thing -> return $ Succeeded thing
- Nothing -> return $ Failed $
+ Nothing -> pprTrace "importDecl" (ppr name $$ callStackDoc) $
+ return $ Failed $
Can'tFindNameInInterface name
(filter is_interesting $ nonDetNameEnvElts $ eps_PTE eps)
}}}
=====================================
compiler/GHC/Iface/Tidy.hs
=====================================
@@ -1107,7 +1107,7 @@ tidyTopName mod name_cache maybe_ref occ_env id
-- This is necessary because the byte-code generator the byte-code
-- generator builds a system-wide Name->BCO symbol table.
- | local && external = do new_external_name <- allocateGlobalBinder name_cache mod occ' loc
+ | local && external = do new_external_name <- allocateGlobalBinder name_cache mod occ' Nothing loc
return (occ_env', new_external_name)
-- If we want to externalise a currently-local name, check
-- whether we have already assigned a unique for it.
=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -12,7 +12,6 @@ Type checking of type signatures in interface files
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
module GHC.IfaceToCore (
- tcLookupImported_maybe,
importDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface,
typecheckWholeCoreBindings,
tcIfaceDefaults,
@@ -33,7 +32,6 @@ import GHC.Prelude
import GHC.ByteCode.Types
-import GHC.Driver.Env
import GHC.Driver.Session
import GHC.Driver.Config.Core.Lint ( initLintConfig )
@@ -2046,91 +2044,13 @@ tcIfaceGlobal name
= do { ifCheckWiredInThing thing; return thing }
| otherwise
- = do { env <- getGblEnv
- ; cur_mod <- if_mod <$> getLclEnv
- ; case lookupKnotVars (if_rec_types env) (fromMaybe cur_mod (nameModule_maybe name)) of
- -- Note [Tying the knot]
- Just get_type_env
- -> do -- It's defined in a module in the hs-boot loop
- { type_env <- setLclEnv () get_type_env -- yuk
- ; case lookupNameEnv type_env name of
- Just thing -> return thing
- -- See Note [Knot-tying fallback on boot]
- Nothing -> via_external
- }
-
- _ -> via_external }
- where
- via_external = do
- { hsc_env <- getTopEnv
- ; mb_thing <- liftIO (lookupType hsc_env name)
- ; case mb_thing of {
- Just thing -> return thing ;
- Nothing -> do
-
- { mb_thing <- importDecl name -- It's imported; go get it
- ; case mb_thing of
+ = do { mod <- case nameModule_maybe name of
+ Just mod -> return mod
+ Nothing -> if_mod <$> getLclEnv
+ ; mb_thing <- loadGlobalName name mod
+ ; case mb_thing of
Failed err -> failIfM (ppr name <+> pprDiagnostic err)
- Succeeded thing -> return thing
- }}}
-
--- Note [Tying the knot]
--- ~~~~~~~~~~~~~~~~~~~~~
--- The if_rec_types field is used when we are compiling M.hs, which indirectly
--- imports Foo.hi, which mentions M.T Then we look up M.T in M's type
--- environment, which is splatted into if_rec_types after we've built M's type
--- envt.
---
--- This is a dark and complicated part of GHC type checking, with a lot
--- of moving parts. Interested readers should also look at:
---
--- * Note [Knot-tying typecheckIface]
--- * Note [DFun knot-tying]
--- * Note [hsc_type_env_var hack]
--- * Note [Knot-tying fallback on boot]
--- * Note [Hydrating Modules]
---
--- There is also a wiki page on the subject, see:
---
--- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/tying-the-knot
-
--- Note [Knot-tying fallback on boot]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- Suppose that you are typechecking A.hs, which transitively imports,
--- via B.hs, A.hs-boot. When we poke on B.hs and discover that it
--- has a reference to a type T from A, what TyThing should we wire
--- it up with? Clearly, if we have already typechecked T and
--- added it into the type environment, we should go ahead and use that
--- type. But what if we haven't typechecked it yet?
---
--- For the longest time, GHC adopted the policy that this was
--- *an error condition*; that you MUST NEVER poke on B.hs's reference
--- to a T defined in A.hs until A.hs has gotten around to kind-checking
--- T and adding it to the env. However, actually ensuring this is the
--- case has proven to be a bug farm, because it's really difficult to
--- actually ensure this never happens. The problem was especially poignant
--- with type family consistency checks, which eagerly happen before any
--- typechecking takes place.
---
--- Today, we take a different strategy: if we ever try to access
--- an entity from A which doesn't exist, we just fall back on the
--- definition of A from the hs-boot file. This is complicated in
--- its own way: it means that you may end up with a mix of A.hs and
--- A.hs-boot TyThings during the course of typechecking. We don't
--- think (and have not observed) any cases where this would cause
--- problems, but the hypothetical situation one might worry about
--- is something along these lines in Core:
---
--- case x of
--- A -> e1
--- B -> e2
---
--- If, when typechecking this, we find x :: T, and the T we are hooked
--- up with is the abstract one from the hs-boot file, rather than the
--- one defined in this module with constructors A and B. But it's hard
--- to see how this could happen, especially because the reference to
--- the constructor (A and B) means that GHC will always typecheck
--- this expression *after* typechecking T.
+ Succeeded thing -> return thing }
tcIfaceTyCon :: IfaceTyCon -> IfL TyCon
tcIfaceTyCon (IfaceTyCon name _info)
=====================================
compiler/GHC/Rename/Env.hs
=====================================
@@ -68,7 +68,11 @@ import GHC.Tc.Utils.Env
import GHC.Tc.Types.LclEnv
import GHC.Tc.Utils.Monad
import GHC.Parser.PostProcess ( setRdrNameSpace )
+
import GHC.Builtin.Types
+import GHC.Builtin.Utils( knownKeyOccMap )
+import GHC.Builtin.Names( rOOT_MAIN )
+
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.Name.Env
@@ -79,11 +83,11 @@ import GHC.Unit.Module.ModIface
import GHC.Core.ConLike
import GHC.Core.DataCon
import GHC.Core.TyCon
-import GHC.Builtin.Names( rOOT_MAIN )
import GHC.Types.Basic ( TupleSort(..), tupleSortBoxity )
import GHC.Types.TyThing ( tyThingGREInfo )
import GHC.Types.SrcLoc as SrcLoc
import GHC.Utils.Outputable as Outputable
+import GHC.Types.Unique
import GHC.Types.Unique.FM
import GHC.Types.Unique.DSet
import GHC.Types.Unique.Set
@@ -224,11 +228,11 @@ newTopSrcBinder (L loc rdr_name)
-- the RdrName, not from the environment. In principle, it'd be fine to
-- have an arbitrary mixture of external core definitions in a single module,
-- (apart from module-initialisation issues, perhaps).
- ; newGlobalBinder rdr_mod rdr_occ (locA loc) }
+ ; newGlobalBinder rdr_mod rdr_occ Nothing (locA loc) }
| otherwise
- = do { when (isQual rdr_name)
- (addErrAt (locA loc) (badQualBndrErr rdr_name))
+ = do { when (isQual rdr_name) $
+ addErrAt (locA loc) (badQualBndrErr rdr_name)
-- Binders should not be qualified; if they are, and with a different
-- module name, we get a confusing "M.T is not in scope" error later
@@ -239,11 +243,30 @@ newTopSrcBinder (L loc rdr_name)
do { uniq <- newUnique
; return (mkInternalName uniq (rdrNameOcc rdr_name) (locA loc)) }
else
- do { this_mod <- getModule
- ; traceRn "newTopSrcBinder" (ppr this_mod $$ ppr rdr_name $$ ppr (locA loc))
- ; newGlobalBinder this_mod (rdrNameOcc rdr_name) (locA loc) }
+ -- Finally we get the "normal path"; an ordinary, top-level binding
+ newTopVanillaSrcBinder (rdrNameOcc rdr_name) (locA loc)
}
+newTopVanillaSrcBinder :: OccName -> SrcSpan -> RnM Name
+newTopVanillaSrcBinder occ loc
+ = do { this_mod <- getModule
+
+ -- See if this bindings is for a known-key name, and if so get its Unique
+ ; defines_known_keys <- xoptM LangExt.DefinesKnownKeyNames
+ ; let mb_uniq :: Maybe Unique
+ mb_uniq | defines_known_keys = lookupOccEnv knownKeyOccMap occ
+ | otherwise = Nothing
+
+ ; name <- newGlobalBinder this_mod occ mb_uniq loc
+ ; traceRn "newTopSrcBinder" $
+ vcat [ text "module:" <+> ppr this_mod
+ , text "occ:" <+> ppr occ
+ , text "mb_uniq:" <+> ppr mb_uniq
+ , text "loc:" <+> ppr loc
+ , text "name:" <+> ppr name ]
+ ; return name
+ }
+
{-
*********************************************************
* *
=====================================
compiler/GHC/Tc/Deriv/Generics.hs
=====================================
@@ -445,7 +445,7 @@ gen_Generic_fam_inst gk get_fixity loc
; mod <- getModule
; let tc_occ = nameOccName (tyConName tycon)
rep_occ = case gk of Gen0 -> mkGenR tc_occ; Gen1 -> mkGen1R tc_occ
- ; rep_name <- newGlobalBinder mod rep_occ loc
+ ; rep_name <- newGlobalBinder mod rep_occ Nothing loc
; let tcv = tyCoVarsOfTypeList inst_ty
(tv, cv) = partition isTyVar tcv
=====================================
compiler/GHC/Tc/Gen/Splice.hs
=====================================
@@ -76,7 +76,6 @@ import GHC.ThToHs
import GHC.HsToCore.Docs
import GHC.HsToCore.Expr
import GHC.HsToCore.Monad
-import GHC.IfaceToCore
import GHC.Iface.Load
import GHCi.Message
=====================================
compiler/GHC/Tc/Instance/Typeable.hs
=====================================
@@ -188,7 +188,7 @@ mkModIdBindings :: TcM TcGblEnv
mkModIdBindings
= do { mod <- getModule
; loc <- getSrcSpanM
- ; mod_nm <- newGlobalBinder mod (mkVarOccFS (fsLit "$trModule")) loc
+ ; mod_nm <- newGlobalBinder mod (mkVarOccFS (fsLit "$trModule")) Nothing loc
; trModuleTyCon <- tcLookupTyCon trModuleTyConName
; let mod_id = mkExportedVanillaId mod_nm (mkTyConApp trModuleTyCon [])
; mod_bind <- mkVarBind mod_id <$> mkModIdRHS mod
=====================================
compiler/GHC/Tc/TyCl/Build.hs
=====================================
@@ -429,7 +429,7 @@ newImplicitBinderLoc :: Name -- Base name
-- Just the same, but lets you specify the SrcSpan
newImplicitBinderLoc base_name mk_sys_occ loc
| Just mod <- nameModule_maybe base_name
- = newGlobalBinder mod occ loc
+ = newGlobalBinder mod occ Nothing loc
| otherwise -- When typechecking a [d| decl bracket |],
-- TH generates types, classes etc with Internal names,
-- so we follow suit for the implicit binders
@@ -443,6 +443,6 @@ newTyConRepName :: Name -> TcRnIf gbl lcl TyConRepName
newTyConRepName tc_name
| Just mod <- nameModule_maybe tc_name
, (mod, occ) <- tyConRepModOcc mod (nameOccName tc_name)
- = newGlobalBinder mod occ noSrcSpan
+ = newGlobalBinder mod occ Nothing noSrcSpan
| otherwise
= newImplicitBinder tc_name mkTyConRepOcc
=====================================
compiler/GHC/Tc/Types.hs
=====================================
@@ -355,10 +355,9 @@ data IfGblEnv
-- We need the module name so we can test when it's appropriate
-- to look in this env.
-- See Note [Tying the knot] in GHC.IfaceToCore
- if_rec_types :: (KnotVars (IfG TypeEnv))
+ if_rec_types :: KnotVars (IfG TypeEnv)
-- Allows a read effect, so it can be in a mutable
-- variable; c.f. handling the external package type env
- -- Nothing => interactive stuff, no loops possible
}
data IfLclEnv
=====================================
compiler/GHC/Tc/Utils/Env.hs
=====================================
@@ -24,6 +24,7 @@ module GHC.Tc.Utils.Env(
tcLookupRecSelParent,
tcLookupLocatedGlobalId, tcLookupLocatedTyCon,
tcLookupLocatedClass, tcLookupAxiom,
+ tcLookupImported_maybe,
lookupGlobal, lookupGlobal_maybe,
addTypecheckedBinds, addEvBinds, addTopEvBinds,
failIllegalTyCon, failIllegalTyVar,
@@ -58,8 +59,8 @@ module GHC.Tc.Utils.Env(
-- Template Haskell stuff
LevelCheckReason(..),
- tcMetaTy, thLevelIndex,
- isBrackLevel,
+ tcMetaTy, tcMetaKnownKeyTy,
+ thLevelIndex, isBrackLevel,
-- New Ids
newDFunName,
@@ -268,6 +269,26 @@ tcLookupGlobal name
Failed msg -> failWithTc (TcRnInterfaceError msg)
}}}
+tcLookupImported_maybe :: Name -> TcM (MaybeErr IfaceMessage TyThing)
+-- Returns (Failed err) if we can't find the interface file for the thing
+tcLookupImported_maybe name
+ = do { hsc_env <- getTopEnv
+ ; mb_thing <- liftIO (lookupType hsc_env name)
+ ; case mb_thing of
+ Just thing -> return (Succeeded thing)
+ Nothing -> tcImportDecl_maybe name }
+
+tcImportDecl_maybe :: Name -> TcM (MaybeErr IfaceMessage TyThing)
+-- Entry point for *source-code* uses of importDecl
+tcImportDecl_maybe name
+ | Just thing <- wiredInNameTyThing_maybe name
+ = do { when (needWiredInHomeIface thing)
+ (initIfaceTcRn (loadWiredInHomeIface name))
+ -- See Note [Loading instances for wired-in things]
+ ; return (Succeeded thing) }
+ | otherwise
+ = initIfaceTcRn (importDecl name)
+
-- Look up only in this module's global env't. Don't look in imports, etc.
-- Panic if it's not there.
tcLookupGlobalOnly :: Name -> TcM TyThing
@@ -932,13 +953,25 @@ tcExtendRules lcl_rules thing_inside
************************************************************************
-}
+tcMetaKnownKeyTy :: HasDebugCallStack => Unique -> TcM Type
+tcMetaKnownKeyTy uniq
+ = do { normal_path <- xoptM LangExt.ImplicitKnownKeyNames
+ ; mb_rdr_env <- if normal_path
+ then return Nothing
+ else Just <$> getGlobalRdrEnv
+ ; mb_thing <- initIfaceTcRn (lookupKnownKeyThing mb_rdr_env uniq)
+ ; case mb_thing of
+ Succeeded (ATyCon tc) -> return (mkTyConTy tc)
+ Succeeded thing -> wrongThingErr WrongThingTyCon (AGlobal thing) (getName thing)
+ Failed msg -> failWithTc (TcRnInterfaceError msg) }
+
tcMetaTy :: Name -> TcM Type
-- Given the name of a Template Haskell data type,
-- return the type
-- E.g. given the name "Expr" return the type "Expr"
-tcMetaTy tc_name = do
- t <- tcLookupTyCon tc_name
- return (mkTyConTy t)
+tcMetaTy tc_name
+ = do { t <- tcLookupTyCon tc_name
+ ; return (mkTyConTy t) }
isBrackLevel :: ThLevel -> Bool
isBrackLevel (Brack {}) = True
@@ -1135,7 +1168,7 @@ newDFunName clas tys loc
; let info_string = occNameString (getOccName clas) ++
concatMap (occNameString . getDFunTyKey) tys
; dfun_occ <- chooseUniqueOccTc (mkDFunOcc info_string is_boot)
- ; newGlobalBinder mod dfun_occ loc }
+ ; newGlobalBinder mod dfun_occ Nothing loc }
newFamInstTyConName :: LocatedN Name -> [Type] -> TcM Name
newFamInstTyConName (L loc name) tys = mk_fam_inst_name id (locA loc) name [tys]
@@ -1150,7 +1183,7 @@ mk_fam_inst_name adaptOcc loc tc_name tyss
; let info_string = occNameString (getOccName tc_name) ++
intercalate "|" ty_strings
; occ <- chooseUniqueOccTc (mkInstTyTcOcc info_string)
- ; newGlobalBinder mod (adaptOcc occ) loc }
+ ; newGlobalBinder mod (adaptOcc occ) Nothing loc }
where
ty_strings = map (concatMap (occNameString . getDFunTyKey)) tyss
@@ -1262,8 +1295,8 @@ notFound name
}
wrongThingErr :: WrongThingSort -> TcTyThing -> Name -> TcM a
-wrongThingErr expected thing name =
- failWithTc (TcRnTyThingUsedWrong expected thing name)
+wrongThingErr expected thing name
+ = failWithTc (TcRnTyThingUsedWrong expected thing name)
{- Note [Out of scope might be a staging error]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Tc/Utils/Instantiate.hs
=====================================
@@ -796,7 +796,7 @@ mkOverLit (HsIntegral i)
; return (XLit $ HsInteger (il_text i) (il_value i) integer_ty) }
mkOverLit (HsFractional r)
- = do { rat_ty <- tcMetaTy rationalTyConName
+ = do { rat_ty <- tcMetaKnownKeyTy rationalTyConKey
; return (XLit $ HsRat r rat_ty) }
mkOverLit (HsIsString src s) = return (HsString src s)
=====================================
compiler/GHC/Tc/Utils/Monad.hs
=====================================
@@ -2391,8 +2391,8 @@ initIfaceTcRn thing_inside
-- bangs to avoid leaking the envs (#19356)
; let !mhome_unit = hsc_home_unit_maybe hsc_env
!knot_vars = tcg_type_env_var tcg_env
- -- When we are instantiating a signature, we DEFINITELY
- -- do not want to knot tie.
+ -- When we are instantiating a signature,
+ -- we DEFINITELY do not want to knot tie.
is_instantiate = fromMaybe False (isHomeUnitInstantiating <$> mhome_unit)
; let { if_env = IfGblEnv {
if_doc = text "initIfaceTcRn",
=====================================
compiler/GHC/Types/Name/Cache.hs
=====================================
@@ -32,6 +32,7 @@ import GHC.Builtin.Utils
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Misc( HasDebugCallStack )
import Control.Applicative
import Control.Concurrent.MVar
@@ -134,12 +135,12 @@ lookupOrigNameCache nc mod occ = lookup_infinite <|> lookup_normal
occ_env <- lookupModuleEnv nc mod
lookupOccEnv occ_env occ
-extendOrigNameCache' :: OrigNameCache -> Name -> OrigNameCache
+extendOrigNameCache' :: HasDebugCallStack => OrigNameCache -> Name -> OrigNameCache
extendOrigNameCache' nc name
= assertPpr (isExternalName name) (ppr name) $
extendOrigNameCache nc (nameModule name) (nameOccName name) name
-extendOrigNameCache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache
+extendOrigNameCache :: HasDebugCallStack => OrigNameCache -> Module -> OccName -> Name -> OrigNameCache
extendOrigNameCache nc mod occ name
= extendModuleEnvWith combine nc mod (unitOccEnv occ name)
where
=====================================
compiler/GHC/Unit/External.hs
=====================================
@@ -3,6 +3,7 @@ module GHC.Unit.External
, initExternalUnitCache
, eucEPS
, ExternalPackageState (..)
+ , KnownKeyNameMap
, initExternalPackageState
, EpsStats(..)
, addEpsInStats
@@ -21,8 +22,6 @@ import GHC.Prelude
import GHC.Unit
import GHC.Unit.Module.ModIface
-import GHC.Builtin.Utils( KnownKeyOccMap)
-
import GHC.Core.FamInstEnv
import GHC.Core.InstEnv ( InstEnv, emptyInstEnv )
import GHC.Core.Opt.ConstantFold
@@ -32,7 +31,10 @@ import GHC.Types.Annotations ( AnnEnv, emptyAnnEnv )
import GHC.Types.CompleteMatch
import GHC.Types.DefaultEnv (DefaultEnv)
import GHC.Types.TypeEnv
+import GHC.Types.Name( Name )
+import GHC.Types.Unique( Unique )
import GHC.Types.Unique.DSet
+import GHC.Types.Unique.FM( UniqFM )
import GHC.Linker.Types (Linkable)
@@ -153,7 +155,7 @@ data ExternalPackageState
-- See Note [Interface Files with Core Definitions]
eps_iface_bytecode :: !(ModuleEnv (IO Linkable)),
- eps_known_keys :: Maybe KnownKeyOccMap, -- ^ See Note [Overview of KnownKeyNames]
+ eps_known_keys :: Maybe KnownKeyNameMap, -- ^ See Note [Overview of KnownKeyNames]
eps_inst_env :: !PackageInstEnv, -- ^ The total 'InstEnv' accumulated
-- from all the external-package modules
@@ -174,6 +176,8 @@ data ExternalPackageState
eps_defaults :: !(ModuleEnv DefaultEnv) -- ^ Default declarations exported by external packages
}
+type KnownKeyNameMap = UniqFM Unique Name -- See Note [Overview of known-key Names]
+
-- | Accumulated statistics about what we are putting into the 'ExternalPackageState'.
-- \"In\" means stuff that is just /read/ from interface files,
-- \"Out\" means actually sucked in and type-checked
=====================================
libraries/base/base.cabal.in
=====================================
@@ -28,7 +28,7 @@ extra-doc-files:
Library
default-language: Haskell2010
- default-extensions: NoImplicitPrelude
+ default-extensions: NoImplicitPrelude, NoImplicitKnownKeyNames
build-depends:
ghc-internal == @ProjectVersionForLib@.*,
ghc-prim,
=====================================
libraries/ghc-internal/ghc-internal.cabal.in
=====================================
@@ -81,6 +81,7 @@ Library
default-language: Haskell2010
default-extensions:
NoImplicitPrelude
+ NoImplicitKnownKeyNames
other-extensions:
BangPatterns
CApiFFI
=====================================
libraries/ghc-internal/src/GHC/Internal/LanguageExtensions.hs
=====================================
@@ -55,7 +55,8 @@ data Extension
| QuasiQuotes
| ImplicitParams
| ImplicitPrelude
- | ImplicitKnownKeyNames -- TODO: Note for knownkey names
+ | ImplicitKnownKeyNames -- See Note [Overview of known-key names]
+ | DefinesKnownKeyNames -- See Note [Overview of known-key names]
| ScopedTypeVariables
| AllowAmbiguousTypes
| UnboxedTuples
=====================================
libraries/ghc-internal/src/GHC/Internal/Real.hs
=====================================
@@ -1,4 +1,5 @@
{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE DefinesKnownKeyNames #-}
{-# LANGUAGE CPP, NoImplicitPrelude, MagicHash, UnboxedTuples, BangPatterns #-}
{-# OPTIONS_GHC -Wno-orphans #-}
{-# OPTIONS_HADDOCK not-home #-}
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/88d760d98757119c048d701529ceb4b…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/88d760d98757119c048d701529ceb4b…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
14 Mar '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
b5d39cad by Matthew Pickering at 2026-03-14T16:38:37-04:00
Use explicit syntax rather than pure
- - - - -
1 changed file:
- .gitlab/generate-ci/gen_ci.hs
Changes:
=====================================
.gitlab/generate-ci/gen_ci.hs
=====================================
@@ -173,7 +173,7 @@ configureArgsStr :: BuildConfig -> String
configureArgsStr bc = unwords $
["--enable-unregisterised"| unregisterised bc ]
++ ["--disable-tables-next-to-code" | not (tablesNextToCode bc) ]
- ++ ["--with-intree-gmp" | Just _ <- pure (crossTarget bc) ]
+ ++ ["--with-intree-gmp" | Just _ <- [crossTarget bc] ]
++ ["--with-system-libffi" | crossTarget bc == Just "wasm32-wasi" ]
++ ["--enable-ipe-data-compression" | withZstd bc ]
++ ["--enable-strict-ghc-toolchain-check"]
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b5d39cadfeba9f4f2803ff124a78520…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b5d39cadfeba9f4f2803ff124a78520…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] base: fix redundant imports in GHC.Internal.Weak.Finalize
by Marge Bot (＠marge-bot) 14 Mar '26
by Marge Bot (＠marge-bot) 14 Mar '26
14 Mar '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
12a706cf by Cheng Shao at 2026-03-14T16:37:54-04:00
base: fix redundant imports in GHC.Internal.Weak.Finalize
This patch fixes redundant imports in GHC.Internal.Weak.Finalize that
causes a regression in bootstrapping head from 9.14 with validate
flavours. Fixes #27026.
- - - - -
1 changed file:
- libraries/base/src/GHC/Weak/Finalize.hs
Changes:
=====================================
libraries/base/src/GHC/Weak/Finalize.hs
=====================================
@@ -16,12 +16,9 @@ import GHC.Internal.Weak.Finalize
import GHC.Internal.Base
import GHC.Internal.Exception
-import GHC.Internal.IORef
-import GHC.Internal.Conc.Sync (labelThreadByteArray#, myThreadId)
-import GHC.Internal.IO (catchException, unsafePerformIO)
+import GHC.Internal.IO (catchException)
import GHC.Internal.IO.Handle.Types (Handle)
import GHC.Internal.IO.Handle.Text (hPutStrLn)
-import GHC.Internal.Encoding.UTF8 (utf8EncodeByteArray#)
{-# DEPRECATED runFinalizerBatch
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/12a706cfadceced7e0c441d0871bc0a…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/12a706cfadceced7e0c441d0871bc0a…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 7 commits: configure: make $LLVMAS default to $CC when $CcLlvmBackend is YES
by Marge Bot (＠marge-bot) 14 Mar '26
by Marge Bot (＠marge-bot) 14 Mar '26
14 Mar '26
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
a18fa3c1 by Cheng Shao at 2026-03-14T05:12:14-04:00
configure: make $LLVMAS default to $CC when $CcLlvmBackend is YES
This patch changes the $LLVMAS detection logic in configure so that
when it's not manually specified by the user, it defaults to $CC if
$CcLlvmBackend is YES. It's a more sensible default than auto-detected
clang from the environment, especially when cross-compiling, $CC as
the cross target's LLVM assembler is more compatible with the use case
than the system-wide clang. Fixes #26769.
- - - - -
3774086e by Matthew Pickering at 2026-03-14T05:13:00-04:00
exceptions: annotate onException continuation with WhileHandling
Before this patch, an exception thrown in the `onException` handler
would loose track of where the original exception was thrown.
```
import Control.Exception
main :: IO ()
main = failingAction `onException` failingCleanup
where
failingAction = throwIO (ErrorCall "outer failure")
failingCleanup = throwIO (ErrorCall "cleanup failure")
```
would report
```
T28399: Uncaught exception ghc-internal:GHC.Internal.Exception.ErrorCall:
cleanup failure
HasCallStack backtrace:
throwIO, called at T28399.hs:<line>:<column> in <package-id>:Main
```
notice that the "outer failure" exception is not present in the error
message.
With this patch, any exception thrown is in the handler is annotated
with WhileHandling. The resulting message looks like
```
T28399: Uncaught exception ghc-internal:GHC.Internal.Exception.ErrorCall:
cleanup failure
While handling outer failure
HasCallStack backtrace:
throwIO, called at T28399.hs:7:22 in main:Main
```
CLC Proposal: https://github.com/haskell/core-libraries-committee/issues/397
Fixes #26759
- - - - -
63ae8eb3 by Andreas Klebinger at 2026-03-14T05:13:43-04:00
Fix missing profiling header for origin_thunk frame.
Fixes #27007
- - - - -
213d2c0e by Cheng Shao at 2026-03-14T05:14:28-04:00
ci: fix ci-images revision
The current ci-images revision was a commit on the WIP branch of
https://gitlab.haskell.org/ghc/ci-images/-/merge_requests/183, and
it's not on the current ci-images master branch. This patch fixes the
image revision to use the current tip of ci-images master.
- - - - -
fc2b083f by Andreas Klebinger at 2026-03-14T05:15:14-04:00
Revert "hadrian/build-cabal: Better respect and utilize -j"
This reverts commit eab3dbba79650e6046efca79133b4c0a5257613d.
While it's neat this currently isn't well supported on all platforms.
It's time will come, but for now I'm reverting this to avoid issues for
users on slightly unconvential platforms.
This will be tracked at #26977.
- - - - -
033185be by Cheng Shao at 2026-03-14T12:27:32-04:00
base: fix redundant imports in GHC.Internal.Weak.Finalize
This patch fixes redundant imports in GHC.Internal.Weak.Finalize that
causes a regression in bootstrapping head from 9.14 with validate
flavours. Fixes #27026.
- - - - -
8d578fdd by Matthew Pickering at 2026-03-14T12:27:33-04:00
Use explicit syntax rather than pure
- - - - -
16 changed files:
- .gitlab-ci.yml
- .gitlab/generate-ci/gen_ci.hs
- configure.ac
- distrib/configure.ac.in
- hadrian/build-cabal
- libraries/base/changelog.md
- libraries/base/src/GHC/Weak/Finalize.hs
- libraries/ghc-internal/src/GHC/Internal/Control/Exception/Base.hs
- libraries/ghc-internal/src/GHC/Internal/IO.hs
- rts/StgMiscClosures.cmm
- + testsuite/tests/exceptions/T26759.hs
- + testsuite/tests/exceptions/T26759.stderr
- + testsuite/tests/exceptions/T26759a.hs
- + testsuite/tests/exceptions/T26759a.stderr
- + testsuite/tests/exceptions/T26759a.stdout
- testsuite/tests/exceptions/all.T
Changes:
=====================================
.gitlab-ci.yml
=====================================
@@ -11,7 +11,7 @@ variables:
GIT_SSL_NO_VERIFY: "1"
# Commit of ghc/ci-images repository from which to pull Docker images
- DOCKER_REV: 4c3454a524436623df71b5faabd24e30b0f816d5
+ DOCKER_REV: 5df428b97c501f61f57587048d4bd15eba53e364
# Sequential version number of all cached things.
# Bump to invalidate GitLab CI cache.
=====================================
.gitlab/generate-ci/gen_ci.hs
=====================================
@@ -173,7 +173,7 @@ configureArgsStr :: BuildConfig -> String
configureArgsStr bc = unwords $
["--enable-unregisterised"| unregisterised bc ]
++ ["--disable-tables-next-to-code" | not (tablesNextToCode bc) ]
- ++ ["--with-intree-gmp" | Just _ <- pure (crossTarget bc) ]
+ ++ ["--with-intree-gmp" | Just _ <- [crossTarget bc] ]
++ ["--with-system-libffi" | crossTarget bc == Just "wasm32-wasi" ]
++ ["--enable-ipe-data-compression" | withZstd bc ]
++ ["--enable-strict-ghc-toolchain-check"]
=====================================
configure.ac
=====================================
@@ -542,9 +542,17 @@ FIND_LLVM_PROG([OPT], [opt], [$LlvmMinVersion], [$LlvmMaxVersion])
OptCmd="$OPT"
AC_SUBST([OptCmd])
+dnl ** look to see if we have a C compiler using an llvm back end.
+dnl
+FP_CC_LLVM_BACKEND
+AC_SUBST(CcLlvmBackend)
+
dnl ** Which LLVM assembler to use?
dnl --------------------------------------------------------------
AC_ARG_VAR(LLVMAS,[Use as the path to LLVM's assembler (typically clang) [default=autodetect]])
+if test "x$CcLlvmBackend" = "xYES" && test -z "$LLVMAS"; then
+ LLVMAS="$CC"
+fi
FIND_LLVM_PROG([LLVMAS], [clang], [$LlvmMinVersion], [$LlvmMaxVersion])
LlvmAsCmd="$LLVMAS"
AC_SUBST([LlvmAsCmd])
@@ -622,11 +630,6 @@ else
AC_SUBST([NeedLibatomic],[NO])
fi
-dnl ** look to see if we have a C compiler using an llvm back end.
-dnl
-FP_CC_LLVM_BACKEND
-AC_SUBST(CcLlvmBackend)
-
FPTOOLS_SET_C_LD_FLAGS([target],[CFLAGS],[LDFLAGS],[IGNORE_LINKER_LD_FLAGS],[CPPFLAGS])
FPTOOLS_SET_C_LD_FLAGS([build],[CONF_CC_OPTS_STAGE0],[CONF_GCC_LINKER_OPTS_STAGE0],[CONF_LD_LINKER_OPTS_STAGE0],[CONF_CPP_OPTS_STAGE0])
FPTOOLS_SET_C_LD_FLAGS([target],[CONF_CC_OPTS_STAGE1],[CONF_GCC_LINKER_OPTS_STAGE1],[CONF_LD_LINKER_OPTS_STAGE1],[CONF_CPP_OPTS_STAGE1])
=====================================
distrib/configure.ac.in
=====================================
@@ -203,9 +203,17 @@ FIND_LLVM_PROG([OPT], [opt], [$LlvmMinVersion], [$LlvmMaxVersion])
OptCmd="$OPT"
AC_SUBST([OptCmd])
+dnl ** look to see if we have a C compiler using an llvm back end.
+dnl
+FP_CC_LLVM_BACKEND
+AC_SUBST(CcLlvmBackend)
+
dnl ** Which LLVM assembler to use?
dnl --------------------------------------------------------------
AC_ARG_VAR(LLVMAS,[Use as the path to LLVM's assembler (typically clang) [default=autodetect]])
+if test "x$CcLlvmBackend" = "xYES" && test -z "$LLVMAS"; then
+ LLVMAS="$CC"
+fi
FIND_LLVM_PROG([LLVMAS], [clang], [$LlvmMinVersion], [$LlvmMaxVersion])
LlvmAsCmd="$LLVMAS"
AC_SUBST([LlvmAsCmd])
=====================================
hadrian/build-cabal
=====================================
@@ -23,52 +23,9 @@ fi
CABVERSTR=$("$CABAL" --numeric-version)
CABVER=( ${CABVERSTR//./ } )
-THREADS="-j1"
-GC_THREADS=""
-SEMAPHORE=""
-
-echo "$@"
-
-# Try building hadrian in parallel. We check for -j<n>.
-# If threads > 1 we pass --semaphore to allow ghc to build more than one module in parallel
-# If threads > 4 we pass -qn as higher parallel gc thread counts can lead to slow downs
-# We only do any of thise for cabal >= 3.14, because I don't trust older versions to handle --semaphore right
-if [ "${CABVER[0]}" -gt 3 ] || [ "${CABVER[0]}" -eq 3 -a "${CABVER[1]}" -ge 14 ];
-then
-
- for arg in "$@"; do
- case "$arg" in
- -j)
- GC_THREADS="-qn4"
- SEMAPHORE="--semaphore"
- THREADS="-j"
- ;;
- -j[0-9]*)
- threads="${arg#-j}"
- if [[ "$threads" =~ ^[0-9]+$ ]] && [ "$threads" -ne 0 ]; then
- THREADS="-j${threads}"
- if [ $threads -ge 4 ]; then
- GC_THREADS="-qn4"
- fi
- if [ $threads -gt 1 ]; then
- SEMAPHORE="--semaphore"
- fi
- fi
- ;;
- esac
-
- done
-
-fi
-
-if [ "$(uname -s)" = "FreeBSD" ]; then
- # Can't rely on posix semaphore support in free bsd.
- SEMAPHORE=""
-fi
-
if [ "${CABVER[0]}" -gt 2 -o "${CABVER[0]}" -eq 2 -a "${CABVER[1]}" -ge 2 ];
then
- "$CABAL" --project-file="$PROJ" new-build "${CABFLAGS[@]}" ${THREADS} ${SEMAPHORE} --ghc-options="+RTS ${GC_THREADS} -RTS" exe:hadrian
+ "$CABAL" --project-file="$PROJ" new-build "${CABFLAGS[@]}" -j exe:hadrian
# use new-exec instead of new-run to make sure that the build-tools (alex & happy) are in PATH
"$CABAL" --project-file="$PROJ" new-exec "${CABFLAGS[@]}" hadrian -- \
--directory "$PWD" \
=====================================
libraries/base/changelog.md
=====================================
@@ -27,6 +27,7 @@
* Evaluate backtraces for "error" exceptions at the moment they are thrown. ([CLC proposal #383](https://github.com/haskell/core-libraries-committee/issues/383))
* Hide implementation details when throwing exceptions in throw and throwSTM. ([CLC proposal #387](https://github.com/haskell/core-libraries-committee/issues/387))
* Change `hIsReadable` and `hIsWritable` such that they always throw a respective exception when encountering a closed or semi-closed handle, not just in the case of a file handle. ([CLC proposal #371](github.com/haskell/core-libraries-committee/issues/371))
+ * Annotate `onException` continuation with `WhileHandling`. ([CLC Proposal #397](https://github.com/haskell/core-libraries-committee/issues/397))
## 4.22.0.0 *TBA*
* Shipped with GHC 9.14.1
=====================================
libraries/base/src/GHC/Weak/Finalize.hs
=====================================
@@ -16,12 +16,9 @@ import GHC.Internal.Weak.Finalize
import GHC.Internal.Base
import GHC.Internal.Exception
-import GHC.Internal.IORef
-import GHC.Internal.Conc.Sync (labelThreadByteArray#, myThreadId)
-import GHC.Internal.IO (catchException, unsafePerformIO)
+import GHC.Internal.IO (catchException)
import GHC.Internal.IO.Handle.Types (Handle)
import GHC.Internal.IO.Handle.Text (hPutStrLn)
-import GHC.Internal.Encoding.UTF8 (utf8EncodeByteArray#)
{-# DEPRECATED runFinalizerBatch
=====================================
libraries/ghc-internal/src/GHC/Internal/Control/Exception/Base.hs
=====================================
@@ -203,7 +203,7 @@ tryJust p a = catchJust p (Right `fmap` a) (return . Left)
-- exception raised by the computation.
onException :: IO a -> IO b -> IO a
onException io what = io `catchNoPropagate` \e -> do
- _ <- what
+ _ <- annotateIO (whileHandling e) what
rethrowIO (e :: ExceptionWithContext SomeException)
-----------------------------------------------------------------------------
=====================================
libraries/ghc-internal/src/GHC/Internal/IO.hs
=====================================
@@ -52,7 +52,7 @@ module GHC.Internal.IO (
import GHC.Internal.Base
import GHC.Internal.ST
import GHC.Internal.Exception
-import GHC.Internal.Exception.Type (NoBacktrace(..), WhileHandling(..), HasExceptionContext, ExceptionWithContext(..))
+import GHC.Internal.Exception.Type (NoBacktrace(..), whileHandling, WhileHandling(..), HasExceptionContext, ExceptionWithContext(..))
import GHC.Internal.Show
import GHC.Internal.IO.Unsafe
import GHC.Internal.Unsafe.Coerce ( unsafeCoerce )
@@ -363,7 +363,7 @@ getMaskingState = IO $ \s ->
onException :: IO a -> IO b -> IO a
onException io what = io `catchExceptionNoPropagate` \e -> do
- _ <- what
+ _ <- annotateIO (whileHandling e) what
rethrowIO (e :: ExceptionWithContext SomeException)
-- | Executes an IO computation with asynchronous
=====================================
rts/StgMiscClosures.cmm
=====================================
@@ -47,6 +47,7 @@ import CLOSURE stg_ret_v_info;
/* See Note [Original thunk info table frames] in GHC.StgToCmm.Bind. */
INFO_TABLE_RET (stg_orig_thunk_info_frame, RET_SMALL,
W_ info_ptr,
+ PROF_HDR_FIELDS(W_, p1, p2)
W_ thunk_info_ptr)
/* no args => explicit stack */
{
=====================================
testsuite/tests/exceptions/T26759.hs
=====================================
@@ -0,0 +1,10 @@
+import Control.Exception
+
+run :: IO ()
+run = failingAction `onException` failingCleanup
+ where
+ failingAction = throwIO (ErrorCall "outer failure")
+ failingCleanup = throwIO (ErrorCall "cleanup failure")
+
+main :: IO ()
+main = run
=====================================
testsuite/tests/exceptions/T26759.stderr
=====================================
@@ -0,0 +1,9 @@
+T26759: Uncaught exception ghc-internal:GHC.Internal.Exception.ErrorCall:
+
+cleanup failure
+
+While handling outer failure
+
+HasCallStack backtrace:
+ throwIO, called at T26759.hs:7:22 in main:Main
+
=====================================
testsuite/tests/exceptions/T26759a.hs
=====================================
@@ -0,0 +1,10 @@
+import Control.Exception
+
+run :: IO ()
+run = failingAction `onException` cleanup
+ where
+ failingAction = throwIO (ErrorCall "outer failure")
+ cleanup = putStrLn "cleanup"
+
+main :: IO ()
+main = run
=====================================
testsuite/tests/exceptions/T26759a.stderr
=====================================
@@ -0,0 +1,7 @@
+T26759a: Uncaught exception ghc-internal:GHC.Internal.Exception.ErrorCall:
+
+outer failure
+
+HasCallStack backtrace:
+ throwIO, called at T26759a.hs:6:21 in main:Main
+
=====================================
testsuite/tests/exceptions/T26759a.stdout
=====================================
@@ -0,0 +1 @@
+cleanup
=====================================
testsuite/tests/exceptions/all.T
=====================================
@@ -1,2 +1,3 @@
test('T25052', normal, compile_and_run, [''])
-
+test('T26759', exit_code(1), compile_and_run, [''])
+test('T26759a', exit_code(1), compile_and_run, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6a4c0dccfc7ec838323be03325c186…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6a4c0dccfc7ec838323be03325c186…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc] Pushed new branch wip/supersven/explicit-syntax
by Sven Tennie (＠supersven) 14 Mar '26
by Sven Tennie (＠supersven) 14 Mar '26
14 Mar '26
Sven Tennie pushed new branch wip/supersven/explicit-syntax at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/supersven/explicit-syntax
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc] Pushed new branch wip/supersven/add-missing-req_interp
by Sven Tennie (＠supersven) 14 Mar '26
by Sven Tennie (＠supersven) 14 Mar '26
14 Mar '26
Sven Tennie pushed new branch wip/supersven/add-missing-req_interp at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/supersven/add-missing-req_int…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] Revert "hadrian/build-cabal: Better respect and utilize -j"
by Marge Bot (＠marge-bot) 14 Mar '26
by Marge Bot (＠marge-bot) 14 Mar '26
14 Mar '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
fc2b083f by Andreas Klebinger at 2026-03-14T05:15:14-04:00
Revert "hadrian/build-cabal: Better respect and utilize -j"
This reverts commit eab3dbba79650e6046efca79133b4c0a5257613d.
While it's neat this currently isn't well supported on all platforms.
It's time will come, but for now I'm reverting this to avoid issues for
users on slightly unconvential platforms.
This will be tracked at #26977.
- - - - -
1 changed file:
- hadrian/build-cabal
Changes:
=====================================
hadrian/build-cabal
=====================================
@@ -23,52 +23,9 @@ fi
CABVERSTR=$("$CABAL" --numeric-version)
CABVER=( ${CABVERSTR//./ } )
-THREADS="-j1"
-GC_THREADS=""
-SEMAPHORE=""
-
-echo "$@"
-
-# Try building hadrian in parallel. We check for -j<n>.
-# If threads > 1 we pass --semaphore to allow ghc to build more than one module in parallel
-# If threads > 4 we pass -qn as higher parallel gc thread counts can lead to slow downs
-# We only do any of thise for cabal >= 3.14, because I don't trust older versions to handle --semaphore right
-if [ "${CABVER[0]}" -gt 3 ] || [ "${CABVER[0]}" -eq 3 -a "${CABVER[1]}" -ge 14 ];
-then
-
- for arg in "$@"; do
- case "$arg" in
- -j)
- GC_THREADS="-qn4"
- SEMAPHORE="--semaphore"
- THREADS="-j"
- ;;
- -j[0-9]*)
- threads="${arg#-j}"
- if [[ "$threads" =~ ^[0-9]+$ ]] && [ "$threads" -ne 0 ]; then
- THREADS="-j${threads}"
- if [ $threads -ge 4 ]; then
- GC_THREADS="-qn4"
- fi
- if [ $threads -gt 1 ]; then
- SEMAPHORE="--semaphore"
- fi
- fi
- ;;
- esac
-
- done
-
-fi
-
-if [ "$(uname -s)" = "FreeBSD" ]; then
- # Can't rely on posix semaphore support in free bsd.
- SEMAPHORE=""
-fi
-
if [ "${CABVER[0]}" -gt 2 -o "${CABVER[0]}" -eq 2 -a "${CABVER[1]}" -ge 2 ];
then
- "$CABAL" --project-file="$PROJ" new-build "${CABFLAGS[@]}" ${THREADS} ${SEMAPHORE} --ghc-options="+RTS ${GC_THREADS} -RTS" exe:hadrian
+ "$CABAL" --project-file="$PROJ" new-build "${CABFLAGS[@]}" -j exe:hadrian
# use new-exec instead of new-run to make sure that the build-tools (alex & happy) are in PATH
"$CABAL" --project-file="$PROJ" new-exec "${CABFLAGS[@]}" hadrian -- \
--directory "$PWD" \
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fc2b083f9541ff29925988bdf2dbb25…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fc2b083f9541ff29925988bdf2dbb25…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
213d2c0e by Cheng Shao at 2026-03-14T05:14:28-04:00
ci: fix ci-images revision
The current ci-images revision was a commit on the WIP branch of
https://gitlab.haskell.org/ghc/ci-images/-/merge_requests/183, and
it's not on the current ci-images master branch. This patch fixes the
image revision to use the current tip of ci-images master.
- - - - -
1 changed file:
- .gitlab-ci.yml
Changes:
=====================================
.gitlab-ci.yml
=====================================
@@ -11,7 +11,7 @@ variables:
GIT_SSL_NO_VERIFY: "1"
# Commit of ghc/ci-images repository from which to pull Docker images
- DOCKER_REV: 4c3454a524436623df71b5faabd24e30b0f816d5
+ DOCKER_REV: 5df428b97c501f61f57587048d4bd15eba53e364
# Sequential version number of all cached things.
# Bump to invalidate GitLab CI cache.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/213d2c0e5ab0bf8f879fae891a634c8…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/213d2c0e5ab0bf8f879fae891a634c8…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] Fix missing profiling header for origin_thunk frame.
by Marge Bot (＠marge-bot) 14 Mar '26
by Marge Bot (＠marge-bot) 14 Mar '26
14 Mar '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
63ae8eb3 by Andreas Klebinger at 2026-03-14T05:13:43-04:00
Fix missing profiling header for origin_thunk frame.
Fixes #27007
- - - - -
1 changed file:
- rts/StgMiscClosures.cmm
Changes:
=====================================
rts/StgMiscClosures.cmm
=====================================
@@ -47,6 +47,7 @@ import CLOSURE stg_ret_v_info;
/* See Note [Original thunk info table frames] in GHC.StgToCmm.Bind. */
INFO_TABLE_RET (stg_orig_thunk_info_frame, RET_SMALL,
W_ info_ptr,
+ PROF_HDR_FIELDS(W_, p1, p2)
W_ thunk_info_ptr)
/* no args => explicit stack */
{
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/63ae8eb38c54eaba77949b048a3621a…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/63ae8eb38c54eaba77949b048a3621a…
You're receiving this email because of your account on gitlab.haskell.org.
1
0