Fix LiberateCase

	Merge to STABLE please

Liberate case was being far too gung-ho about what to specialise. This
bug only showed up when a recursive function 'f' has a nested recursive
function 'g', where 'g' calls 'f' (as well as recursively calling 'g').
This exact situation happens in GHC/IO.writeLines.

This patch puts things right; see Note [When to specialise].  Result:
much less code bloat.

diff --git a/compiler/simplCore/LiberateCase.lhs b/compiler/simplCore/LiberateCase.lhs
index 8b3d91b..c29d217 100644 (file)
--- a/compiler/simplCore/LiberateCase.lhs
+++ b/compiler/simplCore/LiberateCase.lhs
@@ -60,30 +60,13 @@ Example
 Better code, because 'a' is  free inside the inner letrec, rather
 than needing projection from v.
 
 Better code, because 'a' is  free inside the inner letrec, rather
 than needing projection from v.
 

-Other examples we'd like to catch with this kind of transformation
+Note that this deals with *free variables*.  SpecConstr deals with
+*arguments* that are of known form.  E.g.

 
        last []     = error 
        last (x:[]) = x
        last (x:xs) = last xs
 
 
        last []     = error 
        last (x:[]) = x
        last (x:xs) = last xs
 

-We'd like to avoid the redundant pattern match, transforming to
-
-       last [] = error
-       last (x:[]) = x
-       last (x:(y:ys)) = last' y ys
-               where
-                 last' y []     = y
-                 last' _ (y:ys) = last' y ys
-
-       (is this necessarily an improvement)
-
-Similarly drop:
-
-       drop n [] = []
-       drop 0 xs = xs
-       drop n (x:xs) = drop (n-1) xs
-
-Would like to pass n along unboxed.

        
 Note [Scrutinee with cast]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
        
 Note [Scrutinee with cast]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~

@@ -266,8 +249,39 @@ libCaseId env v
   where
     rec_id_level = lookupLevel env v
     free_scruts  = freeScruts env rec_id_level
   where
     rec_id_level = lookupLevel env v
     free_scruts  = freeScruts env rec_id_level

+
+freeScruts :: LibCaseEnv
+          -> LibCaseLevel      -- Level of the recursive Id
+          -> [Id]              -- Ids that are scrutinised between the binding
+                               -- of the recursive Id and here
+freeScruts env rec_bind_lvl
+  = [v | (v,scrut_bind_lvl) <- lc_scruts env
+       , scrut_bind_lvl <= rec_bind_lvl]
+       -- Note [When to specialise]

 \end{code}
 
 \end{code}
 

+Note [When to specialise]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  f = \x. letrec g = \y. case x of
+                          True  -> ... (f a) ...
+                          False -> ... (g b) ...
+
+We get the following levels
+         f  0
+         x  1
+         g  1
+         y  2  
+
+Then 'x' is being scrutinised at a deeper level than its binding, so
+it's added to lc_sruts:  [(x,1)]  
+
+We do *not* want to specialise the call to 'f', becuase 'x' is not free 
+in 'f'.  So here the bind-level of 'x' (=1) is not <= the bind-level of 'f' (=0).
+
+We *do* want to specialise the call to 'g', because 'x' is free in g.
+Here the bind-level of 'x' (=1) is <= the bind-level of 'g' (=1).
+

 
 %************************************************************************
 %*                                                                     *
 
 %************************************************************************
 %*                                                                     *

@@ -304,7 +318,7 @@ addScrutedVar env@(LibCaseEnv { lc_lvl = lvl, lc_lvl_env = lvl_env,
 
   | otherwise = env
   where
 
   | otherwise = env
   where

-    scruts'  = (scrut_var, lvl) : scruts
+    scruts'  = (scrut_var, bind_lvl) : scruts

     bind_lvl = case lookupVarEnv lvl_env scrut_var of
                 Just lvl -> lvl
                 Nothing  -> topLevel
     bind_lvl = case lookupVarEnv lvl_env scrut_var of
                 Just lvl -> lvl
                 Nothing  -> topLevel

@@ -317,13 +331,6 @@ lookupLevel env id
   = case lookupVarEnv (lc_lvl_env env) id of
       Just lvl -> lvl
       Nothing  -> topLevel
   = case lookupVarEnv (lc_lvl_env env) id of
       Just lvl -> lvl
       Nothing  -> topLevel

-
-freeScruts :: LibCaseEnv
-          -> LibCaseLevel      -- Level of the recursive Id
-          -> [Id]              -- Ids that are scrutinised between the binding
-                               -- of the recursive Id and here
-freeScruts env rec_bind_lvl
-  = [v | (v,scrut_lvl) <- lc_scruts env, scrut_lvl > rec_bind_lvl]

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -347,25 +354,25 @@ data LibCaseEnv
                                -- (passed in from cmd-line args)
 
        lc_lvl :: LibCaseLevel, -- Current level
                                -- (passed in from cmd-line args)
 
        lc_lvl :: LibCaseLevel, -- Current level

+               -- The level is incremented when (and only when) going
+               -- inside the RHS of a (sufficiently small) recursive
+               -- function.

 
        lc_lvl_env :: IdEnv LibCaseLevel,  
 
        lc_lvl_env :: IdEnv LibCaseLevel,  

-                       -- Binds all non-top-level in-scope Ids
-                       -- (top-level and imported things have
-                       -- a level of zero)
+               -- Binds all non-top-level in-scope Ids (top-level and
+               -- imported things have a level of zero)

 
        lc_rec_env :: IdEnv CoreBind, 
 
        lc_rec_env :: IdEnv CoreBind, 

-                       -- Binds *only* recursively defined ids, 
-                       -- to their own binding group,
-                       -- and *only* in their own RHSs
+               -- Binds *only* recursively defined ids, to their own
+               -- binding group, and *only* in their own RHSs

 
        lc_scruts :: [(Id,LibCaseLevel)]
 
        lc_scruts :: [(Id,LibCaseLevel)]

-                       -- Each of these Ids was scrutinised by an
-                       -- enclosing case expression, with the
-                       -- specified number of enclosing
-                       -- recursive bindings; furthermore,
-                       -- the Id is bound at a lower level
-                       -- than the case expression.  The order is
-                       -- insignificant; it's a bag really
+               -- Each of these Ids was scrutinised by an enclosing
+               -- case expression, at a level deeper than its binding
+               -- level.  The LibCaseLevel recorded here is the *binding
+               -- level* of the scrutinised Id.
+               -- 
+               -- The order is insignificant; it's a bag really

        }
 
 initEnv :: DynFlags -> LibCaseEnv
        }
 
 initEnv :: DynFlags -> LibCaseEnv