[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 6 commits: Type-check default declarations before deriving clauses (#24566)
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Fri Mar 22 14:09:48 UTC 2024
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
52072f8e by Sylvain Henry at 2024-03-21T21:01:59-04:00
Type-check default declarations before deriving clauses (#24566)
See added Note and #24566. Default declarations must be type-checked
before deriving clauses.
- - - - -
7dfdf3d9 by Sylvain Henry at 2024-03-21T21:02:40-04:00
Lexer: small perf changes
- Use unsafeChr because we know our values to be valid
- Remove some unnecessary use of `ord` (return Word8 values directly)
- - - - -
864922ef by Sylvain Henry at 2024-03-21T21:02:40-04:00
JS: fix some comments
- - - - -
3e0b2b1f by Sebastian Graf at 2024-03-21T21:03:16-04:00
Simplifier: Re-do dependency analysis in abstractFloats (#24551)
In #24551, we abstracted a string literal binding over a type variable,
triggering a CoreLint error when that binding floated to top-level.
The solution implemented in this patch fixes this by re-doing dependency
analysis on a simplified recursive let binding that is about to be type
abstracted, in order to find the minimal set of type variables to abstract over.
See wrinkle (AB5) of Note [Floating and type abstraction] for more details.
Fixes #24551
- - - - -
4b676966 by Zubin Duggal at 2024-03-22T10:09:16-04:00
driver: Make `checkHomeUnitsClosed` faster
The implementation of `checkHomeUnitsClosed` was traversing every single path
in the unit dependency graph - this grows exponentially and quickly grows to be
infeasible on larger unit dependency graphs.
Instead we replace this with a faster implementation which follows from the
specificiation of the closure property - there is a closure error if there are
units which are both are both (transitively) depended upon by home units and
(transitively) depend on home units, but are not themselves home units.
To compute the set of units required for closure, we first compute the closure
of the unit dependency graph, then the transpose of this closure, and find all
units that are reachable from the home units in the transpose of the closure.
- - - - -
0aeb789f by Andreas Klebinger at 2024-03-22T10:09:17-04:00
NCG: Fix a bug in jump shortcutting.
When checking if a jump has more than one destination account for the
possibility of some jumps not being representable by a BlockId.
We do so by having isJumpishInstr return a `Maybe BlockId` where Nothing
represents non-BlockId jump destinations.
Fixes #24507
- - - - -
28 changed files:
- compiler/GHC/CmmToAsm/AArch64/Instr.hs
- compiler/GHC/CmmToAsm/BlockLayout.hs
- compiler/GHC/CmmToAsm/Instr.hs
- compiler/GHC/CmmToAsm/PPC/Instr.hs
- compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs
- compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs
- compiler/GHC/CmmToAsm/Reg/Liveness.hs
- compiler/GHC/CmmToAsm/X86/Instr.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Parser/Lexer.x
- compiler/GHC/StgToJS/Linker/Linker.hs
- compiler/GHC/Tc/Module.hs
- libraries/ghc-internal/src/GHC/Internal/Maybe.hs
- + testsuite/tests/codeGen/should_run/T24507.hs
- + testsuite/tests/codeGen/should_run/T24507.stdout
- + testsuite/tests/codeGen/should_run/T24507_cmm.cmm
- testsuite/tests/codeGen/should_run/all.T
- + testsuite/tests/driver/multipleHomeUnits/mhu-perf/Makefile
- + testsuite/tests/driver/multipleHomeUnits/mhu-perf/Setup.hs
- + testsuite/tests/driver/multipleHomeUnits/mhu-perf/all.T
- + testsuite/tests/driver/multipleHomeUnits/mhu-perf/genLargeHMU
- + testsuite/tests/driver/multipleHomeUnits/mhu-perf/mhu-perf.stderr
- + testsuite/tests/simplCore/should_compile/T24551.hs
- testsuite/tests/simplCore/should_compile/all.T
- testsuite/tests/typecheck/should_compile/Makefile
- + testsuite/tests/typecheck/should_compile/T24566.hs
- testsuite/tests/typecheck/should_compile/all.T
Changes:
=====================================
compiler/GHC/CmmToAsm/AArch64/Instr.hs
=====================================
@@ -301,15 +301,20 @@ isJumpishInstr instr = case instr of
-- | Checks whether this instruction is a jump/branch instruction.
-- One that can change the flow of control in a way that the
-- register allocator needs to worry about.
-jumpDestsOfInstr :: Instr -> [BlockId]
+jumpDestsOfInstr :: Instr -> [Maybe BlockId]
jumpDestsOfInstr (ANN _ i) = jumpDestsOfInstr i
-jumpDestsOfInstr (CBZ _ t) = [ id | TBlock id <- [t]]
-jumpDestsOfInstr (CBNZ _ t) = [ id | TBlock id <- [t]]
-jumpDestsOfInstr (J t) = [id | TBlock id <- [t]]
-jumpDestsOfInstr (B t) = [id | TBlock id <- [t]]
-jumpDestsOfInstr (BL t _ _) = [ id | TBlock id <- [t]]
-jumpDestsOfInstr (BCOND _ t) = [ id | TBlock id <- [t]]
-jumpDestsOfInstr _ = []
+jumpDestsOfInstr i = case i of
+ (CBZ _ t) -> [ mkDest t ]
+ (CBNZ _ t) -> [ mkDest t ]
+ (J t) -> [ mkDest t ]
+ (B t) -> [ mkDest t ]
+ (BL t _ _) -> [ mkDest t ]
+ (BCOND _ t) -> [ mkDest t ]
+ _ -> []
+ where
+ mkDest (TBlock id) = Just id
+ mkDest TLabel{} = Nothing
+ mkDest TReg{} = Nothing
-- | Change the destination of this jump instruction.
-- Used in the linear allocator when adding fixup blocks for join
=====================================
compiler/GHC/CmmToAsm/BlockLayout.hs
=====================================
@@ -771,7 +771,7 @@ dropJumps :: forall a i. Instruction i => LabelMap a -> [GenBasicBlock i]
dropJumps _ [] = []
dropJumps info (BasicBlock lbl ins:todo)
| Just ins <- nonEmpty ins --This can happen because of shortcutting
- , [dest] <- jumpDestsOfInstr (NE.last ins)
+ , [Just dest] <- jumpDestsOfInstr (NE.last ins)
, BasicBlock nextLbl _ : _ <- todo
, not (mapMember dest info)
, nextLbl == dest
@@ -870,7 +870,7 @@ mkNode edgeWeights block@(BasicBlock id instrs) =
| length successors > 2 || edgeWeight info <= 0 -> []
| otherwise -> [target]
| Just instr <- lastMaybe instrs
- , [one] <- jumpDestsOfInstr instr
+ , [one] <- jumpBlockDestsOfInstr instr
= [one]
| otherwise = []
=====================================
compiler/GHC/CmmToAsm/Instr.hs
=====================================
@@ -17,6 +17,8 @@ import GHC.Cmm.BlockId
import GHC.CmmToAsm.Config
import GHC.Data.FastString
+import Data.Maybe (catMaybes)
+
-- | Holds a list of source and destination registers used by a
-- particular instruction.
--
@@ -73,9 +75,17 @@ class Instruction instr where
-- | Give the possible destinations of this jump instruction.
-- Must be defined for all jumpish instructions.
+ -- Returns Nothing for non BlockId destinations.
jumpDestsOfInstr
+ :: instr -> [Maybe BlockId]
+
+ -- | Give the possible block destinations of this jump instruction.
+ -- Must be defined for all jumpish instructions.
+ jumpBlockDestsOfInstr
:: instr -> [BlockId]
+ jumpBlockDestsOfInstr = catMaybes . jumpDestsOfInstr
+
-- | Change the destination of this jump instruction.
-- Used in the linear allocator when adding fixup blocks for join
=====================================
compiler/GHC/CmmToAsm/PPC/Instr.hs
=====================================
@@ -513,12 +513,15 @@ isJumpishInstr instr
-- | Checks whether this instruction is a jump/branch instruction.
-- One that can change the flow of control in a way that the
-- register allocator needs to worry about.
-jumpDestsOfInstr :: Instr -> [BlockId]
+jumpDestsOfInstr :: Instr -> [Maybe BlockId]
jumpDestsOfInstr insn
= case insn of
- BCC _ id _ -> [id]
- BCCFAR _ id _ -> [id]
- BCTR targets _ _ -> [id | Just id <- targets]
+ BCC _ id _ -> [Just id]
+ BCCFAR _ id _ -> [Just id]
+ BCTR targets _ _ -> targets
+ BCTRL{} -> [Nothing]
+ BL{} -> [Nothing]
+ JMP{} -> [Nothing]
_ -> []
=====================================
compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs
=====================================
@@ -207,7 +207,7 @@ cleanForward platform blockId assoc acc (li : instrs)
-- Remember the association over a jump.
| LiveInstr instr _ <- li
- , targets <- jumpDestsOfInstr instr
+ , targets <- jumpBlockDestsOfInstr instr
, not $ null targets
= do mapM_ (accJumpValid assoc) targets
cleanForward platform blockId assoc (li : acc) instrs
@@ -386,7 +386,7 @@ cleanBackward' liveSlotsOnEntry reloadedBy noReloads acc (li : instrs)
-- it always does, but if those reloads are cleaned the slot
-- liveness map doesn't get updated.
| LiveInstr instr _ <- li
- , targets <- jumpDestsOfInstr instr
+ , targets <- jumpBlockDestsOfInstr instr
= do
let slotsReloadedByTargets
= IntSet.unions
=====================================
compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs
=====================================
@@ -57,7 +57,7 @@ joinToTargets block_live id instr
= return ([], instr)
| otherwise
- = joinToTargets' block_live [] id instr (jumpDestsOfInstr instr)
+ = joinToTargets' block_live [] id instr (jumpBlockDestsOfInstr instr)
-----
joinToTargets'
=====================================
compiler/GHC/CmmToAsm/Reg/Liveness.hs
=====================================
@@ -468,7 +468,7 @@ slurpReloadCoalesce live
-- if we hit a jump, remember the current slotMap
| LiveInstr (Instr instr) _ <- li
- , targets <- jumpDestsOfInstr instr
+ , targets <- jumpBlockDestsOfInstr instr
, not $ null targets
= do mapM_ (accSlotMap slotMap) targets
return (slotMap, Nothing)
@@ -760,7 +760,7 @@ sccBlocks blocks entries mcfg = map (fmap node_payload) sccs
sccs = stronglyConnCompG g2
getOutEdges :: Instruction instr => [instr] -> [BlockId]
- getOutEdges instrs = concatMap jumpDestsOfInstr instrs
+ getOutEdges instrs = concatMap jumpBlockDestsOfInstr instrs
-- This is truly ugly, but I don't see a good alternative.
-- Digraph just has the wrong API. We want to identify nodes
@@ -837,7 +837,7 @@ checkIsReverseDependent sccs'
slurpJumpDestsOfBlock (BasicBlock _ instrs)
= unionManyUniqSets
- $ map (mkUniqSet . jumpDestsOfInstr)
+ $ map (mkUniqSet . jumpBlockDestsOfInstr)
[ i | LiveInstr i _ <- instrs]
@@ -1047,7 +1047,7 @@ liveness1 platform liveregs blockmap (LiveInstr instr _)
-- union in the live regs from all the jump destinations of this
-- instruction.
- targets = jumpDestsOfInstr instr -- where we go from here
+ targets = jumpBlockDestsOfInstr instr -- where we go from here
not_a_branch = null targets
targetLiveRegs target
=====================================
compiler/GHC/CmmToAsm/X86/Instr.hs
=====================================
@@ -672,13 +672,16 @@ isJumpishInstr instr
jumpDestsOfInstr
:: Instr
- -> [BlockId]
+ -> [Maybe BlockId]
jumpDestsOfInstr insn
= case insn of
- JXX _ id -> [id]
- JMP_TBL _ ids _ _ -> [id | Just (DestBlockId id) <- ids]
+ JXX _ id -> [Just id]
+ JMP_TBL _ ids _ _ -> [(mkDest dest) | Just dest <- ids]
_ -> []
+ where
+ mkDest (DestBlockId id) = Just id
+ mkDest _ = Nothing
patchJumpInstr
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -85,6 +85,8 @@ import GHC.Utils.Panic
import Control.Monad ( when )
import Data.List ( sortBy )
+import GHC.Types.Name.Env
+import Data.Graph
{- *********************************************************************
* *
@@ -2108,6 +2110,27 @@ new binding is abstracted. Several points worth noting
which showed that it's harder to do polymorphic specialisation well
if there are dictionaries abstracted over unnecessary type variables.
See Note [Weird special case for SpecDict] in GHC.Core.Opt.Specialise
+
+(AB5) We do dependency analysis on recursive groups prior to determining
+ which variables to abstract over.
+ This is useful, because ANFisation in prepareBinding may float out
+ values out of a complex recursive binding, e.g.,
+ letrec { xs = g @a "blah"# ((:) 1 []) xs } in ...
+ ==> { prepareBinding }
+ letrec { foo = "blah"#
+ bar = [42]
+ xs = g @a foo bar xs } in
+ ...
+ and we don't want to abstract foo and bar over @a.
+
+ (Why is it OK to float the unlifted `foo` there?
+ See Note [Core top-level string literals] in GHC.Core;
+ it is controlled by GHC.Core.Opt.Simplify.Env.unitLetFloat.)
+
+ It is also necessary to do dependency analysis, because
+ otherwise (in #24551) we might get `foo = \@_ -> "missing"#` at the
+ top-level, and that triggers a CoreLint error because `foo` is *not*
+ manifestly a literal string.
-}
abstractFloats :: UnfoldingOpts -> TopLevelFlag -> [OutTyVar] -> SimplFloats
@@ -2115,15 +2138,27 @@ abstractFloats :: UnfoldingOpts -> TopLevelFlag -> [OutTyVar] -> SimplFloats
abstractFloats uf_opts top_lvl main_tvs floats body
= assert (notNull body_floats) $
assert (isNilOL (sfJoinFloats floats)) $
- do { (subst, float_binds) <- mapAccumLM abstract empty_subst body_floats
+ do { let sccs = concatMap to_sccs body_floats
+ ; (subst, float_binds) <- mapAccumLM abstract empty_subst sccs
; return (float_binds, GHC.Core.Subst.substExpr subst body) }
where
is_top_lvl = isTopLevel top_lvl
body_floats = letFloatBinds (sfLetFloats floats)
empty_subst = GHC.Core.Subst.mkEmptySubst (sfInScope floats)
- abstract :: GHC.Core.Subst.Subst -> OutBind -> SimplM (GHC.Core.Subst.Subst, OutBind)
- abstract subst (NonRec id rhs)
+ -- See wrinkle (AB5) in Note [Which type variables to abstract over]
+ -- for why we need to re-do dependency analysis
+ to_sccs :: OutBind -> [SCC (Id, CoreExpr, VarSet)]
+ to_sccs (NonRec id e) = [AcyclicSCC (id, e, emptyVarSet)] -- emptyVarSet: abstract doesn't need it
+ to_sccs (Rec prs) = sccs
+ where
+ (ids,rhss) = unzip prs
+ sccs = depAnal (\(id,_rhs,_fvs) -> [getName id])
+ (\(_id,_rhs,fvs) -> nonDetStrictFoldVarSet ((:) . getName) [] fvs) -- Wrinkle (AB3)
+ (zip3 ids rhss (map exprFreeVars rhss))
+
+ abstract :: GHC.Core.Subst.Subst -> SCC (Id, CoreExpr, VarSet) -> SimplM (GHC.Core.Subst.Subst, OutBind)
+ abstract subst (AcyclicSCC (id, rhs, _empty_var_set))
= do { (poly_id1, poly_app) <- mk_poly1 tvs_here id
; let (poly_id2, poly_rhs) = mk_poly2 poly_id1 tvs_here rhs'
!subst' = GHC.Core.Subst.extendIdSubst subst id poly_app
@@ -2134,7 +2169,7 @@ abstractFloats uf_opts top_lvl main_tvs floats body
-- tvs_here: see Note [Which type variables to abstract over]
tvs_here = choose_tvs (exprSomeFreeVars isTyVar rhs')
- abstract subst (Rec prs)
+ abstract subst (CyclicSCC trpls)
= do { (poly_ids, poly_apps) <- mapAndUnzipM (mk_poly1 tvs_here) ids
; let subst' = GHC.Core.Subst.extendSubstList subst (ids `zip` poly_apps)
poly_pairs = [ mk_poly2 poly_id tvs_here rhs'
@@ -2142,15 +2177,15 @@ abstractFloats uf_opts top_lvl main_tvs floats body
, let rhs' = GHC.Core.Subst.substExpr subst' rhs ]
; return (subst', Rec poly_pairs) }
where
- (ids,rhss) = unzip prs
-
+ (ids,rhss,_fvss) = unzip3 trpls
-- tvs_here: see Note [Which type variables to abstract over]
- tvs_here = choose_tvs (mapUnionVarSet get_bind_fvs prs)
+ tvs_here = choose_tvs (mapUnionVarSet get_bind_fvs trpls)
-- See wrinkle (AB4) in Note [Which type variables to abstract over]
- get_bind_fvs (id,rhs) = tyCoVarsOfType (idType id) `unionVarSet` get_rec_rhs_tvs rhs
- get_rec_rhs_tvs rhs = nonDetStrictFoldVarSet get_tvs emptyVarSet (exprFreeVars rhs)
+ get_bind_fvs (id,_rhs,rhs_fvs) = tyCoVarsOfType (idType id) `unionVarSet` get_rec_rhs_tvs rhs_fvs
+ get_rec_rhs_tvs rhs_fvs = nonDetStrictFoldVarSet get_tvs emptyVarSet rhs_fvs
+ -- nonDet is safe because of wrinkle (AB3)
get_tvs :: Var -> VarSet -> VarSet
get_tvs var free_tvs
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -1565,8 +1565,8 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
(root_errs, rootSummariesOk) <- partitionWithM getRootSummary roots -- #17549
let root_map = mkRootMap rootSummariesOk
checkDuplicates root_map
- (deps, pkg_deps, map0) <- loopSummaries rootSummariesOk (M.empty, Set.empty, root_map)
- let closure_errs = checkHomeUnitsClosed (hsc_unit_env hsc_env) (hsc_all_home_unit_ids hsc_env) (Set.toList pkg_deps)
+ (deps, map0) <- loopSummaries rootSummariesOk (M.empty, root_map)
+ let closure_errs = checkHomeUnitsClosed (hsc_unit_env hsc_env)
let unit_env = hsc_unit_env hsc_env
let tmpfs = hsc_tmpfs hsc_env
@@ -1660,19 +1660,19 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
-- This loops over all the mod summaries in the dependency graph, accumulates the actual dependencies for each module/unit
loopSummaries :: [ModSummary]
- -> (M.Map NodeKey ModuleGraphNode, Set.Set (UnitId, UnitId),
+ -> (M.Map NodeKey ModuleGraphNode,
DownsweepCache)
- -> IO ((M.Map NodeKey ModuleGraphNode), Set.Set (UnitId, UnitId), DownsweepCache)
+ -> IO ((M.Map NodeKey ModuleGraphNode), DownsweepCache)
loopSummaries [] done = return done
- loopSummaries (ms:next) (done, pkgs, summarised)
+ loopSummaries (ms:next) (done, summarised)
| Just {} <- M.lookup k done
- = loopSummaries next (done, pkgs, summarised)
+ = loopSummaries next (done, summarised)
-- Didn't work out what the imports mean yet, now do that.
| otherwise = do
- (final_deps, pkgs1, done', summarised') <- loopImports (calcDeps ms) done summarised
+ (final_deps, done', summarised') <- loopImports (calcDeps ms) done summarised
-- This has the effect of finding a .hs file if we are looking at the .hs-boot file.
- (_, _, done'', summarised'') <- loopImports (maybeToList hs_file_for_boot) done' summarised'
- loopSummaries next (M.insert k (ModuleNode final_deps ms) done'', pkgs1 `Set.union` pkgs, summarised'')
+ (_, done'', summarised'') <- loopImports (maybeToList hs_file_for_boot) done' summarised'
+ loopSummaries next (M.insert k (ModuleNode final_deps ms) done'', summarised'')
where
k = NodeKey_Module (msKey ms)
@@ -1692,18 +1692,17 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
-- Visited set; the range is a list because
-- the roots can have the same module names
-- if allow_dup_roots is True
- -> IO ([NodeKey], Set.Set (UnitId, UnitId),
-
+ -> IO ([NodeKey],
M.Map NodeKey ModuleGraphNode, DownsweepCache)
-- The result is the completed NodeMap
- loopImports [] done summarised = return ([], Set.empty, done, summarised)
+ loopImports [] done summarised = return ([], done, summarised)
loopImports ((home_uid,mb_pkg, gwib) : ss) done summarised
| Just summs <- M.lookup cache_key summarised
= case summs of
[Right ms] -> do
let nk = NodeKey_Module (msKey ms)
- (rest, pkgs, summarised', done') <- loopImports ss done summarised
- return (nk: rest, pkgs, summarised', done')
+ (rest, summarised', done') <- loopImports ss done summarised
+ return (nk: rest, summarised', done')
[Left _err] ->
loopImports ss done summarised
_errs -> do
@@ -1715,69 +1714,77 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
Nothing excl_mods
case mb_s of
NotThere -> loopImports ss done summarised
- External uid -> do
- (other_deps, pkgs, done', summarised') <- loopImports ss done summarised
- return (other_deps, Set.insert (homeUnitId home_unit, uid) pkgs, done', summarised')
+ External _ -> do
+ (other_deps, done', summarised') <- loopImports ss done summarised
+ return (other_deps, done', summarised')
FoundInstantiation iud -> do
- (other_deps, pkgs, done', summarised') <- loopImports ss done summarised
- return (NodeKey_Unit iud : other_deps, pkgs, done', summarised')
+ (other_deps, done', summarised') <- loopImports ss done summarised
+ return (NodeKey_Unit iud : other_deps, done', summarised')
FoundHomeWithError (_uid, e) -> loopImports ss done (Map.insert cache_key [(Left e)] summarised)
FoundHome s -> do
- (done', pkgs1, summarised') <-
- loopSummaries [s] (done, Set.empty, Map.insert cache_key [Right s] summarised)
- (other_deps, pkgs2, final_done, final_summarised) <- loopImports ss done' summarised'
+ (done', summarised') <-
+ loopSummaries [s] (done, Map.insert cache_key [Right s] summarised)
+ (other_deps, final_done, final_summarised) <- loopImports ss done' summarised'
-- MP: This assumes that we can only instantiate non home units, which is probably fair enough for now.
- return (NodeKey_Module (msKey s) : other_deps, pkgs1 `Set.union` pkgs2, final_done, final_summarised)
+ return (NodeKey_Module (msKey s) : other_deps, final_done, final_summarised)
where
cache_key = (home_uid, mb_pkg, unLoc <$> gwib)
home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env)
GWIB { gwib_mod = L loc mod, gwib_isBoot = is_boot } = gwib
wanted_mod = L loc mod
--- This function checks then important property that if both p and q are home units
+-- | This function checks then important property that if both p and q are home units
-- then any dependency of p, which transitively depends on q is also a home unit.
-checkHomeUnitsClosed :: UnitEnv -> Set.Set UnitId -> [(UnitId, UnitId)] -> [DriverMessages]
--- Fast path, trivially closed.
-checkHomeUnitsClosed ue home_id_set home_imp_ids
- | Set.size home_id_set == 1 = []
- | otherwise =
- let res = foldMap loop home_imp_ids
- -- Now check whether everything which transitively depends on a home_unit is actually a home_unit
- -- These units are the ones which we need to load as home packages but failed to do for some reason,
- -- it's a bug in the tool invoking GHC.
- bad_unit_ids = Set.difference res home_id_set
- in if Set.null bad_unit_ids
- then []
- else [singleMessage $ mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (Set.toList bad_unit_ids)]
-
+--
+-- See Note [Multiple Home Units], section 'Closure Property'.
+checkHomeUnitsClosed :: UnitEnv -> [DriverMessages]
+checkHomeUnitsClosed ue
+ | Set.null bad_unit_ids = []
+ | otherwise = [singleMessage $ mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (Set.toList bad_unit_ids)]
where
+ home_id_set = unitEnv_keys $ ue_home_unit_graph ue
+ bad_unit_ids = upwards_closure Set.\\ home_id_set
rootLoc = mkGeneralSrcSpan (fsLit "<command line>")
- -- TODO: This could repeat quite a bit of work but I struggled to write this function.
- -- Which units transitively depend on a home unit
- loop :: (UnitId, UnitId) -> Set.Set UnitId -- The units which transitively depend on a home unit
- loop (from_uid, uid) =
- let us = ue_findHomeUnitEnv from_uid ue in
- let um = unitInfoMap (homeUnitEnv_units us) in
- case lookupUniqMap um uid of
- Nothing -> pprPanic "uid not found" (ppr uid)
- Just ui ->
- let depends = unitDepends ui
- home_depends = Set.fromList depends `Set.intersection` home_id_set
- other_depends = Set.fromList depends `Set.difference` home_id_set
- in
- -- Case 1: The unit directly depends on a home_id
- if not (null home_depends)
- then
- let res = foldMap (loop . (from_uid,)) other_depends
- in Set.insert uid res
- -- Case 2: Check the rest of the dependencies, and then see if any of them depended on
- else
- let res = foldMap (loop . (from_uid,)) other_depends
- in
- if not (Set.null res)
- then Set.insert uid res
- else res
+
+ graph :: Graph (Node UnitId UnitId)
+ graph = graphFromEdgedVerticesUniq graphNodes
+
+ -- downwards closure of graph
+ downwards_closure
+ = graphFromEdgedVerticesUniq [ DigraphNode uid uid (Set.toList deps)
+ | (uid, deps) <- M.toList (allReachable graph node_key)]
+
+ inverse_closure = transposeG downwards_closure
+
+ upwards_closure = Set.fromList $ map node_key $ reachablesG inverse_closure [DigraphNode uid uid [] | uid <- Set.toList home_id_set]
+
+ all_unit_direct_deps :: UniqMap UnitId (Set.Set UnitId)
+ all_unit_direct_deps
+ = unitEnv_foldWithKey go emptyUniqMap $ ue_home_unit_graph ue
+ where
+ go rest this this_uis =
+ plusUniqMap_C Set.union
+ (addToUniqMap_C Set.union external_depends this (Set.fromList $ this_deps))
+ rest
+ where
+ external_depends = mapUniqMap (Set.fromList . unitDepends) (unitInfoMap this_units)
+ this_units = homeUnitEnv_units this_uis
+ this_deps = [ toUnitId unit | (unit,Just _) <- explicitUnits this_units]
+
+ graphNodes :: [Node UnitId UnitId]
+ graphNodes = go Set.empty home_id_set
+ where
+ go done todo
+ = case Set.minView todo of
+ Nothing -> []
+ Just (uid, todo')
+ | Set.member uid done -> go done todo'
+ | otherwise -> case lookupUniqMap all_unit_direct_deps uid of
+ Nothing -> pprPanic "uid not found" (ppr (uid, all_unit_direct_deps))
+ Just depends ->
+ let todo'' = (depends Set.\\ done) `Set.union` todo'
+ in DigraphNode uid uid (Set.toList depends) : go (Set.insert uid done) todo''
-- | Update the every ModSummary that is depended on
-- by a module that needs template haskell. We enable codegen to
=====================================
compiler/GHC/Parser/Lexer.x
=====================================
@@ -2814,19 +2814,19 @@ characters into single bytes.
{-# INLINE adjustChar #-}
adjustChar :: Char -> Word8
-adjustChar c = fromIntegral $ ord adj_c
- where non_graphic = '\x00'
- upper = '\x01'
- lower = '\x02'
- digit = '\x03'
- symbol = '\x04'
- space = '\x05'
- other_graphic = '\x06'
- uniidchar = '\x07'
+adjustChar c = adj_c
+ where non_graphic = 0x00
+ upper = 0x01
+ lower = 0x02
+ digit = 0x03
+ symbol = 0x04
+ space = 0x05
+ other_graphic = 0x06
+ uniidchar = 0x07
adj_c
| c <= '\x07' = non_graphic
- | c <= '\x7f' = c
+ | c <= '\x7f' = fromIntegral (ord c)
-- Alex doesn't handle Unicode, so when Unicode
-- character is encountered we output these values
-- with the actual character value hidden in the state.
@@ -2866,15 +2866,18 @@ adjustChar c = fromIntegral $ ord adj_c
--
-- See Note [Unicode in Alex] and #13986.
alexInputPrevChar :: AlexInput -> Char
-alexInputPrevChar (AI _ buf) = chr (fromIntegral (adjustChar pc))
+alexInputPrevChar (AI _ buf) = unsafeChr (fromIntegral (adjustChar pc))
where pc = prevChar buf '\n'
+unsafeChr :: Int -> Char
+unsafeChr (I# c) = C# (chr# c)
+
-- backwards compatibility for Alex 2.x
alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
alexGetChar inp = case alexGetByte inp of
Nothing -> Nothing
Just (b,i) -> c `seq` Just (c,i)
- where c = chr $ fromIntegral b
+ where c = unsafeChr $ fromIntegral b
-- See Note [Unicode in Alex]
alexGetByte :: AlexInput -> Maybe (Word8,AlexInput)
=====================================
compiler/GHC/StgToJS/Linker/Linker.hs
=====================================
@@ -738,7 +738,7 @@ writeExterns out = writeFile (out </> "all.js.externs")
-- | Get all block dependencies for a given set of roots
--
--- Returns the update block info map and the blocks.
+-- Returns the updated block info map and the blocks.
getDeps :: Map Module LocatedBlockInfo -- ^ Block info per module
-> (Module -> IO LocatedBlockInfo) -- ^ Used to load block info if missing
-> Set ExportedFun -- ^ start here
@@ -754,7 +754,7 @@ getDeps init_infos load_info root_funs root_blocks = traverse_funs init_infos S.
-- 1. We use the BlockInfos to find the block corresponding to every
-- exported root functions.
--
- -- 2. We had these blocks to the set of root_blocks if they aren't already
+ -- 2. We add these blocks to the set of root_blocks if they aren't already
-- added to the result.
--
-- 3. Then we traverse the root_blocks to find their dependencies and we
=====================================
compiler/GHC/Tc/Module.hs
=====================================
@@ -709,7 +709,7 @@ tcRnHsBootDecls boot_or_sig decls
-- Typecheck type/class/instance decls
; traceTc "Tc2 (boot)" empty
; (tcg_env, inst_infos, _deriv_binds, _th_bndrs)
- <- tcTyClsInstDecls tycl_decls deriv_decls val_binds
+ <- tcTyClsInstDecls tycl_decls deriv_decls def_decls val_binds
; setGblEnv tcg_env $ do {
-- Emit Typeable bindings
@@ -1612,7 +1612,7 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
traceTc "Tc3" empty ;
(tcg_env, inst_infos, th_bndrs,
XValBindsLR (NValBinds deriv_binds deriv_sigs))
- <- tcTyClsInstDecls tycl_decls deriv_decls val_binds ;
+ <- tcTyClsInstDecls tycl_decls deriv_decls default_decls val_binds ;
updLclCtxt (\tcl_env -> tcl_env { tcl_th_bndrs = th_bndrs `plusNameEnv` tcl_th_bndrs tcl_env }) $
setGblEnv tcg_env $ do {
@@ -1622,11 +1622,6 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
(fi_ids, fi_decls, fi_gres) <- tcForeignImports foreign_decls ;
tcExtendGlobalValEnv fi_ids $ do {
- -- Default declarations
- traceTc "Tc4a" empty ;
- default_tys <- tcDefaults default_decls ;
- updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
-
-- Value declarations next.
-- It is important that we check the top-level value bindings
-- before the GHC-generated derived bindings, since the latter
@@ -1686,13 +1681,14 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
addUsedGREs NoDeprecationWarnings (bagToList fo_gres) ;
return (tcg_env', tcl_env)
- }}}}}}
+ }}}}}
tcTopSrcDecls _ = panic "tcTopSrcDecls: ValBindsIn"
---------------------------
tcTyClsInstDecls :: [TyClGroup GhcRn]
-> [LDerivDecl GhcRn]
+ -> [LDefaultDecl GhcRn]
-> [(RecFlag, LHsBinds GhcRn)]
-> TcM (TcGblEnv, -- The full inst env
[InstInfo GhcRn], -- Source-code instance decls to
@@ -1702,16 +1698,24 @@ tcTyClsInstDecls :: [TyClGroup GhcRn]
HsValBinds GhcRn) -- Supporting bindings for derived
-- instances
-tcTyClsInstDecls tycl_decls deriv_decls binds
+tcTyClsInstDecls tycl_decls deriv_decls default_decls binds
= tcAddDataFamConPlaceholders (tycl_decls >>= group_instds) $
tcAddPatSynPlaceholders (getPatSynBinds binds) $
do { (tcg_env, inst_info, deriv_info, th_bndrs)
<- tcTyAndClassDecls tycl_decls ;
+
; setGblEnv tcg_env $ do {
+
-- With the @TyClDecl at s and @InstDecl at s checked we're ready to
-- process the deriving clauses, including data family deriving
-- clauses discovered in @tcTyAndClassDecls at .
--
+ -- But only after we've typechecked 'default' declarations.
+ -- See Note [Typechecking default declarations]
+ default_tys <- tcDefaults default_decls ;
+ updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
+
+
-- Careful to quit now in case there were instance errors, so that
-- the deriving errors don't pile up as well.
; failIfErrsM
@@ -1720,7 +1724,7 @@ tcTyClsInstDecls tycl_decls deriv_decls binds
; setGblEnv tcg_env' $ do {
failIfErrsM
; pure ( tcg_env', inst_info' ++ inst_info, th_bndrs, val_binds )
- }}}
+ }}}}
{- *********************************************************************
* *
@@ -3141,3 +3145,43 @@ mark_plugin_unsafe dflags = unless (gopt Opt_PluginTrustworthy dflags) $
pluginUnsafe =
singleMessage $
mkPlainMsgEnvelope diag_opts noSrcSpan TcRnUnsafeDueToPlugin
+
+
+-- Note [Typechecking default declarations]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- Typechecking default declarations requires careful placement:
+--
+-- 1. We must check them after types (tcTyAndClassDecls) because they can refer
+-- to them. E.g.
+--
+-- data T = MkT ...
+-- default(Int, T, Integer)
+--
+-- -- or even (tested by T11974b and T2245)
+-- default(Int, T, Integer)
+-- data T = MkT ...
+--
+-- 2. We must check them before typechecking deriving clauses (tcInstDeclsDeriv)
+-- otherwise we may lookup default default types (Integer, Double) while checking
+-- deriving clauses, ignoring the default declaration.
+--
+-- Before this careful placement (#24566), compiling the following example
+-- (T24566) with "-ddump-if-trace -ddump-tc-trace" showed a call to
+-- `applyDefaultingRules` with default types set to "(Integer,Double)":
+--
+-- module M where
+--
+-- import GHC.Classes
+-- default ()
+--
+-- data Foo a = Nothing | Just a
+-- deriving (Eq, Ord)
+--
+-- This was an issue while building modules like M in the ghc-internal package
+-- because they would spuriously fail to build if the module defining Integer
+-- (ghc-bignum:GHC.Num.Integer) wasn't compiled yet and its interface not to be
+-- found. The implicit dependency between M and GHC.Num.Integer isn't known to
+-- the build system.
+-- In addition, trying to explicitly avoid the implicit dependency with `default
+-- ()` didn't work, except if *standalone* deriving was used, which was an
+-- inconsistent behavior.
=====================================
libraries/ghc-internal/src/GHC/Internal/Maybe.hs
=====================================
@@ -28,14 +28,5 @@ default ()
--
data Maybe a = Nothing | Just a
deriving ( Eq -- ^ @since base-2.01
-
- --, Ord -- ^ @since base-2.01
+ , Ord -- ^ @since base-2.01
)
-
--- ???
--- A non-standalone instance will slurp the interface file for GHC.Num.Integer.
- -- During simplifyInstanceContexts, a call to GHC.Tc.Utils.Env.tcGetDefaultTys
- -- apparently sees mb_defaults = Nothing and thus tries to bring in the
- -- default "default" types, including Integer. This seems wrong.
-deriving instance Ord a => Ord (Maybe a) -- ^ @since base-2.01
-
=====================================
testsuite/tests/codeGen/should_run/T24507.hs
=====================================
@@ -0,0 +1,15 @@
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE GHCForeignImportPrim #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+
+module Main where
+
+import GHC.Exts
+
+foreign import prim "foo" foo :: Int# -> Int#
+
+main = do
+
+ let f x = case x of I# x' -> case foo x' of x -> print (I# x)
+ mapM_ f [1..7]
\ No newline at end of file
=====================================
testsuite/tests/codeGen/should_run/T24507.stdout
=====================================
@@ -0,0 +1,7 @@
+1
+2
+2
+2
+2
+2
+2
=====================================
testsuite/tests/codeGen/should_run/T24507_cmm.cmm
=====================================
@@ -0,0 +1,35 @@
+#include "Cmm.h"
+
+foo(W_ x) {
+
+ switch(x) {
+ case 1: goto a;
+ case 2: goto b;
+ case 3: goto c;
+ case 4: goto d;
+ case 5: goto e;
+ case 6: goto f;
+ case 7: goto g;
+ }
+ return (1);
+
+ a:
+ return (1);
+ b:
+ jump bar();
+ c:
+ jump bar();
+ d:
+ jump bar();
+ e:
+ jump bar();
+ f:
+ jump bar();
+ g:
+ jump bar();
+
+}
+
+bar() {
+ return (2);
+}
\ No newline at end of file
=====================================
testsuite/tests/codeGen/should_run/all.T
=====================================
@@ -243,3 +243,6 @@ test('MulMayOflo_full',
test('T24264run', normal, compile_and_run, [''])
test('T24295a', normal, compile_and_run, ['-O -floopification'])
test('T24295b', normal, compile_and_run, ['-O -floopification -fpedantic-bottoms'])
+
+test('T24507', [req_cmm], multi_compile_and_run,
+ ['T24507', [('T24507_cmm.cmm', '')], '-O2'])
=====================================
testsuite/tests/driver/multipleHomeUnits/mhu-perf/Makefile
=====================================
@@ -0,0 +1,23 @@
+TOP=../../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+SETUP=../Setup -v0
+
+mhu-perf: clean
+ $(MAKE) -s --no-print-directory clean
+ ./genLargeHMU
+ '$(GHC_PKG)' init tmp.d
+ '$(TEST_HC)' $(TEST_HC_OPTS) -v0 --make Setup
+ for dir in unit-p*; do \
+ cd $$dir && $(SETUP) clean && $(SETUP) configure $(CABAL_MINIMAL_BUILD) --ipid=$$dir-0.1.0.0 --with-ghc='$(TEST_HC)' --with-hc-pkg='$(GHC_PKG)' --ghc-options='$(TEST_HC_OPTS)' --package-db=../tmp.d && $(SETUP) build && $(SETUP) register --inplace && cd ..; \
+ done;
+
+
+ifeq "$(CLEANUP)" "1"
+ $(MAKE) -s --no-print-directory clean
+endif
+
+clean :
+ $(RM) -r unitTop* unit-p* top*/ tmp*.d inst-* *.o *.hi */*.o */*.hi */Setup$(exeext) */dist Setup$(exeext)
+
=====================================
testsuite/tests/driver/multipleHomeUnits/mhu-perf/Setup.hs
=====================================
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
=====================================
testsuite/tests/driver/multipleHomeUnits/mhu-perf/all.T
=====================================
@@ -0,0 +1,8 @@
+test('mhu-perf',
+ [ collect_compiler_stats('bytes allocated',2),
+ extra_files(['genLargeHMU','Setup.hs']),
+ pre_cmd('$MAKE -s --no-print-directory mhu-perf'),
+ compile_timeout_multiplier(5)
+ ],
+ multiunit_compile,
+ [['unitTop1', 'unitTop2'], '-fhide-source-paths'])
=====================================
testsuite/tests/driver/multipleHomeUnits/mhu-perf/genLargeHMU
=====================================
@@ -0,0 +1,54 @@
+#!/usr/bin/env bash
+# Generate $DEPTH layers of packages with $WIDTH modules on each layer
+# Every package on layer N depends on all the packages on layer N-1
+# unitTop imports all the units from the last layer
+DEPTH=8
+WIDTH=8
+for i in $(seq -w 1 $WIDTH); do
+ mkdir unit-p0M$i
+ echo "module DummyLevel0M$i where" > unit-p0M$i/DummyLevel0M$i.hs;
+ cat > unit-p0M$i/unit-p0M$i.cabal <<EOF
+name: unit-p0M$i
+version: 0.1.0.0
+build-type: Simple
+cabal-version: >=1.10
+library
+ default-language: Haskell2010
+ exposed-modules: DummyLevel0M$i
+ build-depends: base
+EOF
+done
+for l in $(seq 1 $DEPTH); do
+ for i in $(seq -w 1 $WIDTH); do
+ mkdir unit-p${l}M$i
+ cat > unit-p${l}M$i/unit-p${l}M$i.cabal <<EOF
+name: unit-p${l}M$i
+version: 0.1.0.0
+build-type: Simple
+cabal-version: >=1.10
+library
+ default-language: Haskell2010
+ exposed-modules: DummyLevel${l}M$i
+ build-depends: base
+EOF
+ echo "module DummyLevel${l}M$i where" > unit-p${l}M$i/DummyLevel${l}M$i.hs;
+ for j in $(seq -w 1 $WIDTH); do
+ echo " , unit-p$((l-1))M$j" >> unit-p${l}M$i/unit-p${l}M$i.cabal
+ echo "import DummyLevel$((l-1))M$j" >> unit-p${l}M$i/DummyLevel${l}M$i.hs;
+ done
+ done
+done
+mkdir top1
+echo "module Top1 where" > top1/Top1.hs
+echo "-package-db ./tmp.d -i -itop1 Top1 -this-unit-id unit-top1 -package base" > unitTop1;
+for j in $(seq -w 1 $WIDTH); do
+ echo "-package unit-p${DEPTH}M$j" >> unitTop1;
+ echo "import DummyLevel${DEPTH}M$j" >> top1/Top1.hs;
+done
+mkdir top2
+echo "module Top2 where" > top2/Top2.hs
+echo "-package-db ./tmp.d -i -itop2 Top2 -this-unit-id unit-top2 -package base" > unitTop2;
+for j in $(seq -w 2 $WIDTH); do
+ echo "-package unit-p${DEPTH}M$j" >> unitTop2;
+ echo "import DummyLevel${DEPTH}M$j" >> top2/Top2.hs;
+done
=====================================
testsuite/tests/driver/multipleHomeUnits/mhu-perf/mhu-perf.stderr
=====================================
@@ -0,0 +1,2 @@
+[1 of 2] Compiling Top1[unit-top1]
+[2 of 2] Compiling Top2[unit-top2]
=====================================
testsuite/tests/simplCore/should_compile/T24551.hs
=====================================
@@ -0,0 +1,15 @@
+{-# LANGUAGE MagicHash #-}
+module T24551 (f) where
+
+import GHC.Exts
+
+f :: a -> a
+f = repeatFB g
+
+repeatFB :: (Addr# -> (a -> a) -> a -> a) -> a -> a
+repeatFB c = let xs = c "missing"# xs in xs
+{-# INLINE [0] repeatFB #-}
+
+g :: Addr# -> (a -> a) -> a -> a
+g _ _ x = x
+{-# NOINLINE g #-}
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -514,3 +514,4 @@ test('T23209', [extra_files(['T23209_Aux.hs'])], multimod_compile, ['T23209', '-
test('T24229a', [ grep_errmsg(r'wfoo') ], compile, ['-O2 -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques -dppr-cols=99999'])
test('T24229b', [ grep_errmsg(r'wfoo') ], compile, ['-O2 -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques -dppr-cols=99999'])
test('T24370', normal, compile, ['-O'])
+test('T24551', normal, compile, ['-O -dcore-lint'])
=====================================
testsuite/tests/typecheck/should_compile/Makefile
=====================================
@@ -122,3 +122,7 @@ InlinePatSyn_ExplicitBidiBuilder:
InlinePatSyn_ExplicitBidiMatcher:
$(RM) -f InlinePatSyn_ExplicitBidiMatcher.o InlinePatSyn_ExplicitBidiMatcher.hi
'$(TEST_HC)' $(TEST_HC_OPTS) -c InlinePatSyn_ExplicitBidiMatcher.hs -O -dsuppress-all -ddump-simpl | sed -n '/^test/,/^$$/p' | grep -vq 'Pattern'
+
+T24566:
+ '$(TEST_HC)' $(TEST_HC_OPTS) -c T24566.hs -fno-code -dno-typeable-binds -ddump-if-trace 2>&1 | grep Integer || true
+ # Not expecting any mention of Integer in the interface loading trace
=====================================
testsuite/tests/typecheck/should_compile/T24566.hs
=====================================
@@ -0,0 +1,7 @@
+module M where
+
+import GHC.Classes
+default ()
+
+data Foo a = Nothing | Just a
+ deriving (Eq, Ord)
=====================================
testsuite/tests/typecheck/should_compile/all.T
=====================================
@@ -913,3 +913,4 @@ test('T17594a', req_th, compile, [''])
test('T17594f', normal, compile, [''])
test('WarnDefaultedExceptionContext', normal, compile, ['-Wdefaulted-exception-context'])
test('T24470b', normal, compile, [''])
+test('T24566', [], makefile_test, [])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fbad35abf2a06c8890d932e03782de507e169ec8...0aeb789f4fa6b0547540c6f2ea6670650b51e022
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fbad35abf2a06c8890d932e03782de507e169ec8...0aeb789f4fa6b0547540c6f2ea6670650b51e022
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240322/32bb2d68/attachment-0001.html>
More information about the ghc-commits
mailing list