[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