[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 2 commits: Remove RTS hack for configuring

Marge Bot (@marge-bot) gitlab at gitlab.haskell.org
Mon Jan 9 19:39:26 UTC 2023



Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC


Commits:
111caae0 by John Ericson at 2023-01-09T14:39:19-05:00
Remove RTS hack for configuring

See the brand new Note [Undefined symbols in the RTS] for additional
details.

- - - - -
b474a7c7 by Sebastian Graf at 2023-01-09T14:39:19-05:00
Handle shadowing in DmdAnal (#22718)

Previously, when we had a shadowing situation like
```hs
f x = ... -- demand signature <1L><1L>

main = ... \f -> f 1 ...
```
we'd happily use the shadowed demand signature at the call site inside the
lambda. Of course, that's wrong and solution is simply to remove the demand
signature from the `AnalEnv` when we enter the lambda.
This patch does so for all binding constructs Core.

In #22718 the issue was caused by LetUp not shadowing away the existing demand
signature for the let binder in the let body. The resulting absent error is
fickle to reproduce; hence no reproduction test case. #17478 would help.

Fixes #22718.

It appears that TcPlugin_Rewrite regresses by ~40% on Darwin. It is likely that
DmdAnal was exploiting ill-scoped analysis results.

Metric increase ['bytes allocated'] (test_env=x86_64-darwin-validate):
    TcPlugin_Rewrite

- - - - -


4 changed files:

- compiler/GHC/Core/Opt/DmdAnal.hs
- hadrian/src/Hadrian/Haskell/Cabal/Parse.hs
- hadrian/src/Rules/Register.hs
- rts/rts.cabal.in


Changes:

=====================================
compiler/GHC/Core/Opt/DmdAnal.hs
=====================================
@@ -333,7 +333,8 @@ dmdAnalBindLetUp :: TopLevelFlag
                  -> WithDmdType (DmdResult CoreBind a)
 dmdAnalBindLetUp top_lvl env id rhs anal_body = WithDmdType final_ty (R (NonRec id' rhs') (body'))
   where
-    WithDmdType body_ty body'   = anal_body env
+    WithDmdType body_ty body'   = anal_body (addInScopeAnalEnv env id)
+    -- See Note [Bringing a new variable into scope]
     WithDmdType body_ty' id_dmd = findBndrDmd env body_ty id
     -- See Note [Finalising boxity for demand signatures]
 
@@ -473,7 +474,8 @@ dmdAnal' env dmd (App fun arg)
 dmdAnal' env dmd (Lam var body)
   | isTyVar var
   = let
-        WithDmdType body_ty body' = dmdAnal env dmd body
+        WithDmdType body_ty body' = dmdAnal (addInScopeAnalEnv env var) dmd body
+        -- See Note [Bringing a new variable into scope]
     in
     WithDmdType body_ty (Lam var body')
 
@@ -481,7 +483,8 @@ dmdAnal' env dmd (Lam var body)
   = let (n, body_dmd)    = peelCallDmd dmd
           -- body_dmd: a demand to analyze the body
 
-        WithDmdType body_ty body' = dmdAnal env body_dmd body
+        WithDmdType body_ty body' = dmdAnal (addInScopeAnalEnv env var) body_dmd body
+        -- See Note [Bringing a new variable into scope]
         WithDmdType lam_ty var'   = annotateLamIdBndr env body_ty var
         new_dmd_type = multDmdType n lam_ty
     in
@@ -493,7 +496,9 @@ dmdAnal' env dmd (Case scrut case_bndr ty [Alt alt_con bndrs rhs])
   -- can consider its field demands when analysing the scrutinee.
   | want_precise_field_dmds alt_con
   = let
-        WithDmdType rhs_ty rhs'           = dmdAnal env dmd rhs
+        rhs_env = addInScopeAnalEnvs env (case_bndr:bndrs)
+        -- See Note [Bringing a new variable into scope]
+        WithDmdType rhs_ty rhs'           = dmdAnal rhs_env dmd rhs
         WithDmdType alt_ty1 fld_dmds      = findBndrsDmds env rhs_ty bndrs
         WithDmdType alt_ty2 case_bndr_dmd = findBndrDmd env alt_ty1 case_bndr
         !case_bndr'                       = setIdDemandInfo case_bndr case_bndr_dmd
@@ -629,7 +634,9 @@ dmdAnalSumAlts env dmd case_bndr (alt:alts)
 
 dmdAnalSumAlt :: AnalEnv -> SubDemand -> Id -> CoreAlt -> WithDmdType CoreAlt
 dmdAnalSumAlt env dmd case_bndr (Alt con bndrs rhs)
-  | WithDmdType rhs_ty rhs' <- dmdAnal env dmd rhs
+  | let rhs_env = addInScopeAnalEnvs env (case_bndr:bndrs)
+    -- See Note [Bringing a new variable into scope]
+  , WithDmdType rhs_ty rhs' <- dmdAnal rhs_env dmd rhs
   , WithDmdType alt_ty dmds <- findBndrsDmds env rhs_ty bndrs
   , let (_ :* case_bndr_sd) = findIdDemand alt_ty case_bndr
         -- See Note [Demand on case-alternative binders]
@@ -2399,7 +2406,7 @@ enterDFun bind env
 emptySigEnv :: SigEnv
 emptySigEnv = emptyVarEnv
 
--- | Extend an environment with the strictness IDs attached to the id
+-- | Extend an environment with the strictness sigs attached to the Ids
 extendAnalEnvs :: TopLevelFlag -> AnalEnv -> [Id] -> AnalEnv
 extendAnalEnvs top_lvl env vars
   = env { ae_sigs = extendSigEnvs top_lvl (ae_sigs env) vars }
@@ -2418,6 +2425,12 @@ extendSigEnv top_lvl sigs var sig = extendVarEnv sigs var (sig, top_lvl)
 lookupSigEnv :: AnalEnv -> Id -> Maybe (DmdSig, TopLevelFlag)
 lookupSigEnv env id = lookupVarEnv (ae_sigs env) id
 
+addInScopeAnalEnv :: AnalEnv -> Var -> AnalEnv
+addInScopeAnalEnv env id = env { ae_sigs = delVarEnv (ae_sigs env) id }
+
+addInScopeAnalEnvs :: AnalEnv -> [Var] -> AnalEnv
+addInScopeAnalEnvs env ids = env { ae_sigs = delVarEnvList (ae_sigs env) ids }
+
 nonVirgin :: AnalEnv -> AnalEnv
 nonVirgin env = env { ae_virgin = False }
 
@@ -2456,7 +2469,18 @@ findBndrDmd env dmd_ty id
 
     fam_envs = ae_fam_envs env
 
-{- Note [Making dictionary parameters strict]
+{- Note [Bringing a new variable into scope]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+   f x = blah
+   g = ...(\f. ...f...)...
+
+In the body of the '\f', any occurrence of `f` refers to the lambda-bound `f`,
+not the top-level `f` (which will be in `ae_sigs`).  So it's very important
+to delete `f` from `ae_sigs` when we pass a lambda/case/let-up binding of `f`.
+Otherwise chaos results (#22718).
+
+Note [Making dictionary parameters strict]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 The Opt_DictsStrict flag makes GHC use call-by-value for dictionaries.  Why?
 


=====================================
hadrian/src/Hadrian/Haskell/Cabal/Parse.hs
=====================================
@@ -148,6 +148,8 @@ configurePackage context at Context {..} = do
     -- Figure out what hooks we need.
     hooks <- case C.buildType (C.flattenPackageDescription gpd) of
         C.Configure -> pure C.autoconfUserHooks
+        C.Simple -> pure C.simpleUserHooks
+        C.Make -> fail "build-type: Make is not supported"
         -- The 'time' package has a 'C.Custom' Setup.hs, but it's actually
         -- 'C.Configure' plus a @./Setup test@ hook. However, Cabal is also
         -- 'C.Custom', but doesn't have a configure script.
@@ -155,12 +157,6 @@ configurePackage context at Context {..} = do
             configureExists <- doesFileExist $
                 replaceFileName (pkgCabalFile package) "configure"
             pure $ if configureExists then C.autoconfUserHooks else C.simpleUserHooks
-        -- Not quite right, but good enough for us:
-        _ | package == rts ->
-            -- Don't try to do post configuration validation for 'rts'. This
-            -- will simply not work, due to the @ld-options@ and @Stg.h at .
-            pure $ C.simpleUserHooks { C.postConf = \_ _ _ _ -> return () }
-          | otherwise -> pure C.simpleUserHooks
 
     -- Compute the list of flags, and the Cabal configuration arguments
     flavourArgs <- args <$> flavour


=====================================
hadrian/src/Rules/Register.hs
=====================================
@@ -45,6 +45,14 @@ configurePackageRules = do
           isGmp <- (== "gmp") <$> interpretInContext ctx getBignumBackend
           when isGmp $
             need [buildP -/- "include/ghc-gmp.h"]
+        when (pkg == rts) $ do
+          -- Rts.h is a header listed in the cabal file, and configuring
+          -- therefore wants to ensure that the header "works" post-configure.
+          -- But it (transitively) includes these, so we must ensure they exist
+          -- for that check to work.
+          need [ buildP -/- "include/ghcautoconf.h"
+               , buildP -/- "include/ghcplatform.h"
+               ]
         Cabal.configurePackage ctx
 
     root -/- "**/autogen/cabal_macros.h" %> \out -> do


=====================================
rts/rts.cabal.in
=====================================
@@ -275,6 +275,8 @@ library
                         stg/SMP.h
                         stg/Ticky.h
                         stg/Types.h
+
+      -- See Note [Undefined symbols in the RTS]
       if flag(64bit)
         if flag(leading-underscore)
           ld-options:
@@ -474,6 +476,8 @@ library
         ld-options: "-Wl,-search_paths_first"
                     -- See Note [fd_set_overflow]
                     "-Wl,-U,___darwin_check_fd_set_overflow"
+                    -- See Note [Undefined symbols in the RTS]
+                    "-Wl,-undefined,dynamic_lookup"
         if !arch(x86_64) && !arch(aarch64)
            ld-options: -read_only_relocs warning
 
@@ -714,3 +718,35 @@ library
 --     , https://github.com/sitsofe/fio/commit/b6a1e63a1ff607692a3caf3c2db2c3d575ba2320
 
 -- The issue was originally reported in #19950
+
+
+-- Note [Undefined symbols in the RTS]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- The RTS is built with a number of `-u` flags. This is to handle cyclic
+-- dependencies between the RTS and other libraries which we normally think of as
+-- downstream from the RTS. "Regular" dependencies from usages in those libraries
+-- to definitions in the RTS are handled normally. "Reverse" dependencies from
+-- usages in the RTS to definitions in those libraries get the `-u` flag in the
+-- RTS.
+--
+-- The symbols are specified literally, but follow C ABI conventions (as all 3 of
+-- C, C--, and Haskell do currently). Thus, we have to be careful to include a
+-- leading underscore or not based on those conventions for the given platform in
+-- question.
+--
+-- A tricky part is that different linkers have different policies regarding
+-- undefined symbols (not defined in the current binary, or found in a shared
+-- library that could be loaded at run time). GNU Binutils' linker is fine with
+-- undefined symbols by default, but Apple's "cctools" linker is not. To appease
+-- that linker we either need to do a blanket `-undefined dynamic_lookup` or
+-- whitelist each such symbol with an additional `-U` (see the man page for more
+-- details).
+--
+-- GHC already does `-undefined dynamic_lookup`, so we just do that for now, but
+-- we might try to get more precise with `-U` in the future.
+--
+-- Note that the RTS also `-u`s some atomics symbols that *are* defined --- and
+-- defined within the RTS! It is not immediately clear why this is needed. This
+-- dates back to c06e3f46d24ef69f3a3d794f5f604cb8c2a40cbc which mentions a build
+-- failure that it was suggested that this fix, but the precise reasoning is not
+-- explained.



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/965a273510adfac4f041a31182c2fec82e614e47...b474a7c7229ad846e492920aeecf1970180daa63

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/965a273510adfac4f041a31182c2fec82e614e47...b474a7c7229ad846e492920aeecf1970180daa63
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/20230109/39e382da/attachment-0001.html>


More information about the ghc-commits mailing list