\section[LiberateCase]{Unroll recursion to allow evals to be lifted from a loop}
\begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
module LiberateCase ( liberateCase ) where
#include "HsVersions.h"
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
-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]
~~~~~~~~~~~~~~~~~~~~~~~~~~
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
the entire binding group once at each recursive call. But there may
be a group of recursive calls which share a common set of evaluated
pairs' = [(binder, libCase env_rhs rhs) | (binder,rhs) <- pairs]
- env_rhs = if all rhs_small_enough rhss then extended_env else env
+ env_rhs = if all rhs_small_enough pairs then extended_env else env
-- We extend the rec-env by binding each Id to its rhs, first
-- processing the rhs with an *un-extended* environment, so
-- clash at code generation time.
adjust bndr = setIdNotExported (setIdName bndr (localiseName (idName bndr)))
- rhs_small_enough rhs = couldBeSmallEnoughToInline lIBERATE_BOMB_SIZE rhs
- lIBERATE_BOMB_SIZE = bombOutSize env
+ rhs_small_enough (id,rhs)
+ = idArity id > 0 -- Note [Only functions!]
+ && couldBeSmallEnoughToInline (bombOutSize env) rhs
\end{code}
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}
+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).
+
%************************************************************************
%* *
| 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
= 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}
%************************************************************************
-- (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,
- -- 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,
- -- 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)]
- -- 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
projects / ghc-hetmet.git / blobdiff