[Git][ghc/ghc][wip/marge_bot_batch_merge_job] OccurAnal: Avoid exponential behavior due to where clauses

[Ben Gamari]

Ben Gamari pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC


Commits:
f1bfb806 by Ben Gamari at 2020-06-07T10:49:30-04:00
OccurAnal: Avoid exponential behavior due to where clauses

Previously the `Var` case of `occAnalApp` could in some cases (namely
in the case of `runRW#` applications) call `occAnalRhs` two. In the case
of nested `runRW#`s this results in exponential complexity. In some
cases the compilation time that resulted would be very long indeed
(see #18296).

Fixes #18296.

Metric Decrease:
    T9961
    T12150
    T12234

- - - - -


1 changed file:

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


Changes:

=====================================
compiler/GHC/Core/Opt/OccurAnal.hs
=====================================
@@ -1568,16 +1568,17 @@ occAnalRhs :: OccEnv -> Maybe JoinArity
            -> CoreExpr   -- RHS
            -> (UsageDetails, CoreExpr)
 occAnalRhs env mb_join_arity rhs
-  = (rhs_usage, rhs')
+  = case occAnalLamOrRhs env bndrs body of { (body_usage, bndrs', body') ->
+    let rhs' = mkLams (markJoinOneShots mb_join_arity bndrs') body'
+               -- For a /non-recursive/ join point we can mark all
+               -- its join-lambda as one-shot; and it's a good idea to do so
+
+        -- Final adjustment
+        rhs_usage = adjustRhsUsage mb_join_arity NonRecursive bndrs' body_usage
+
+    in (rhs_usage, rhs') }
   where
     (bndrs, body) = collectBinders rhs
-    (body_usage, bndrs', body') = occAnalLamOrRhs env bndrs body
-    rhs' = mkLams (markJoinOneShots mb_join_arity bndrs') body'
-           -- For a /non-recursive/ join point we can mark all
-           -- its join-lambda as one-shot; and it's a good idea to do so
-
-    -- Final adjustment
-    rhs_usage = adjustRhsUsage mb_join_arity NonRecursive bndrs' body_usage
 
 occAnalUnfolding :: OccEnv
                  -> Maybe JoinArity   -- See Note [Join points and unfoldings/rules]
@@ -1885,12 +1886,18 @@ occAnalApp :: OccEnv
 occAnalApp env (Var fun, args, ticks)
   -- Account for join arity of runRW# continuation
   -- See Note [Simplification of runRW#]
+  --
+  -- NB: Do not be tempted to make the next (Var fun, args, tick)
+  --     equation into an 'otherwise' clause for this equation
+  --     The former has a bang-pattern to occ-anal the args, and
+  --     we don't want to occ-anal them twice in the runRW# case!
+  --     This caused #18296
   | fun `hasKey` runRWKey
   , [t1, t2, arg]  <- args
   , let (usage, arg') = occAnalRhs env (Just 1) arg
   = (usage, mkTicks ticks $ mkApps (Var fun) [t1, t2, arg'])
 
-  | otherwise
+occAnalApp env (Var fun, args, ticks)
   = (all_uds, mkTicks ticks $ mkApps fun' args')
   where
     (fun', fun_id') = lookupVarEnv (occ_bs_env env) fun



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f1bfb806683b3092fc5ead84e7ecff928c55fbc4
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/20200607/0931b734/attachment-0001.html>