[Git][ghc/ghc][wip/T18894] Unleash exported bindings later

[Sebastian Graf]

Sebastian Graf pushed to branch wip/T18894 at Glasgow Haskell Compiler / GHC


Commits:
0f02b2d9 by Sebastian Graf at 2020-11-25T16:02:13+01:00
Unleash exported bindings later

- - - - -


3 changed files:

- compiler/GHC/Core/FVs.hs
- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/Core/Opt/WorkWrap/Utils.hs


Changes:

=====================================
compiler/GHC/Core/FVs.hs
=====================================
@@ -525,12 +525,11 @@ ruleLhsFVIds (Rule { ru_bndrs = bndrs, ru_args = args })
   = filterFV isLocalId $ addBndrs bndrs (exprs_fvs args)
 
 ruleRhsFreeIds :: CoreRule -> VarSet
--- ^ This finds all locally-defined free Ids on the left hand side of a rule
+-- ^ This finds all locally-defined free Ids on the right hand side of a rule
 -- and returns them as a non-deterministic set
 ruleRhsFreeIds (BuiltinRule {}) = emptyVarSet
-ruleRhsFreeIds (Rule { ru_bndrs = bndrs, ru_args = args })
-  = fvVarSet $ filterFV isLocalId $
-     addBndrs bndrs $ exprs_fvs args
+ruleRhsFreeIds (Rule { ru_bndrs = bndrs, ru_rhs = rhs })
+  = fvVarSet $ filterFV isLocalId $ addBndrs bndrs $ expr_fvs rhs
 
 {-
 Note [Rule free var hack]  (Not a hack any more)


=====================================
compiler/GHC/Core/Opt/DmdAnal.hs
=====================================
@@ -66,42 +66,43 @@ data DmdAnalOpts = DmdAnalOpts
 -- Note: use `seqBinds` on the result to avoid leaks due to lazyness (cf Note
 -- [Stamp out space leaks in demand analysis])
 dmdAnalProgram :: DmdAnalOpts -> FamInstEnvs -> [CoreRule] -> CoreProgram -> CoreProgram
-dmdAnalProgram opts fam_envs rules binds = binds_plus_dmds
+dmdAnalProgram opts fam_envs rules binds = snd $ go (emptyAnalEnv opts fam_envs) binds
    where
-      env             = emptyAnalEnv opts fam_envs
-      rule_fvs        = foldr (unionVarSet . ruleRhsFreeIds) emptyVarSet rules
-      binds_plus_dmds = snd $ go env nopDmdType binds
-
-      go _   dmd_ty []     = (dmd_ty, [])
-      go env dmd_ty (b:bs) = case b of
+      go _   []     = (nopDmdType, [])
+      go env (b:bs) = case b of
         NonRec id rhs
           | (env', lazy_fvs, id', rhs') <- dmdAnalRhsLetDown TopLevel NonRecursive env topSubDmd id rhs
-          , (dmd_ty', bs') <- go env' (add_exported_use env' dmd_ty id') bs
-          , (dmd_ty'', id_dmd) <- findBndrDmd env' False (dmd_ty' `addLazyFVs` lazy_fvs) id'
+          , (dmd_ty', bs') <- go env' bs
+          , let !dmd_ty'' = add_exported_use env' dmd_ty' id' `addLazyFVs` lazy_fvs
+          , (dmd_ty''', id_dmd) <- findBndrDmd env' False dmd_ty'' id'
           , let id'' = annotate_id_dmd id' id_dmd
-          -> (dmd_ty'', NonRec id'' rhs' : bs')
+          -> (dmd_ty''', NonRec id'' rhs' : bs')
         Rec pairs
           | (env', lazy_fvs, pairs') <- dmdFix TopLevel env topSubDmd pairs
           , let ids' = map fst pairs'
-          , (dmd_ty', bs') <- go env' (add_exported_uses env' dmd_ty ids') bs
-          , (dmd_ty'', id_dmds) <- findBndrsDmds env' (dmd_ty' `addLazyFVs` lazy_fvs) ids'
+          , (dmd_ty', bs') <- go env' bs
+          , let !dmd_ty'' = add_exported_uses env' dmd_ty' ids' `addLazyFVs` lazy_fvs
+          , (dmd_ty''', id_dmds) <- findBndrsDmds env' dmd_ty'' ids'
           , let ids'' = zipWith annotate_id_dmd ids' id_dmds
           , let pairs'' = zipWith (\id'' (_, rhs') -> (id'', rhs')) ids'' pairs'
-          -> (dmd_ty'', Rec pairs'' : bs')
+          -> (dmd_ty''', Rec pairs'' : bs')
 
       annotate_id_dmd id dmd
-        | isInterestingTopLevelFn id, not (id `elemVarSet` rule_fvs)
-        -- See Note [Absence analysis for stable unfoldings and RULES]
+        | isInterestingTopLevelFn id
         = id `setIdDemandInfo` dmd
         | otherwise
         = id `setIdDemandInfo` topDmd
 
       add_exported_uses env = foldl' (add_exported_use env)
       add_exported_use env dmd_ty id
-        | isExportedId id || not (isInterestingTopLevelFn id)
+        | isExportedId id || elemVarSet id rule_fvs
+        -- See Note [Absence analysis for stable unfoldings and RULES]
         = dmd_ty `plusDmdType` fst (dmdAnalStar env topDmd (Var id))
         | otherwise       = dmd_ty
 
+      rule_fvs = foldr (unionVarSet . ruleRhsFreeIds) emptyVarSet rules
+
+
 {- Note [Stamp out space leaks in demand analysis]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 The demand analysis pass outputs a new copy of the Core program in


=====================================
compiler/GHC/Core/Opt/WorkWrap/Utils.hs
=====================================
@@ -1275,10 +1275,14 @@ mk_absent_let dflags fam_envs arg
 
     abs_rhs      = mkAbsentErrorApp arg_ty msg
     msg          = showSDoc (gopt_set dflags Opt_SuppressUniques)
-                            (ppr arg <+> ppr (idType arg) <+> file_msg)
+                            (vcat
+                              [ text "Arg:" <+> ppr arg
+                              , text "Type:" <+> ppr arg_ty
+                              , file_msg
+                              ])
     file_msg     = case outputFile dflags of
                      Nothing -> empty
-                     Just f  -> text "in output file " <+> quotes (text f)
+                     Just f  -> text "In output file " <+> quotes (text f)
               -- We need to suppress uniques here because otherwise they'd
               -- end up in the generated code as strings. This is bad for
               -- determinism, because with different uniques the strings



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0f02b2d94bf24ba0bd45d2b6dcd529bfba9c0d50

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0f02b2d94bf24ba0bd45d2b6dcd529bfba9c0d50
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/20201125/1ada22f8/attachment-0001.html>