summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSimon Peyton Jones <simonpj@microsoft.com>2014-05-05 08:50:51 +0100
committerAustin Seipp <austin@well-typed.com>2014-11-03 07:40:54 -0600
commitfcece34760929d79dea3e9871462cb927f60aa5c (patch)
tree61093bcf35e3791235f64555913d739d8f59ac9d
parentd71f316ef4acb6a967a1f07bc4c1144e553a3ac9 (diff)
downloadhaskell-fcece34760929d79dea3e9871462cb927f60aa5c.tar.gz
Improve comments and tracing in SpecConstr
(cherry picked from commit 675c5478793ac8cede5daca4f70cd09846879837)
-rw-r--r--compiler/specialise/SpecConstr.lhs53
1 files changed, 31 insertions, 22 deletions
diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs
index 060c705cda..faedb94413 100644
--- a/compiler/specialise/SpecConstr.lhs
+++ b/compiler/specialise/SpecConstr.lhs
@@ -396,16 +396,19 @@ use the calls in the un-specialised RHS as seeds. We call these
Note [Top-level recursive groups]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If all the bindings in a top-level recursive group are not exported,
-all the calls are in the rest of the top-level bindings.
-This means we can specialise with those call patterns instead of with the RHSs
-of the recursive group.
+If all the bindings in a top-level recursive group are local (not
+exported), then all the calls are in the rest of the top-level
+bindings. This means we can specialise with those call patterns
+instead of with the RHSs of the recursive group.
-To get the call usage information, we work backwards through the top-level bindings
-so we see the usage before we get to the binding of the function.
-Before we can collect the usage though, we go through all the bindings and add them
-to the environment. This is necessary because usage is only tracked for functions
-in the environment.
+(Question: maybe we should *also* use calls in the rest of the
+top-level bindings as seeds?
+
+To get the call usage information, we work backwards through the
+top-level bindings so we see the usage before we get to the binding of
+the function. Before we can collect the usage though, we go through
+all the bindings and add them to the environment. This is necessary
+because usage is only tracked for functions in the environment.
The actual seeding of the specialisation is very similar to Note [Local recursive group].
@@ -1323,16 +1326,14 @@ scTopBind env usage (Rec prs)
= do { (rhs_usgs, rhss') <- mapAndUnzipM (scExpr env) rhss
; return (usage `combineUsage` (combineUsages rhs_usgs), Rec (bndrs `zip` rhss')) }
| otherwise -- Do specialisation
- = do { (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs env) (bndrs `zip` rhss)
+ = do { (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs env) prs
-- ; pprTrace "scTopBind" (ppr bndrs $$ ppr (map (lookupVarEnv (scu_calls usage)) bndrs)) (return ())
-- Note [Top-level recursive groups]
- ; let (usg,rest) = if all (not . isExportedId) bndrs
- then -- pprTrace "scTopBind-T" (ppr bndrs $$ ppr (map (fmap (map snd) . lookupVarEnv (scu_calls usage)) bndrs))
- ( usage
- , [SI [] 0 (Just us) | us <- rhs_usgs] )
- else ( combineUsages rhs_usgs
- , [SI [] 0 Nothing | _ <- rhs_usgs] )
+ ; let (usg,rest) | any isExportedId bndrs -- Seed from RHSs
+ = ( combineUsages rhs_usgs, [SI [] 0 Nothing | _ <- rhs_usgs] )
+ | otherwise -- Seed from body only
+ = ( usage, [SI [] 0 (Just us) | us <- rhs_usgs] )
; (usage', specs) <- specLoop (scForce env force_spec)
(scu_calls usg) rhs_infos nullUsage rest
@@ -1446,11 +1447,6 @@ specialise env bind_calls (RI fn _ arg_bndrs body arg_occs)
, notNull arg_bndrs -- Only specialise functions
, Just all_calls <- lookupVarEnv bind_calls fn
= do { (boring_call, pats) <- callsToPats env specs arg_occs all_calls
--- ; pprTrace "specialise" (vcat [ ppr fn <+> text "with" <+> int (length pats) <+> text "good patterns"
--- , text "arg_occs" <+> ppr arg_occs
--- , text "calls" <+> ppr all_calls
--- , text "good pats" <+> ppr pats]) $
--- return ()
-- Bale out if too many specialisations
; let n_pats = length pats
@@ -1473,12 +1469,25 @@ specialise env bind_calls (RI fn _ arg_bndrs body arg_occs)
_normal_case -> do {
- let spec_env = decreaseSpecCount env n_pats
+-- ; if (not (null pats) || isJust mb_unspec) then
+-- pprTrace "specialise" (vcat [ ppr fn <+> text "with" <+> int (length pats) <+> text "good patterns"
+-- , text "mb_unspec" <+> ppr (isJust mb_unspec)
+-- , text "arg_occs" <+> ppr arg_occs
+-- , text "good pats" <+> ppr pats]) $
+-- return ()
+-- else return ()
+
+ ; let spec_env = decreaseSpecCount env n_pats
; (spec_usgs, new_specs) <- mapAndUnzipM (spec_one spec_env fn arg_bndrs body)
(pats `zip` [spec_count..])
-- See Note [Specialise original body]
; let spec_usg = combineUsages spec_usgs
+
+ -- If there were any boring calls among the seeds (= all_calls), then those
+ -- calls will call the un-specialised function. So we should use the seeds
+ -- from the _unspecialised_ function's RHS, which are in mb_unspec, by returning
+ -- then in new_usg.
(new_usg, mb_unspec')
= case mb_unspec of
Just rhs_usg | boring_call -> (spec_usg `combineUsage` rhs_usg, Nothing)