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

[Sebastian Graf]

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


Commits:
7e4a746b by Sebastian Graf at 2020-11-24T21:34:11+01:00
Unleash exported bindings later

- - - - -


1 changed file:

- compiler/GHC/Core/Opt/DmdAnal.hs


Changes:

=====================================
compiler/GHC/Core/Opt/DmdAnal.hs
=====================================
@@ -70,24 +70,26 @@ dmdAnalProgram opts fam_envs rules binds = binds_plus_dmds
    where
       env             = emptyAnalEnv opts fam_envs
       rule_fvs        = foldr (unionVarSet . ruleRhsFreeIds) emptyVarSet rules
-      binds_plus_dmds = snd $ go env nopDmdType binds
+      binds_plus_dmds = snd $ go env 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)
@@ -98,7 +100,7 @@ dmdAnalProgram opts fam_envs rules binds = binds_plus_dmds
 
       add_exported_uses env = foldl' (add_exported_use env)
       add_exported_use env dmd_ty id
-        | isExportedId id || not (isInterestingTopLevelFn id)
+        | isExportedId id
         = dmd_ty `plusDmdType` fst (dmdAnalStar env topDmd (Var id))
         | otherwise       = dmd_ty
 



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7e4a746b507f973f56f4a5a012fdf6ee60978725

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7e4a746b507f973f56f4a5a012fdf6ee60978725
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/20201124/0df2138d/attachment-0001.html>