[Git][ghc/ghc][wip/spj-unf-size] Wibbles

[Simon Peyton Jones (@simonpj)]

Simon Peyton Jones pushed to branch wip/spj-unf-size at Glasgow Haskell Compiler / GHC


Commits:
f433129d by Simon Peyton Jones at 2023-10-23T10:05:11+01:00
Wibbles

- - - - -


2 changed files:

- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Unfold.hs


Changes:

=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -660,9 +660,7 @@ tryCastWorkerWrapper env bind_cxt old_bndr occ_info bndr (Cast rhs co)
            _ -> mkLetUnfolding uf_opts top_lvl VanillaSrc work_id work_rhs
 
 tryCastWorkerWrapper env _ _ _ bndr rhs  -- All other bindings
-  = do { traceSmpl "tcww:no" (vcat [ text "bndr:" <+> ppr bndr
-                                   , text "rhs:" <+> ppr rhs ])
-        ; return (mkFloatBind env (NonRec bndr rhs)) }
+  = return (mkFloatBind env (NonRec bndr rhs))
 
 mkCastWrapperInlinePrag :: InlinePragma -> InlinePragma
 -- See Note [Cast worker/wrapper]
@@ -952,7 +950,6 @@ completeBind env bind_cxt old_bndr new_bndr new_rhs
         -- See Note [In-scope set as a substitution]
 
       ; if postInlineUnconditionally env bind_cxt new_bndr_w_info occ_info eta_rhs
-
         then -- Inline and discard the binding
              do  { tick (PostInlineUnconditionally old_bndr)
                  ; let unf_rhs = maybeUnfoldingTemplate new_unfolding `orElse` eta_rhs
@@ -3219,10 +3216,9 @@ simplAlts :: SimplEnv
           -> SimplM OutExpr  -- Returns the complete simplified case expression
 
 simplAlts env0 scrut case_bndr alts cont'
-  = do  { traceSmpl "simplAlts" (vcat [ ppr case_bndr
-                                      , text "cont':" <+> ppr cont'
-                                      , text "in_scope" <+> ppr (seInScope env0) ])
-        ; (env1, case_bndr1) <- simplBinder env0 case_bndr
+  = do  { (env1, case_bndr1) <- simplBinder env0 case_bndr
+        ; traceSmpl "simplAlts" (vcat [ ppr case_bndr <+> ppr case_bndr1
+                                      , text "cont':" <+> ppr cont' ])
         ; let case_bndr2 = case_bndr1 `setIdUnfolding` evaldUnfolding
               env2       = modifyInScope env1 case_bndr2
               -- See Note [Case binder evaluated-ness]


=====================================
compiler/GHC/Core/Unfold.hs
=====================================
@@ -1089,19 +1089,19 @@ caseTreeSize ic (ScrutOf bndr disc)
 
 caseTreeSize ic (CaseOf scrut_var case_bndr alts)
   = case lookupBndr ic scrut_var of
-      ArgNoInfo     -> keptCaseSize ic alts
-      ArgIsLam      -> keptCaseSize ic alts
-      ArgIsNot cons -> keptCaseSize ic (trim_alts cons alts)
+      ArgNoInfo     -> keptCaseSize ic case_bndr alts
+      ArgIsLam      -> keptCaseSize ic case_bndr alts
+      ArgIsNot cons -> keptCaseSize ic case_bndr (trim_alts cons alts)
       arg_summ@(ArgIsCon con args)
-         | Just (AltTree _ bs rhs) <- find_alt con alts
+         | Just (AltTree _ bndrs rhs) <- find_alt con alts
          , let new_summaries :: [(Var,ArgSummary)]
-               new_summaries = (case_bndr,arg_summ) : bs `zip` args
+               new_summaries = (case_bndr,arg_summ) : bndrs `zip` args
                   -- Don't forget to add a summary for the case binder!
                ic' = ic { ic_bound = ic_bound ic `extendVarEnvList` new_summaries }
                      -- In DEFAULT case, bs is empty, so extending is a no-op
          -> exprTreeSize ic' rhs
          | otherwise  -- Happens for empty alternatives
-         -> keptCaseSize ic alts
+         -> keptCaseSize ic case_bndr alts
 
 find_alt :: AltCon -> [AltTree] -> Maybe AltTree
 find_alt _   []                     = Nothing
@@ -1120,16 +1120,22 @@ trim_alts acs (alt:alts)
   | AltTree con _ _ <- alt, con `elem` acs = trim_alts acs alts
   | otherwise                              = alt : trim_alts acs alts
 
-keptCaseSize :: InlineContext -> [AltTree] -> Size
+keptCaseSize :: InlineContext -> Id -> [AltTree] -> Size
 -- Size of a (retained) case expression
-keptCaseSize ic alts
+keptCaseSize ic case_bndr alts
   = foldr (addSize . size_alt) (sizeN 0) alts
     -- We make the case itself free, but charge for each alternative
     -- If there are no alternatives (case e of {}), we get just the size of the scrutinee
   where
     size_alt :: AltTree -> Size
-    size_alt (AltTree _ _ rhs) = exprTreeSize ic rhs
+    size_alt (AltTree _ bndrs rhs) = exprTreeSize ic' rhs
         -- Cost for the alternative is already in `rhs`
+      where
+        -- Must extend ic_bound, lest a captured variable is
+        -- looked up in ic_free by lookupBndr
+        new_summaries :: [(Var,ArgSummary)]
+        new_summaries = [(b,ArgNoInfo) | b <- case_bndr:bndrs]
+        ic' = ic { ic_bound = ic_bound ic `extendVarEnvList` new_summaries }
 
 lookupBndr :: HasDebugCallStack => InlineContext -> Id -> ArgSummary
 lookupBndr (IC { ic_bound = bound_env, ic_free = lookup_free }) var



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f433129ddb8e7597d6944c023f8152b141ee8210
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/20231023/d55d60dc/attachment-0001.html>