X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FLiberateCase.lhs;h=9c51103d7636b4b4d550d079eba0caff61371b88;hb=00fe4381668528eb2f60496eea97e433528d2bb8;hp=31063d3b2491b7a32fd859137fc8904aefa32cdd;hpb=7aa3f5247ae454b10b61e2f28a9431f0889a8cff;p=ghc-hetmet.git
diff --git a/compiler/simplCore/LiberateCase.lhs b/compiler/simplCore/LiberateCase.lhs
index 31063d3..9c51103 100644
--- a/compiler/simplCore/LiberateCase.lhs
+++ b/compiler/simplCore/LiberateCase.lhs
@@ -4,6 +4,13 @@
\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"
@@ -17,15 +24,9 @@ import Rules ( RuleBase )
import UniqSupply ( UniqSupply )
import SimplMonad ( SimplCount, zeroSimplCount )
import Id
-import FamInstEnv
-import Type
-import Coercion
-import TyCon
import VarEnv
import Name ( localiseName )
-import Outputable
import Util ( notNull )
-import Data.IORef ( readIORef )
\end{code}
The liberate-case transformation
@@ -59,30 +60,13 @@ Example
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]
~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -90,13 +74,30 @@ Consider this:
f = \ t -> case (v `cast` co) of
V a b -> a : f t
-Exactly the same optimistaion (unrolling one call to f) will work here,
+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
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
@@ -108,7 +109,6 @@ big.
Data types
~~~~~~~~~~
-
The ``level'' of a binder tells how many
recursive defns lexically enclose the binding
A recursive defn "encloses" its RHS, not its
@@ -122,43 +122,6 @@ scope. For example:
Here, the level of @f@ is zero, the level of @g@ is one,
and the level of @h@ is zero (NB not one).
-Note [Indexed data types]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
- data family T :: * -> *
- data T Int = TI Int
-
- f :: T Int -> Bool
- f x = case x of { DEFAULT ->
}
-
-We would like to change this to
- f x = case x `cast` co of { TI p -> }
-
-so that can make use of the fact that x is already evaluated to
-a TI; and a case on a known data type may be more efficient than a
-polymorphic one (not sure this is true any longer). Anyway the former
-showed up in Roman's experiments. Example:
- foo :: FooT Int -> Int -> Int
- foo t n = t `seq` bar n
- where
- bar 0 = 0
- bar n = bar (n - case t of TI i -> i)
-Here we'd like to avoid repeated evaluating t inside the loop, by
-taking advantage of the `seq`.
-
-We implement this as part of the liberate-case transformation by
-spotting
- case of (x::T) tys { DEFAULT -> }
-where x :: T tys, and T is a indexed family tycon. Find the
-representation type (T77 tys'), and coercion co, and transform to
- case `cast` co of (y::T77 tys')
- DEFAULT -> let x = y `cast` sym co in
-
-The "find the representation type" part is done by looking up in the
-family-instance environment.
-
-NB: in fact we re-use x (changing its type) to avoid making a fresh y;
-this entails shadowing, but that's ok.
%************************************************************************
%* *
@@ -171,11 +134,9 @@ liberateCase :: HscEnv -> UniqSupply -> RuleBase -> ModGuts
-> IO (SimplCount, ModGuts)
liberateCase hsc_env _ _ guts
= do { let dflags = hsc_dflags hsc_env
- ; eps <- readIORef (hsc_EPS hsc_env)
- ; let fam_envs = (eps_fam_inst_env eps, mg_fam_inst_env guts)
; showPass dflags "Liberate case"
- ; let { env = initEnv dflags fam_envs
+ ; let { env = initEnv dflags
; binds' = do_prog env (mg_binds guts) }
; endPass dflags "Liberate case" Opt_D_verbose_core2core binds'
{- no specific flag for dumping -}
@@ -211,7 +172,7 @@ libCaseBind env (Rec pairs)
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
@@ -232,8 +193,10 @@ libCaseBind env (Rec pairs)
-- 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!]
+ && maybe True (\size -> couldBeSmallEnoughToInline size rhs)
+ (bombOutSize env)
\end{code}
@@ -261,7 +224,7 @@ libCase env (Let bind body)
(env_body, bind') = libCaseBind env bind
libCase env (Case scrut bndr ty alts)
- = mkCase env (libCase env scrut) bndr ty (map (libCaseAlt env_alts) alts)
+ = Case (libCase env scrut) bndr ty (map (libCaseAlt env_alts) alts)
where
env_alts = addBinders (mk_alt_env scrut) [bndr]
mk_alt_env (Var scrut_var) = addScrutedVar env scrut_var
@@ -271,23 +234,6 @@ libCase env (Case scrut bndr ty alts)
libCaseAlt env (con,args,rhs) = (con, args, libCase (addBinders env args) rhs)
\end{code}
-\begin{code}
-mkCase :: LibCaseEnv -> CoreExpr -> Id -> Type -> [CoreAlt] -> CoreExpr
--- See Note [Indexed data types]
-mkCase env scrut bndr ty [(DEFAULT,_,rhs)]
- | Just (tycon, tys) <- splitTyConApp_maybe (idType bndr)
- , [(subst, fam_inst)] <- lookupFamInstEnv (lc_fams env) tycon tys
- = let
- rep_tc = famInstTyCon fam_inst
- rep_tys = map (substTyVar subst) (tyConTyVars rep_tc)
- bndr' = setIdType bndr (mkTyConApp rep_tc rep_tys)
- Just co_tc = tyConFamilyCoercion_maybe rep_tc
- co = mkTyConApp co_tc rep_tys
- bind = NonRec bndr (Cast (Var bndr') (mkSymCoercion co))
- in mkCase env (Cast scrut co) bndr' ty [(DEFAULT,[],Let bind rhs)]
-mkCase env scrut bndr ty alts
- = Case scrut bndr ty alts
-\end{code}
Ids
~~~
@@ -304,8 +250,39 @@ libCaseId env v
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).
+
%************************************************************************
%* *
@@ -342,7 +319,7 @@ addScrutedVar env@(LibCaseEnv { lc_lvl = lvl, lc_lvl_env = lvl_env,
| 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
@@ -353,15 +330,8 @@ lookupRecId env id = lookupVarEnv (lc_rec_env env) id
lookupLevel :: LibCaseEnv -> Id -> LibCaseLevel
lookupLevel env id
= case lookupVarEnv (lc_lvl_env env) id of
- Just lvl -> lc_lvl env
+ 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}
%************************************************************************
@@ -380,43 +350,39 @@ topLevel = 0
\begin{code}
data LibCaseEnv
= LibCaseEnv {
- lc_size :: Int, -- Bomb-out size for deciding if
+ lc_size :: Maybe Int, -- Bomb-out size for deciding if
-- potential liberatees are too big.
-- (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
-
- 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
-
- lc_fams :: FamInstEnvs
- -- Instance env for indexed data types
+ -- 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, 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 -> FamInstEnvs -> LibCaseEnv
-initEnv dflags fams
- = LibCaseEnv { lc_size = libCaseThreshold dflags,
+initEnv :: DynFlags -> LibCaseEnv
+initEnv dflags
+ = LibCaseEnv { lc_size = liberateCaseThreshold dflags,
lc_lvl = 0,
lc_lvl_env = emptyVarEnv,
lc_rec_env = emptyVarEnv,
- lc_scruts = [],
- lc_fams = fams }
+ lc_scruts = [] }
bombOutSize = lc_size
\end{code}