[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 12 commits: Hadrian: correctly detect AR at-file support
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Thu Jan 26 09:54:17 UTC 2023
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
e987e345 by Sylvain Henry at 2023-01-25T14:47:41-05:00
Hadrian: correctly detect AR at-file support
Stage0's ar may not support at-files. Take it into account.
Found while cross-compiling from Darwin to Windows.
- - - - -
48131ee2 by Sylvain Henry at 2023-01-25T14:47:41-05:00
Hadrian: fix Windows cross-compilation
Decision to build either unix or Win32 package must be stage specific
for cross-compilation to be supported.
- - - - -
288fa017 by Sylvain Henry at 2023-01-25T14:47:41-05:00
Fix RTS build on Windows
This change fixes a cross-compilation issue from ArchLinux to Windows
because these symbols weren't found.
- - - - -
2fdf22ae by Sylvain Henry at 2023-01-25T14:47:41-05:00
configure: support "windows" as an OS
- - - - -
13a0566b by Simon Peyton Jones at 2023-01-25T14:48:16-05:00
Fix in-scope set in specImports
Nothing deep here; I had failed to bring some
floated dictionary binders into scope.
Exposed by -fspecialise-aggressively
Fixes #22715.
- - - - -
b7efdb24 by Matthew Pickering at 2023-01-25T14:48:51-05:00
ci: Disable HLint job due to excessive runtime
The HLint jobs takes much longer to run (20 minutes) after "Give the RTS it's own configure script" eb5a6b91
Now the CI job will build the stage0 compiler before it generates the necessary RTS headers.
We either need to:
* Fix the linting rules so they take much less time
* Revert the commit
* Remove the linting of base from the hlint job
* Remove the hlint job
This is highest priority as it is affecting all CI pipelines.
For now I am just disabling the job because there are many more pressing
matters at hand.
Ticket #22830
- - - - -
0497d592 by Sylvain Henry at 2023-01-26T04:53:56-05:00
Factorize hptModulesBelow
Create and use moduleGraphModulesBelow in GHC.Unit.Module.Graph that
doesn't need anything from the driver to be used.
- - - - -
cc605e6c by Matthew Pickering at 2023-01-26T04:53:56-05:00
Store dehydrated data structures in CgModBreaks
This fixes a tricky leak in GHCi where we were retaining old copies of
HscEnvs when reloading. If not all modules were recompiled then these
hydrated fields in break points would retain a reference to the old
HscEnv which could double memory usage.
Fixes #22530
- - - - -
de30896f by Matthew Pickering at 2023-01-26T04:53:57-05:00
Force more in NFData Name instance
Doesn't force the lazy `OccName` field (#19619) which is already known
as a really bad source of leaks.
When we slam the hammer storing Names on disk (in interface files or the
like), all this should be forced as otherwise a `Name` can easily retain
an `Id` and hence the entire world.
Fixes #22833
- - - - -
76d2ee53 by Matthew Pickering at 2023-01-26T04:53:57-05:00
Force OccName in tidyTopName
This occname has just been derived from an `Id`, so need to force it
promptly so we can release the Id back to the world.
Another symptom of the bug caused by #19619
- - - - -
879205d5 by Matthew Pickering at 2023-01-26T04:53:57-05:00
Strict fields in ModNodeKey (otherwise retains HomeModInfo)
Towards #22530
- - - - -
17fda35d by Sylvain Henry at 2023-01-26T04:53:59-05:00
Hadrian: fix doc generation
Was missing dependencies on files generated by templates (e.g.
ghc.cabal)
- - - - -
23 changed files:
- .gitlab-ci.yml
- compiler/GHC/ByteCode/Types.hs
- compiler/GHC/Core/Opt/Specialise.hs
- compiler/GHC/CoreToIface.hs
- compiler/GHC/Driver/Env.hs
- compiler/GHC/Iface/Tidy.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/StgToByteCode.hs
- compiler/GHC/Types/Name.hs
- compiler/GHC/Unit/Module/Graph.hs
- hadrian/cfg/system.config.in
- hadrian/src/Builder.hs
- hadrian/src/Oracles/Flag.hs
- hadrian/src/Rules/Documentation.hs
- hadrian/src/Rules/Generate.hs
- hadrian/src/Settings/Default.hs
- m4/fptools_set_haskell_platform_vars.m4
- m4/ghc_convert_os.m4
- rts/RtsSymbols.c
- + testsuite/tests/simplCore/should_compile/T22715_2.hs
- + testsuite/tests/simplCore/should_compile/T22715_2a.hs
- testsuite/tests/simplCore/should_compile/all.T
Changes:
=====================================
.gitlab-ci.yml
=====================================
@@ -329,7 +329,8 @@ lint-submods-branch:
paths:
- cabal-cache
-hlint-ghc-and-base:
+# Disabled due to #22830
+.hlint-ghc-and-base:
extends: .lint-params
image: "registry.gitlab.haskell.org/ghc/ci-images/linters:$DOCKER_REV"
variables:
=====================================
compiler/GHC/ByteCode/Types.hs
=====================================
@@ -23,12 +23,10 @@ import GHC.Prelude
import GHC.Data.FastString
import GHC.Data.SizedSeq
-import GHC.Types.Id
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Utils.Outputable
import GHC.Builtin.PrimOps
-import GHC.Core.Type
import GHC.Types.SrcLoc
import GHCi.BreakArray
import GHCi.RemoteTypes
@@ -41,10 +39,10 @@ import Data.Array.Base ( UArray(..) )
import Data.ByteString (ByteString)
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
-import Data.Maybe (catMaybes)
import qualified GHC.Exts.Heap as Heap
import GHC.Stack.CCS
import GHC.Cmm.Expr ( GlobalRegSet, emptyRegSet, regSetToList )
+import GHC.Iface.Syntax
-- -----------------------------------------------------------------------------
-- Compiled Byte Code
@@ -174,18 +172,22 @@ instance NFData BCONPtr where
rnf x = x `seq` ()
-- | Information about a breakpoint that we know at code-generation time
+-- In order to be used, this needs to be hydrated relative to the current HscEnv by
+-- 'hydrateCgBreakInfo'. Everything here can be fully forced and that's critical for
+-- preventing space leaks (see #22530)
data CgBreakInfo
= CgBreakInfo
- { cgb_vars :: [Maybe (Id,Word16)]
- , cgb_resty :: Type
+ { cgb_tyvars :: ![IfaceTvBndr] -- ^ Type variables in scope at the breakpoint
+ , cgb_vars :: ![Maybe (IfaceIdBndr, Word16)]
+ , cgb_resty :: !IfaceType
}
-- See Note [Syncing breakpoint info] in GHC.Runtime.Eval
--- Not a real NFData instance because we can't rnf Id or Type
seqCgBreakInfo :: CgBreakInfo -> ()
seqCgBreakInfo CgBreakInfo{..} =
- rnf (map snd (catMaybes (cgb_vars))) `seq`
- seqType cgb_resty
+ rnf cgb_tyvars `seq`
+ rnf cgb_vars `seq`
+ rnf cgb_resty
instance Outputable UnlinkedBCO where
ppr (UnlinkedBCO nm _arity _insns _bitmap lits ptrs)
=====================================
compiler/GHC/Core/Opt/Specialise.hs
=====================================
@@ -33,6 +33,7 @@ import GHC.Core.Utils ( exprIsTrivial
import GHC.Core.FVs
import GHC.Core.TyCo.FVs ( tyCoVarsOfTypeList )
import GHC.Core.Opt.Arity( collectBindersPushingCo )
+-- import GHC.Core.Ppr( pprIds )
import GHC.Builtin.Types ( unboxedUnitTy )
@@ -736,7 +737,8 @@ specImports top_env (MkUD { ud_binds = dict_binds, ud_calls = calls })
= return ([], wrapDictBinds dict_binds [])
| otherwise
- = do { (_env, spec_rules, spec_binds) <- spec_imports top_env [] dict_binds calls
+ = do { let env_w_dict_bndrs = top_env `bringFloatedDictsIntoScope` dict_binds
+ ; (_env, spec_rules, spec_binds) <- spec_imports env_w_dict_bndrs [] dict_binds calls
-- Don't forget to wrap the specialized bindings with
-- bindings for the needed dictionaries.
@@ -752,6 +754,7 @@ specImports top_env (MkUD { ud_binds = dict_binds, ud_calls = calls })
-- | Specialise a set of calls to imported bindings
spec_imports :: SpecEnv -- Passed in so that all top-level Ids are in scope
+ ---In-scope set includes the FloatedDictBinds
-> [Id] -- Stack of imported functions being specialised
-- See Note [specImport call stack]
-> FloatedDictBinds -- Dict bindings, used /only/ for filterCalls
@@ -781,6 +784,7 @@ spec_imports env callers dict_binds calls
; return (env, rules1 ++ rules2, spec_binds1 ++ spec_binds2) }
spec_import :: SpecEnv -- Passed in so that all top-level Ids are in scope
+ ---In-scope set includes the FloatedDictBinds
-> [Id] -- Stack of imported functions being specialised
-- See Note [specImport call stack]
-> FloatedDictBinds -- Dict bindings, used /only/ for filterCalls
@@ -806,23 +810,35 @@ spec_import env callers dict_binds cis@(CIS fn _)
; eps_rules <- getExternalRuleBase
; let rule_env = se_rules env `updExternalPackageRules` eps_rules
--- ; debugTraceMsg (text "specImport1" <+> vcat [ppr fn, ppr good_calls
--- , ppr (getRules rule_env fn), ppr rhs])
+-- ; debugTraceMsg (text "specImport1" <+> vcat
+-- [ text "function:" <+> ppr fn
+-- , text "good calls:" <+> ppr good_calls
+-- , text "existing rules:" <+> ppr (getRules rule_env fn)
+-- , text "rhs:" <+> ppr rhs
+-- , text "dict_binds:" <+> ppr dict_binds ])
+
; (rules1, spec_pairs, MkUD { ud_binds = dict_binds1, ud_calls = new_calls })
- <- runSpecM $ specCalls True env dict_binds
- (getRules rule_env fn) good_calls fn rhs
+ <- runSpecM $ specCalls True env (getRules rule_env fn) good_calls fn rhs
; let spec_binds1 = [NonRec b r | (b,r) <- spec_pairs]
- -- After the rules kick in we may get recursion, but
- -- we rely on a global GlomBinds to sort that out later
+ -- After the rules kick in, via fireRewriteRules, we may get recursion,
+ -- but we rely on a global GlomBinds to sort that out later
-- See Note [Glom the bindings if imported functions are specialised]
+ -- Meanwhile, though, bring the binders into scope
new_subst = se_subst env `Core.extendSubstInScopeList` map fst spec_pairs
new_env = env { se_rules = rule_env `addLocalRules` rules1
, se_subst = new_subst }
+ `bringFloatedDictsIntoScope` dict_binds1
+
+ -- Now specialise any cascaded calls
+-- ; debugTraceMsg (text "specImport 2" <+> vcat
+-- [ text "function:" <+> ppr fn
+-- , text "rules1:" <+> ppr rules1
+-- , text "spec_binds1" <+> ppr spec_binds1
+-- , text "dict_binds1" <+> ppr dict_binds1
+-- , text "new_calls" <+> ppr new_calls ])
- -- Now specialise any cascaded calls
--- ; debugTraceMsg (text "specImport 2" <+> (ppr fn $$ ppr rules1 $$ ppr spec_binds1))
; (env, rules2, spec_binds2)
<- spec_imports new_env (fn:callers)
(dict_binds `thenFDBs` dict_binds1)
@@ -1561,10 +1577,11 @@ specDefn :: SpecEnv
specDefn env body_uds fn rhs
= do { let (body_uds_without_me, calls_for_me) = callsForMe fn body_uds
rules_for_me = idCoreRules fn
- dict_binds = ud_binds body_uds
+ -- Bring into scope the binders from the floated dicts
+ env_w_dict_bndrs = bringFloatedDictsIntoScope env (ud_binds body_uds)
- ; (rules, spec_defns, spec_uds) <- specCalls False env dict_binds
- rules_for_me calls_for_me fn rhs
+ ; (rules, spec_defns, spec_uds) <- specCalls False env_w_dict_bndrs
+ rules_for_me calls_for_me fn rhs
; return ( fn `addIdSpecialisations` rules
, spec_defns
@@ -1580,7 +1597,6 @@ specDefn env body_uds fn rhs
specCalls :: Bool -- True => specialising imported fn
-- False => specialising local fn
-> SpecEnv
- -> FloatedDictBinds -- Just so that we can extend the in-scope set
-> [CoreRule] -- Existing RULES for the fn
-> [CallInfo]
-> OutId -> InExpr
@@ -1594,7 +1610,7 @@ type SpecInfo = ( [CoreRule] -- Specialisation rules
, [(Id,CoreExpr)] -- Specialised definition
, UsageDetails ) -- Usage details from specialised RHSs
-specCalls spec_imp env dict_binds existing_rules calls_for_me fn rhs
+specCalls spec_imp env existing_rules calls_for_me fn rhs
-- The first case is the interesting one
| notNull calls_for_me -- And there are some calls to specialise
&& not (isNeverActive (idInlineActivation fn))
@@ -1610,8 +1626,11 @@ specCalls spec_imp env dict_binds existing_rules calls_for_me fn rhs
-- See Note [Inline specialisations] for why we do not
-- switch off specialisation for inline functions
- = -- pprTrace "specCalls: some" (ppr fn $$ ppr calls_for_me $$ ppr existing_rules) $
- foldlM spec_call ([], [], emptyUDs) calls_for_me
+ = do { -- debugTraceMsg (text "specCalls: some" <+> vcat
+ -- [ text "function" <+> ppr fn
+ -- , text "calls:" <+> ppr calls_for_me
+ -- , text "subst" <+> ppr (se_subst env) ])
+ ; foldlM spec_call ([], [], emptyUDs) calls_for_me }
| otherwise -- No calls or RHS doesn't fit our preconceptions
= warnPprTrace (not (exprIsTrivial rhs) && notNull calls_for_me && not (isClassOpId fn))
@@ -1639,9 +1658,6 @@ specCalls spec_imp env dict_binds existing_rules calls_for_me fn rhs
(rhs_bndrs, rhs_body) = collectBindersPushingCo rhs
-- See Note [Account for casts in binding]
- -- Bring into scope the binders from the floated dicts
- env_with_dict_bndrs = bringFloatedDictsIntoScope env dict_binds
-
already_covered :: SpecEnv -> [CoreRule] -> [CoreExpr] -> Bool
already_covered env new_rules args -- Note [Specialisations already covered]
= isJust (specLookupRule env fn args (beginPhase inl_act)
@@ -1667,22 +1683,22 @@ specCalls spec_imp env dict_binds existing_rules calls_for_me fn rhs
; ( useful, rhs_env2, leftover_bndrs
, rule_bndrs, rule_lhs_args
- , spec_bndrs1, dx_binds, spec_args) <- specHeader env_with_dict_bndrs
- rhs_bndrs all_call_args
-
--- ; pprTrace "spec_call" (vcat [ text "fun: " <+> ppr fn
--- , text "call info: " <+> ppr _ci
--- , text "useful: " <+> ppr useful
--- , text "rule_bndrs:" <+> ppr rule_bndrs
--- , text "lhs_args: " <+> ppr rule_lhs_args
--- , text "spec_bndrs1:" <+> ppr spec_bndrs1
--- , text "leftover_bndrs:" <+> pprIds leftover_bndrs
--- , text "spec_args: " <+> ppr spec_args
--- , text "dx_binds: " <+> ppr dx_binds
--- , text "rhs_body" <+> ppr rhs_body
--- , text "rhs_env2: " <+> ppr (se_subst rhs_env2)
--- , ppr dx_binds ]) $
--- return ()
+ , spec_bndrs1, dx_binds, spec_args) <- specHeader env rhs_bndrs all_call_args
+
+-- ; debugTraceMsg (text "spec_call" <+> vcat
+-- [ text "fun: " <+> ppr fn
+-- , text "call info: " <+> ppr _ci
+-- , text "useful: " <+> ppr useful
+-- , text "rule_bndrs:" <+> ppr rule_bndrs
+-- , text "lhs_args: " <+> ppr rule_lhs_args
+-- , text "spec_bndrs1:" <+> ppr spec_bndrs1
+-- , text "leftover_bndrs:" <+> pprIds leftover_bndrs
+-- , text "spec_args: " <+> ppr spec_args
+-- , text "dx_binds: " <+> ppr dx_binds
+-- , text "rhs_bndrs" <+> ppr rhs_bndrs
+-- , text "rhs_body" <+> ppr rhs_body
+-- , text "rhs_env2: " <+> ppr (se_subst rhs_env2)
+-- , ppr dx_binds ]
; if not useful -- No useful specialisation
|| already_covered rhs_env2 rules_acc rule_lhs_args
=====================================
compiler/GHC/CoreToIface.hs
=====================================
@@ -43,12 +43,18 @@ module GHC.CoreToIface
, toIfaceVar
-- * Other stuff
, toIfaceLFInfo
+ -- * CgBreakInfo
+ , dehydrateCgBreakInfo
) where
import GHC.Prelude
+import Data.Word
+
import GHC.StgToCmm.Types
+import GHC.ByteCode.Types
+
import GHC.Core
import GHC.Core.TyCon hiding ( pprPromotionQuote )
import GHC.Core.Coercion.Axiom
@@ -685,6 +691,16 @@ toIfaceLFInfo nm lfi = case lfi of
LFLetNoEscape ->
panic "toIfaceLFInfo: LFLetNoEscape"
+-- Dehydrating CgBreakInfo
+
+dehydrateCgBreakInfo :: [TyVar] -> [Maybe (Id, Word16)] -> Type -> CgBreakInfo
+dehydrateCgBreakInfo ty_vars idOffSets tick_ty =
+ CgBreakInfo
+ { cgb_tyvars = map toIfaceTvBndr ty_vars
+ , cgb_vars = map (fmap (\(i, offset) -> (toIfaceIdBndr i, offset))) idOffSets
+ , cgb_resty = toIfaceType tick_ty
+ }
+
{- Note [Inlining and hs-boot files]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this example (#10083, #12789):
=====================================
compiler/GHC/Driver/Env.hs
=====================================
@@ -1,4 +1,3 @@
-{-# LANGUAGE LambdaCase #-}
module GHC.Driver.Env
( Hsc(..)
@@ -84,10 +83,7 @@ import GHC.Utils.Logger
import Data.IORef
import qualified Data.Set as Set
-import Data.Set (Set)
import GHC.Unit.Module.Graph
-import Data.List (sort)
-import qualified Data.Map as Map
runHsc :: HscEnv -> Hsc a -> IO a
runHsc hsc_env (Hsc hsc) = do
@@ -267,35 +263,6 @@ hptAllThings :: (HomeModInfo -> [a]) -> HscEnv -> [a]
hptAllThings extract hsc_env = concatMap (concatMap extract . eltsHpt . homeUnitEnv_hpt . snd)
(hugElts (hsc_HUG hsc_env))
--- | This function returns all the modules belonging to the home-unit that can
--- be reached by following the given dependencies. Additionally, if both the
--- boot module and the non-boot module can be reached, it only returns the
--- non-boot one.
-hptModulesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> Set ModNodeKeyWithUid
-hptModulesBelow hsc_env uid mn = filtered_mods $ [ mn | NodeKey_Module mn <- modules_below]
- where
- td_map = mgTransDeps (hsc_mod_graph hsc_env)
-
- modules_below = maybe [] Set.toList $ Map.lookup (NodeKey_Module (ModNodeKeyWithUid mn uid)) td_map
-
- filtered_mods = Set.fromDistinctAscList . filter_mods . sort
-
- -- IsBoot and NotBoot modules are necessarily consecutive in the sorted list
- -- (cf Ord instance of GenWithIsBoot). Hence we only have to perform a
- -- linear sweep with a window of size 2 to remove boot modules for which we
- -- have the corresponding non-boot.
- filter_mods = \case
- (r1@(ModNodeKeyWithUid (GWIB m1 b1) uid1) : r2@(ModNodeKeyWithUid (GWIB m2 _) uid2): rs)
- | m1 == m2 && uid1 == uid2 ->
- let !r' = case b1 of
- NotBoot -> r1
- IsBoot -> r2
- in r' : filter_mods rs
- | otherwise -> r1 : filter_mods (r2:rs)
- rs -> rs
-
-
-
-- | Get things from modules "below" this one (in the dependency sense)
-- C.f Inst.hptInstances
hptSomeThingsBelowUs :: (HomeModInfo -> [a]) -> Bool -> HscEnv -> UnitId -> ModuleNameWithIsBoot -> [a]
@@ -304,11 +271,12 @@ hptSomeThingsBelowUs extract include_hi_boot hsc_env uid mn
| otherwise
= let hug = hsc_HUG hsc_env
+ mg = hsc_mod_graph hsc_env
in
[ thing
|
-- Find each non-hi-boot module below me
- (ModNodeKeyWithUid (GWIB { gwib_mod = mod, gwib_isBoot = is_boot }) mod_uid) <- Set.toList (hptModulesBelow hsc_env uid mn)
+ (ModNodeKeyWithUid (GWIB { gwib_mod = mod, gwib_isBoot = is_boot }) mod_uid) <- Set.toList (moduleGraphModulesBelow mg uid mn)
, include_hi_boot || (is_boot == NotBoot)
-- unsavoury: when compiling the base package with --make, we
@@ -324,7 +292,7 @@ hptSomeThingsBelowUs extract include_hi_boot hsc_env uid mn
Nothing -> pprTrace "WARNING in hptSomeThingsBelowUs" msg mempty
msg = vcat [text "missing module" <+> ppr mod,
text "When starting from" <+> ppr mn,
- text "below:" <+> ppr (hptModulesBelow hsc_env uid mn),
+ text "below:" <+> ppr (moduleGraphModulesBelow mg uid mn),
text "Probable cause: out-of-date interface files"]
-- This really shouldn't happen, but see #962
, thing <- things
=====================================
compiler/GHC/Iface/Tidy.hs
=====================================
@@ -1077,7 +1077,8 @@ tidyTopName mod name_cache maybe_ref occ_env id
-- we have to update the name cache in a nice atomic fashion
| local && internal = do uniq <- takeUniqFromNameCache name_cache
- let new_local_name = mkInternalName uniq occ' loc
+ -- See #19619
+ let new_local_name = occ' `seq` mkInternalName uniq occ' loc
return (occ_env', new_local_name)
-- Even local, internal names must get a unique occurrence, because
-- if we do -split-objs we externalise the name later, in the code generator
=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -12,6 +12,7 @@ Type checking of type signatures in interface files
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE RecordWildCards #-}
module GHC.IfaceToCore (
tcLookupImported_maybe,
@@ -25,10 +26,15 @@ module GHC.IfaceToCore (
tcIfaceExpr, -- Desired by HERMIT (#7683)
tcIfaceGlobal,
tcIfaceOneShot, tcTopIfaceBindings,
+ hydrateCgBreakInfo
) where
import GHC.Prelude
+import GHC.ByteCode.Types
+
+import Data.Word
+
import GHC.Driver.Env
import GHC.Driver.Session
import GHC.Driver.Config.Core.Lint ( initLintConfig )
@@ -2166,3 +2172,12 @@ bindIfaceTyConBinderX :: (IfaceBndr -> (TyCoVar -> IfL a) -> IfL a)
bindIfaceTyConBinderX bind_tv (Bndr tv vis) thing_inside
= bind_tv tv $ \tv' ->
thing_inside (Bndr tv' vis)
+
+-- CgBreakInfo
+
+hydrateCgBreakInfo :: CgBreakInfo -> IfL ([Maybe (Id, Word16)], Type)
+hydrateCgBreakInfo CgBreakInfo{..} = do
+ bindIfaceTyVars cgb_tyvars $ \_ -> do
+ result_ty <- tcIfaceType cgb_resty
+ mbVars <- mapM (traverse (\(if_gbl, offset) -> (,offset) <$> bindIfaceId if_gbl return)) cgb_vars
+ return (mbVars, result_ty)
=====================================
compiler/GHC/Runtime/Eval.hs
=====================================
@@ -136,6 +136,7 @@ import GHC.Tc.Solver (simplifyWantedsTcM)
import GHC.Tc.Utils.Monad
import GHC.Core.Class (classTyCon)
import GHC.Unit.Env
+import GHC.IfaceToCore
-- -----------------------------------------------------------------------------
-- running a statement interactively
@@ -562,12 +563,19 @@ bindLocalsAtBreakpoint hsc_env apStack_fhv (Just BreakInfo{..}) = do
breaks = getModBreaks hmi
info = expectJust "bindLocalsAtBreakpoint2" $
IntMap.lookup breakInfo_number (modBreaks_breakInfo breaks)
- mbVars = cgb_vars info
- result_ty = cgb_resty info
occs = modBreaks_vars breaks ! breakInfo_number
span = modBreaks_locs breaks ! breakInfo_number
decl = intercalate "." $ modBreaks_decls breaks ! breakInfo_number
+ -- Rehydrate to understand the breakpoint info relative to the current environment.
+ -- This design is critical to preventing leaks (#22530)
+ (mbVars, result_ty) <- initIfaceLoad hsc_env
+ $ initIfaceLcl breakInfo_module (text "debugger") NotBoot
+ $ hydrateCgBreakInfo info
+
+
+ let
+
-- Filter out any unboxed ids by changing them to Nothings;
-- we can't bind these at the prompt
mbPointers = nullUnboxed <$> mbVars
=====================================
compiler/GHC/StgToByteCode.hs
=====================================
@@ -89,6 +89,7 @@ import Data.Either ( partitionEithers )
import GHC.Stg.Syntax
import qualified Data.IntSet as IntSet
+import GHC.CoreToIface
-- -----------------------------------------------------------------------------
-- Generating byte code for a complete module
@@ -370,10 +371,8 @@ schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_no fvs) rhs)
this_mod <- moduleName <$> getCurrentModule
platform <- profilePlatform <$> getProfile
let idOffSets = getVarOffSets platform d p fvs
- let breakInfo = CgBreakInfo
- { cgb_vars = idOffSets
- , cgb_resty = tick_ty
- }
+ ty_vars = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs)
+ let breakInfo = dehydrateCgBreakInfo ty_vars idOffSets tick_ty
newBreakInfo tick_no breakInfo
hsc_env <- getHscEnv
let cc | Just interp <- hsc_interp hsc_env
=====================================
compiler/GHC/Types/Name.hs
=====================================
@@ -155,7 +155,7 @@ instance Outputable NameSort where
ppr System = text "system"
instance NFData Name where
- rnf Name{..} = rnf n_sort
+ rnf Name{..} = rnf n_sort `seq` rnf n_occ `seq` n_uniq `seq` rnf n_loc
instance NFData NameSort where
rnf (External m) = rnf m
=====================================
compiler/GHC/Unit/Module/Graph.hs
=====================================
@@ -22,6 +22,7 @@ module GHC.Unit.Module.Graph
, showModMsg
, moduleGraphNodeModule
, moduleGraphNodeModSum
+ , moduleGraphModulesBelow
, moduleGraphNodes
, SummaryNode
@@ -62,12 +63,14 @@ import System.FilePath
import qualified Data.Map as Map
import GHC.Types.Unique.DSet
import qualified Data.Set as Set
+import Data.Set (Set)
import GHC.Unit.Module
import GHC.Linker.Static.Utils
import Data.Bifunctor
import Data.Either
import Data.Function
+import Data.List (sort)
import GHC.Data.List.SetOps
-- | A '@ModuleGraphNode@' is a node in the '@ModuleGraph@'.
@@ -131,8 +134,8 @@ nodeKeyModName :: NodeKey -> Maybe ModuleName
nodeKeyModName (NodeKey_Module mk) = Just (gwib_mod $ mnkModuleName mk)
nodeKeyModName _ = Nothing
-data ModNodeKeyWithUid = ModNodeKeyWithUid { mnkModuleName :: ModuleNameWithIsBoot
- , mnkUnitId :: UnitId } deriving (Eq, Ord)
+data ModNodeKeyWithUid = ModNodeKeyWithUid { mnkModuleName :: !ModuleNameWithIsBoot
+ , mnkUnitId :: !UnitId } deriving (Eq, Ord)
instance Outputable ModNodeKeyWithUid where
ppr (ModNodeKeyWithUid mnwib uid) = ppr uid <> colon <> ppr mnwib
@@ -385,3 +388,30 @@ msKey ms = ModNodeKeyWithUid (ms_mnwib ms) (ms_unitid ms)
type ModNodeKey = ModuleNameWithIsBoot
+
+-- | This function returns all the modules belonging to the home-unit that can
+-- be reached by following the given dependencies. Additionally, if both the
+-- boot module and the non-boot module can be reached, it only returns the
+-- non-boot one.
+moduleGraphModulesBelow :: ModuleGraph -> UnitId -> ModuleNameWithIsBoot -> Set ModNodeKeyWithUid
+moduleGraphModulesBelow mg uid mn = filtered_mods $ [ mn | NodeKey_Module mn <- modules_below]
+ where
+ td_map = mgTransDeps mg
+
+ modules_below = maybe [] Set.toList $ Map.lookup (NodeKey_Module (ModNodeKeyWithUid mn uid)) td_map
+
+ filtered_mods = Set.fromDistinctAscList . filter_mods . sort
+
+ -- IsBoot and NotBoot modules are necessarily consecutive in the sorted list
+ -- (cf Ord instance of GenWithIsBoot). Hence we only have to perform a
+ -- linear sweep with a window of size 2 to remove boot modules for which we
+ -- have the corresponding non-boot.
+ filter_mods = \case
+ (r1@(ModNodeKeyWithUid (GWIB m1 b1) uid1) : r2@(ModNodeKeyWithUid (GWIB m2 _) uid2): rs)
+ | m1 == m2 && uid1 == uid2 ->
+ let !r' = case b1 of
+ NotBoot -> r1
+ IsBoot -> r2
+ in r' : filter_mods rs
+ | otherwise -> r1 : filter_mods (r2:rs)
+ rs -> rs
=====================================
hadrian/cfg/system.config.in
=====================================
@@ -40,6 +40,7 @@ python = @PythonCmd@
#============================
ar-supports-at-file = @ArSupportsAtFile@
+system-ar-supports-at-file = @ArSupportsAtFile_STAGE0@
ar-supports-dash-l = @ArSupportsDashL@
system-ar-supports-dash-l = @ArSupportsDashL_STAGE0@
cc-llvm-backend = @CcLlvmBackend@
=====================================
hadrian/src/Builder.hs
=====================================
@@ -312,8 +312,8 @@ instance H.Builder Builder where
-- see Note [Capture stdout as a ByteString]
writeFileChangedBS output stdout
case builder of
- Ar Pack _ -> do
- useTempFile <- flag ArSupportsAtFile
+ Ar Pack stg -> do
+ useTempFile <- arSupportsAtFile stg
if useTempFile then runAr path buildArgs buildInputs
else runArWithoutTempFile path buildArgs buildInputs
=====================================
hadrian/src/Oracles/Flag.hs
=====================================
@@ -7,7 +7,8 @@ module Oracles.Flag (
targetSupportsThreadedRts,
targetSupportsSMP,
useLibffiForAdjustors,
- arSupportsDashL
+ arSupportsDashL,
+ arSupportsAtFile
) where
import Hadrian.Oracles.TextFile
@@ -18,6 +19,7 @@ import Oracles.Setting
data Flag = ArSupportsAtFile
| ArSupportsDashL
+ | SystemArSupportsAtFile
| SystemArSupportsDashL
| CrossCompiling
| CcLlvmBackend
@@ -48,6 +50,7 @@ flag f = do
let key = case f of
ArSupportsAtFile -> "ar-supports-at-file"
ArSupportsDashL -> "ar-supports-dash-l"
+ SystemArSupportsAtFile-> "system-ar-supports-at-file"
SystemArSupportsDashL-> "system-ar-supports-dash-l"
CrossCompiling -> "cross-compiling"
CcLlvmBackend -> "cc-llvm-backend"
@@ -89,6 +92,10 @@ arSupportsDashL :: Stage -> Action Bool
arSupportsDashL (Stage0 {}) = flag SystemArSupportsDashL
arSupportsDashL _ = flag ArSupportsDashL
+arSupportsAtFile :: Stage -> Action Bool
+arSupportsAtFile (Stage0 {}) = flag SystemArSupportsAtFile
+arSupportsAtFile _ = flag ArSupportsAtFile
+
platformSupportsSharedLibs :: Action Bool
platformSupportsSharedLibs = do
windows <- isWinTarget
=====================================
hadrian/src/Rules/Documentation.hs
=====================================
@@ -12,7 +12,7 @@ import Hadrian.BuildPath
import Hadrian.Haskell.Cabal
import Hadrian.Haskell.Cabal.Type
-import Rules.Generate (ghcPrimDependencies)
+import Rules.Generate (ghcPrimDependencies, generateTemplateResults)
import Base
import Context
import Expression (getContextData, interpretInContext, (?), package)
@@ -68,6 +68,12 @@ pathPath "users_guide" = "docs/users_guide"
pathPath "Haddock" = "utils/haddock/doc"
pathPath _ = ""
+-- Generate files required to build the docs (e.g. ghc.cabal)
+needDocDeps :: Action ()
+needDocDeps = do
+ -- build .cabal files used by the doc engine to list package versions
+ generateTemplateResults
+
-- | Build all documentation
documentationRules :: Rules ()
documentationRules = do
@@ -188,6 +194,9 @@ buildSphinxHtml :: FilePath -> Rules ()
buildSphinxHtml path = do
root <- buildRootRules
root -/- htmlRoot -/- path -/- "index.html" %> \file -> do
+
+ needDocDeps
+
let dest = takeDirectory file
rstFilesDir = pathPath path
rstFiles <- getDirectoryFiles rstFilesDir ["**/*.rst"]
@@ -301,6 +310,9 @@ buildSphinxPdf :: FilePath -> Rules ()
buildSphinxPdf path = do
root <- buildRootRules
root -/- pdfRoot -/- path <.> "pdf" %> \file -> do
+
+ needDocDeps
+
withTempDir $ \dir -> do
let rstFilesDir = pathPath path
rstFiles <- getDirectoryFiles rstFilesDir ["**/*.rst"]
=====================================
hadrian/src/Rules/Generate.hs
=====================================
@@ -2,7 +2,7 @@ module Rules.Generate (
isGeneratedCmmFile, compilerDependencies, generatePackageCode,
generateRules, copyRules, generatedDependencies,
ghcPrimDependencies,
- templateRules
+ templateRules, generateTemplateResults
) where
import qualified Data.Set as Set
@@ -243,7 +243,6 @@ templateResults =
, "driver/ghci/ghci-wrapper.cabal"
, "ghc/ghc-bin.cabal"
, "utils/iserv/iserv.cabal"
- , "utils/iserv-proxy/iserv-proxy.cabal"
, "utils/remote-iserv/remote-iserv.cabal"
, "utils/runghc/runghc.cabal"
, "libraries/ghc-boot/ghc-boot.cabal"
@@ -256,6 +255,10 @@ templateResults =
, "libraries/prologue.txt"
]
+-- | Generate all the files we know we have a template for
+generateTemplateResults :: Action ()
+generateTemplateResults = need templateResults
+
templateRules :: Rules ()
templateRules = do
templateResults |%> \out -> do
=====================================
hadrian/src/Settings/Default.hs
=====================================
@@ -72,7 +72,6 @@ stageBootPackages = return [lintersCommon, lintCommitMsg, lintSubmoduleRefs, lin
stage0Packages :: Action [Package]
stage0Packages = do
cross <- flag CrossCompiling
- winTarget <- isWinTarget
return $ [ binary
, bytestring
, cabalSyntax
@@ -102,7 +101,7 @@ stage0Packages = do
, transformers
, unlit
, hp2ps
- , if winTarget then win32 else unix
+ , if windowsHost then win32 else unix
]
++ [ terminfo | not windowsHost, not cross ]
++ [ timeout | windowsHost ]
@@ -111,7 +110,15 @@ stage0Packages = do
-- | Packages built in 'Stage1' by default. You can change this in "UserSettings".
stage1Packages :: Action [Package]
stage1Packages = do
- libraries0 <- filter isLibrary <$> stage0Packages
+ let good_stage0_package p
+ -- we only keep libraries for some reason
+ | not (isLibrary p) = False
+ -- but not win32/unix because it depends on cross-compilation target
+ | p == win32 = False
+ | p == unix = False
+ | otherwise = True
+
+ libraries0 <- filter good_stage0_package <$> stage0Packages
cross <- flag CrossCompiling
winTarget <- isWinTarget
@@ -138,6 +145,7 @@ stage1Packages = do
, stm
, unlit
, xhtml
+ , if winTarget then win32 else unix
]
, when (not cross)
[ haddock
=====================================
m4/fptools_set_haskell_platform_vars.m4
=====================================
@@ -82,7 +82,7 @@ AC_DEFUN([FPTOOLS_SET_HASKELL_PLATFORM_VARS_SHELL_FUNCTIONS],
solaris2)
test -z "[$]2" || eval "[$]2=OSSolaris2"
;;
- mingw32)
+ mingw32|windows)
test -z "[$]2" || eval "[$]2=OSMinGW32"
;;
freebsd)
=====================================
m4/ghc_convert_os.m4
=====================================
@@ -22,8 +22,11 @@ AC_DEFUN([GHC_CONVERT_OS],[
openbsd*)
$3="openbsd"
;;
+ windows|mingw32)
+ $3="mingw32"
+ ;;
# As far as I'm aware, none of these have relevant variants
- freebsd|dragonfly|hpux|linuxaout|kfreebsdgnu|freebsd2|mingw32|darwin|nextstep2|nextstep3|sunos4|ultrix|haiku)
+ freebsd|dragonfly|hpux|linuxaout|kfreebsdgnu|freebsd2|darwin|nextstep2|nextstep3|sunos4|ultrix|haiku)
$3="$1"
;;
msys)
=====================================
rts/RtsSymbols.c
=====================================
@@ -170,8 +170,6 @@ extern char **environ;
SymI_NeedsProto(__mingw_module_is_dll) \
RTS_WIN32_ONLY(SymI_NeedsProto(___chkstk_ms)) \
RTS_WIN64_ONLY(SymI_NeedsProto(___chkstk_ms)) \
- RTS_WIN64_ONLY(SymI_HasProto(__stdio_common_vswprintf_s)) \
- RTS_WIN64_ONLY(SymI_HasProto(__stdio_common_vswprintf)) \
RTS_WIN64_ONLY(SymI_HasProto(_errno)) \
/* see Note [Symbols for MinGW's printf] */ \
SymI_HasProto(_lock_file) \
=====================================
testsuite/tests/simplCore/should_compile/T22715_2.hs
=====================================
@@ -0,0 +1,6 @@
+module T22715_2 where
+
+import T22715_2a
+
+debugTerminalKeys :: (forall m. CommandMonad m => m Char) -> Input IO Char
+debugTerminalKeys eval = runIdT eval
=====================================
testsuite/tests/simplCore/should_compile/T22715_2a.hs
=====================================
@@ -0,0 +1,29 @@
+{-# OPTIONS_GHC -Wno-missing-methods #-}
+
+module T22715_2a where
+
+newtype IdentityT m a = IdentityT (m a) deriving Functor
+newtype IdT m a = IdT {runIdT :: m a} deriving Functor
+
+class Functor m => SillyA m where
+ unused :: m a -> m a
+
+class SillyA m => SillyB m where
+ unused2 :: m a -> m a
+
+instance SillyA m => SillyA (IdentityT m) where
+instance SillyB m => SillyB (IdentityT m) where
+
+instance SillyA m => SillyA (IdT m) where
+instance SillyB m => SillyB (IdT m) where
+
+instance SillyA IO where
+instance SillyB IO where
+
+class Functor m => Special m
+instance Functor m => Special (IdT m)
+
+type Input m = IdentityT (IdentityT m)
+
+class (Special m, SillyB m) => CommandMonad m
+instance SillyB m => CommandMonad (IdT (Input m))
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -469,4 +469,4 @@ test('T22662', normal, compile, [''])
test('T22725', normal, compile, ['-O'])
test('T22502', normal, compile, ['-O'])
test('T22611', [when(wordsize(32), skip), grep_errmsg(r'\$salterF') ], compile, ['-O -ddump-simpl -dsuppress-uniques -dsuppress-all'])
-
+test('T22715_2', normal, multimod_compile, ['T22715_2', '-v0 -O -fspecialise-aggressively'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fb9630389afbaf408bb3e5027f5966ad9e1defeb...17fda35d98014459385d097e672ab7531d86588e
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fb9630389afbaf408bb3e5027f5966ad9e1defeb...17fda35d98014459385d097e672ab7531d86588e
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/20230126/647d5163/attachment-0001.html>
More information about the ghc-commits
mailing list