[commit: ghc] master: Improve LiberateCase (800009d)

[git at git.haskell.org]

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

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/800009d9b78a9b2877e7efc889e8a0b21873990d/ghc

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

commit 800009d9b78a9b2877e7efc889e8a0b21873990d
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Fri Dec 8 15:31:36 2017 +0000

    Improve LiberateCase
    
    This patch, which fixes Trac #14566, makes LiberateCase a little
    more conservative.  In particular:
    
    * In libCaseBind, treat a recursive group as a whole, rather than
      binding-by-binding, allowing the group to be duplicated only if
        - the bindings /considered together/ are smaller than the
          liberate-case threshold (which is large by default)
        - none of them are thunks
        - none of them are guaranteed-diverging
    
      The latter condidtion is new, and happens to apply in the
      case of Data/Typeable/Internal.mkTrApp


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

800009d9b78a9b2877e7efc889e8a0b21873990d
 compiler/simplCore/LiberateCase.hs | 90 +++++++++++++++++++++++---------------
 1 file changed, 54 insertions(+), 36 deletions(-)

diff --git a/compiler/simplCore/LiberateCase.hs b/compiler/simplCore/LiberateCase.hs
index 8cee064..342ad73 100644
--- a/compiler/simplCore/LiberateCase.hs
+++ b/compiler/simplCore/LiberateCase.hs
@@ -14,6 +14,7 @@ import GhcPrelude
 import DynFlags
 import CoreSyn
 import CoreUnfold       ( couldBeSmallEnoughToInline )
+import TysWiredIn       ( unitDataConId )
 import Id
 import VarEnv
 import Util             ( notNull )
@@ -68,24 +69,6 @@ Exactly the same optimisation (unrolling one call to f) will work here,
 despite the cast.  See mk_alt_env in the Case branch of libCase.
 
 
-Note [Only functions!]
-~~~~~~~~~~~~~~~~~~~~~~
-Consider the following code
-
-       f = g (case v of V a b -> a : t f)
-
-where g is expensive. If we aren't careful, liberate case will turn this into
-
-       f = g (case v of
-               V a b -> a : t (letrec f = g (case v of V a b -> a : f t)
-                                in f)
-             )
-
-Yikes! We evaluate g twice. This leads to a O(2^n) explosion
-if g calls back to the same code recursively.
-
-Solution: make sure that we only do the liberate-case thing on *functions*
-
 To think about (Apr 94)
 ~~~~~~~~~~~~~~
 Main worry: duplicating code excessively.  At the moment we duplicate
@@ -156,18 +139,63 @@ libCaseBind env (Rec pairs)
         -- We extend the rec-env by binding each Id to its rhs, first
         -- processing the rhs with an *un-extended* environment, so
         -- that the same process doesn't occur for ever!
-    env_rhs = addRecBinds env [ (localiseId binder, libCase env_body rhs)
-                              | (binder, rhs) <- pairs
-                              , rhs_small_enough binder rhs ]
+    env_rhs | is_dupable_bind = addRecBinds env dup_pairs
+            | otherwise       = env
+
+    dup_pairs = [ (localiseId binder, libCase env_body rhs)
+                | (binder, rhs) <- pairs ]
         -- localiseID : see Note [Need to localiseId in libCaseBind]
 
+    is_dupable_bind = small_enough && all ok_pair pairs
 
-    rhs_small_enough id rhs     -- Note [Small enough]
-        =  idArity id > 0       -- Note [Only functions!]
-        && maybe True (\size -> couldBeSmallEnoughToInline (lc_dflags env) size rhs)
-                      (bombOutSize env)
+    -- Size: we are going to duplicate dup_pairs; to find their
+    --       size, build a fake binding (let { dup_pairs } in (),
+    --       and find the size of that
+    -- See Note [Small enough]
+    small_enough = case bombOutSize env of
+                      Nothing   -> True   -- Infinity
+                      Just size -> couldBeSmallEnoughToInline (lc_dflags env) size $
+                                   Let (Rec dup_pairs) (Var unitDataConId)
+
+    ok_pair (id,_)
+        =  idArity id > 0          -- Note [Only functions!]
+        && not (isBottomingId id)  -- Note [Not bottoming ids]
+
+{- Note [Not bottoming Ids]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Do not specialise error-functions (this is unusual, but I once saw it,
+(acually in Data.Typable.Internal)
+
+Note [Only functions!]
+~~~~~~~~~~~~~~~~~~~~~~
+Consider the following code
+
+       f = g (case v of V a b -> a : t f)
+
+where g is expensive. If we aren't careful, liberate case will turn this into
+
+       f = g (case v of
+               V a b -> a : t (letrec f = g (case v of V a b -> a : f t)
+                                in f)
+             )
+
+Yikes! We evaluate g twice. This leads to a O(2^n) explosion
+if g calls back to the same code recursively.
+
+Solution: make sure that we only do the liberate-case thing on *functions*
+
+Note [Small enough]
+~~~~~~~~~~~~~~~~~~~
+Consider
+  \fv. letrec
+         f = \x. BIG...(case fv of { (a,b) -> ...g.. })...
+         g = \y. SMALL...f...
+
+Then we *can* in principle do liberate-case on 'g' (small RHS) but not
+for 'f' (too big).  But doing so is not profitable, becuase duplicating
+'g' at its call site in 'f' doesn't get rid of any cases.  So we just
+ask for the whole group to be small enough.
 
-{-
 Note [Need to localiseId in libCaseBind]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 The call to localiseId is needed for two subtle reasons
@@ -181,16 +209,6 @@ The call to localiseId is needed for two subtle reasons
         nested; if it were floated to the top level, we'd get a name
         clash at code generation time.
 
-Note [Small enough]
-~~~~~~~~~~~~~~~~~~~
-Consider
-  \fv. letrec
-         f = \x. BIG...(case fv of { (a,b) -> ...g.. })...
-         g = \y. SMALL...f...
-Then we *can* do liberate-case on g (small RHS) but not for f (too big).
-But we can choose on a item-by-item basis, and that's what the
-rhs_small_enough call in the comprehension for env_rhs does.
-
 Expressions
 ~~~~~~~~~~~
 -}