[commit: ghc] wip/T14951: Do cascading SpecConstr also for non-recursive bindings (0aa7d87)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/T14951
Link       : http://ghc.haskell.org/trac/ghc/changeset/0aa7d8796a95298e906ea81fe4a52590d75c2e47/ghc

>---------------------------------------------------------------

commit 0aa7d8796a95298e906ea81fe4a52590d75c2e47
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Wed Mar 21 15:29:15 2018 -0400

    Do cascading SpecConstr also for non-recursive bindings
    
    just for the sake of consistency, and clean up the code a bit.


>---------------------------------------------------------------

0aa7d8796a95298e906ea81fe4a52590d75c2e47
 compiler/specialise/SpecConstr.hs | 36 +++++++++++++++++++++---------------
 1 file changed, 21 insertions(+), 15 deletions(-)

diff --git a/compiler/specialise/SpecConstr.hs b/compiler/specialise/SpecConstr.hs
index 44fdf66..ab2490e 100644
--- a/compiler/specialise/SpecConstr.hs
+++ b/compiler/specialise/SpecConstr.hs
@@ -1511,7 +1511,8 @@ specNonRec :: ScEnv
                                                --     plus details of specialisations
 
 specNonRec env body_usg rhs_info
-  = specialise env (scu_calls body_usg) rhs_info
+  = addPatUsages env (scu_calls body_usg) <$>
+    specialise env (scu_calls body_usg) rhs_info
                (noSpecInfo { si_mb_unspec = Just (ri_rhs_usg rhs_info) })
 
 ----------------------
@@ -1522,22 +1523,9 @@ specRec :: TopLevelFlag -> ScEnv
                                            --     plus details of specialisations
 
 specRec top_lvl env body_usg rhs_infos
-  = add_pat_usages <$>
+  = addPatUsagess env (scu_calls body_usg) <$>
     go 1 seed_calls nullUsage init_spec_infos
   where
-    -- Calculate the stronger demand on all all arguments to fn that
-    -- is useful once we have this specialization
-    add_pat_usages (usg, spec_infos) = (usg `combineUsage` extra_usages, spec_infos)
-      where extra_usages = combineUsages
-                [ patToCallUsage env call_pat call
-                | si <- spec_infos
-                , os <- si_specs si
-                , let fn  = os_orig_id os
-                      call_pat = os_pat os
-                , pprTrace "add_pat_usages" (ppr fn <+> ppr call_pat)  True
-                , call <- fromMaybe [] $ lookupVarEnv all_calls fn
-                ]
-
     (seed_calls, init_spec_infos)    -- Note [Seeding top-level recursive groups]
        | isTopLevel top_lvl
        , any (isExportedId . ri_fn) rhs_infos   -- Seed from body and RHSs
@@ -1761,6 +1749,24 @@ spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number)
                                , os_rhs = spec_rhs }) }
 
 -- See Note [ArgOcc from calls to specialized functions]
+addPatUsagess :: ScEnv -> CallEnv -> (ScUsage, [SpecInfo]) -> (ScUsage, [SpecInfo])
+addPatUsagess env body_calls (usg, spec_infos) = (usg `combineUsage` extra_usages, spec_infos)
+  where extra_usages = combineUsages [ extraPatUsages env body_calls si | si <- spec_infos ]
+
+addPatUsages :: ScEnv -> CallEnv -> (ScUsage, SpecInfo) -> (ScUsage, SpecInfo)
+addPatUsages env body_calls (usg, spec_info) = (usg `combineUsage` extra_usage, spec_info)
+  where extra_usage = extraPatUsages env body_calls spec_info
+
+extraPatUsages :: ScEnv -> CallEnv -> SpecInfo -> ScUsage
+extraPatUsages env body_calls si  = combineUsages
+    [ patToCallUsage env call_pat call
+    | os <- si_specs si
+    , let fn  = os_orig_id os
+          call_pat = os_pat os
+    , pprTrace "add_pat_usages" (ppr fn <+> ppr call_pat)  True
+    , call <- fromMaybe [] $ lookupVarEnv body_calls fn
+    ]
+
 patToCallUsage :: ScEnv -> CallPat -> Call -> ScUsage
 patToCallUsage env (_qvars, pats) (Call _ args _)
     = pprTrace "patToCallUsage" (ppr pats <+> ppr args <+> ppr usage) $