\section[LiberateCase]{Unroll recursion to allow evals to be lifted from a loop}
\begin{code}
+{-# OPTIONS_GHC -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/WorkingConventions#Warnings
+-- for details
+
module LiberateCase ( liberateCase ) where
#include "HsVersions.h"
-import DynFlags ( DynFlags, DynFlag(..) )
-import StaticFlags ( opt_LiberateCaseThreshold )
+import DynFlags
+import HscTypes
import CoreLint ( showPass, endPass )
import CoreSyn
import CoreUnfold ( couldBeSmallEnoughToInline )
-import Id ( Id, setIdName, idName, setIdNotExported )
+import Rules ( RuleBase )
+import UniqSupply ( UniqSupply )
+import SimplMonad ( SimplCount, zeroSimplCount )
+import Id
import VarEnv
import Name ( localiseName )
-import Outputable
import Util ( notNull )
\end{code}
+The liberate-case transformation
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
This module walks over @Core@, and looks for @case@ on free variables.
The criterion is:
if there is case on a free on the route to the recursive call,
Example
-\begin{verbatim}
-f = \ t -> case v of
- V a b -> a : f t
-\end{verbatim}
+ f = \ t -> case v of
+ V a b -> a : f t
=> the inner f is replaced.
-\begin{verbatim}
-f = \ t -> case v of
- V a b -> a : (letrec
+ f = \ t -> case v of
+ V a b -> a : (letrec
f = \ t -> case v of
V a b -> a : f t
- in f) t
-\end{verbatim}
+ in f) t
(note the NEED for shadowing)
=> Simplify
-\begin{verbatim}
-f = \ t -> case v of
- V a b -> a : (letrec
+ f = \ t -> case v of
+ V a b -> a : (letrec
f = \ t -> a : f t
- in f t)
-\begin{verbatim}
+ in f t)
Better code, because 'a' is free inside the inner letrec, rather
than needing projection from v.
(is this necessarily an improvement)
-
Similarly drop:
drop n [] = []
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
Data types
~~~~~~~~~~
-
The ``level'' of a binder tells how many
recursive defns lexically enclose the binding
A recursive defn "encloses" its RHS, not its
Here, the level of @f@ is zero, the level of @g@ is one,
and the level of @h@ is zero (NB not one).
-\begin{code}
-type LibCaseLevel = Int
-topLevel :: LibCaseLevel
-topLevel = 0
-\end{code}
+%************************************************************************
+%* *
+ Top-level code
+%* *
+%************************************************************************
\begin{code}
-data LibCaseEnv
- = LibCaseEnv {
- lc_size :: Int, -- Bomb-out size for deciding if
- -- potential liberatees are too big.
- -- (passed in from cmd-line args)
-
- lc_lvl :: LibCaseLevel, -- Current level
-
- lc_lvl_env :: IdEnv LibCaseLevel,
- -- 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
- }
-
-initEnv :: Int -> LibCaseEnv
-initEnv bomb_size
- = LibCaseEnv { lc_size = bomb_size, lc_lvl = 0,
- lc_lvl_env = emptyVarEnv, lc_rec_env = emptyVarEnv,
- lc_scruts = [] }
-
-bombOutSize = lc_size
-\end{code}
-
-
-Programs
-~~~~~~~~
-\begin{code}
-liberateCase :: DynFlags -> [CoreBind] -> IO [CoreBind]
-liberateCase dflags binds
- = do {
- showPass dflags "Liberate case" ;
- let { binds' = do_prog (initEnv opt_LiberateCaseThreshold) binds } ;
- endPass dflags "Liberate case" Opt_D_verbose_core2core binds'
- {- no specific flag for dumping -}
- }
+liberateCase :: HscEnv -> UniqSupply -> RuleBase -> ModGuts
+ -> IO (SimplCount, ModGuts)
+liberateCase hsc_env _ _ guts
+ = do { let dflags = hsc_dflags hsc_env
+
+ ; showPass dflags "Liberate case"
+ ; 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 -}
+ ; return (zeroSimplCount dflags, guts { mg_binds = binds' }) }
where
do_prog env [] = []
do_prog env (bind:binds) = bind' : do_prog env' binds
(env', bind') = libCaseBind env bind
\end{code}
+
+%************************************************************************
+%* *
+ Main payload
+%* *
+%************************************************************************
+
Bindings
~~~~~~~~
-
\begin{code}
libCaseBind :: LibCaseEnv -> CoreBind -> (LibCaseEnv, CoreBind)
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}
libCaseAlt env (con,args,rhs) = (con, args, libCase (addBinders env args) rhs)
\end{code}
+
Ids
~~~
\begin{code}
\end{code}
+%************************************************************************
+%* *
+ Utility functions
+%* *
+%************************************************************************
-Utility functions
-~~~~~~~~~~~~~~~~~
\begin{code}
addBinders :: LibCaseEnv -> [CoreBndr] -> LibCaseEnv
addBinders env@(LibCaseEnv { lc_lvl = lvl, lc_lvl_env = lvl_env }) binders
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
freeScruts env rec_bind_lvl
= [v | (v,scrut_lvl) <- lc_scruts env, scrut_lvl > rec_bind_lvl]
\end{code}
+
+%************************************************************************
+%* *
+ The environment
+%* *
+%************************************************************************
+
+\begin{code}
+type LibCaseLevel = Int
+
+topLevel :: LibCaseLevel
+topLevel = 0
+\end{code}
+
+\begin{code}
+data LibCaseEnv
+ = LibCaseEnv {
+ lc_size :: Int, -- Bomb-out size for deciding if
+ -- potential liberatees are too big.
+ -- (passed in from cmd-line args)
+
+ lc_lvl :: LibCaseLevel, -- Current level
+
+ lc_lvl_env :: IdEnv LibCaseLevel,
+ -- 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
+ }
+
+initEnv :: DynFlags -> LibCaseEnv
+initEnv dflags
+ = LibCaseEnv { lc_size = specThreshold dflags,
+ lc_lvl = 0,
+ lc_lvl_env = emptyVarEnv,
+ lc_rec_env = emptyVarEnv,
+ lc_scruts = [] }
+
+bombOutSize = lc_size
+\end{code}
+
+
projects / ghc-hetmet.git / blobdiff