%
-% (c) The AQUA Project, Glasgow University, 1994
+% (c) The AQUA Project, Glasgow University, 1994-1998
%
\section[LiberateCase]{Unroll recursion to allow evals to be lifted from a loop}
-
\begin{code}
-#include "HsVersions.h"
-
module LiberateCase ( liberateCase ) where
-IMPORT_Trace
+#include "HsVersions.h"
-import Id ( localiseId, toplevelishId{-debugging-} )
-import IdEnv
-import Maybes
+import CmdLineOpts ( DynFlags, DynFlag(..), opt_LiberateCaseThreshold )
+import CoreLint ( showPass, endPass )
+import CoreSyn
+import CoreUnfold ( couldBeSmallEnoughToInline )
+import Var ( Id )
+import VarEnv
+import UniqFM ( ufmToList )
import Outputable
-import PlainCore
-import Pretty
-import SimplEnv ( UnfoldingGuidance(..) )
-import Util
\end{code}
This module walks over @Core@, and looks for @case@ on free variables.
\begin{verbatim}
f = \ t -> case v of
- V a b -> a : f t
+ V a b -> a : f t
\end{verbatim}
=> the inner f is replaced.
f = \ t -> case v of
V a b -> a : (letrec
f = \ t -> case v of
- V a b -> a : f t
- in f) t
+ V a b -> a : f t
+ in f) t
\end{verbatim}
(note the NEED for shadowing)
-=> Run Andr\'e's wonder pass ...
+=> Simplify
+
\begin{verbatim}
f = \ t -> case v of
V a b -> a : (letrec
- f = \ t -> a : f t
+ f = \ t -> a : f t
in f t)
\begin{verbatim}
+
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
+
+ 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.
+
To think about (Apr 94)
~~~~~~~~~~~~~~
let h = ...
in ...
\end{verbatim}
-Here, the level of @f@ is zero, the level of @g@ is one,
+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
+type LibCaseLevel = Int
topLevel :: LibCaseLevel
topLevel = 0
\end{code}
\begin{code}
-data LibCaseEnv
+data LibCaseEnv
= LibCaseEnv
Int -- Bomb-out size for deciding if
-- potential liberatees are too big.
-- (top-level and imported things have
-- a level of zero)
- (IdEnv PlainCoreBinding)-- Binds *only* recursively defined
+ (IdEnv CoreBind) -- Binds *only* recursively defined
-- Ids, to their own binding group,
-- and *only* in their own RHSs
-- really
initEnv :: Int -> LibCaseEnv
-initEnv bomb_size = LibCaseEnv bomb_size 0 nullIdEnv nullIdEnv []
+initEnv bomb_size = LibCaseEnv bomb_size 0 emptyVarEnv emptyVarEnv []
bombOutSize (LibCaseEnv bomb_size _ _ _ _) = bomb_size
\end{code}
Programs
~~~~~~~~
\begin{code}
-liberateCase :: Int -> [PlainCoreBinding] -> [PlainCoreBinding]
-liberateCase bomb_size prog
- = do_prog (initEnv bomb_size) prog
+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 -}
+ }
where
do_prog env [] = []
do_prog env (bind:binds) = bind' : do_prog env' binds
~~~~~~~~
\begin{code}
-libCaseBind :: LibCaseEnv -> PlainCoreBinding -> (LibCaseEnv, PlainCoreBinding)
+libCaseBind :: LibCaseEnv -> CoreBind -> (LibCaseEnv, CoreBind)
-libCaseBind env (CoNonRec binder rhs)
- = (addBinders env [binder], CoNonRec binder (libCase env rhs))
+libCaseBind env (NonRec binder rhs)
+ = (addBinders env [binder], NonRec binder (libCase env rhs))
-libCaseBind env (CoRec pairs)
- = (env_body, CoRec pairs')
+libCaseBind env (Rec pairs)
+ = (env_body, Rec pairs')
where
(binders, rhss) = unzip pairs
-- processing the rhs with an *un-extended* environment, so
-- that the same process doesn't occur for ever!
- extended_env
- = addRecBinds env [ (localiseId binder, libCase env_body rhs)
- | (binder, rhs) <- pairs ]
-
- -- Why "localiseId" above? Because we're creating a new local
- -- copy of the original binding. In particular, the original
- -- binding might have been for a TopLevId, and this copy clearly
- -- will not be top-level!
-
- -- It is enough to change just the binder, because subsequent
- -- simplification will propagate the right info from the binder.
-
- -- Why does it matter? Because the codeGen keeps a separate
- -- environment for top-level Ids, and it is disastrous for it
- -- to think that something is top-level when it isn't.
+ extended_env = addRecBinds env [ (binder, libCase env_body rhs)
+ | (binder, rhs) <- pairs ]
- rhs_small_enough rhs
- = case (calcUnfoldingGuidance True{-sccs OK-} lIBERATE_BOMB_SIZE rhs) of
- UnfoldNever -> False
- _ -> True -- we didn't BOMB, so it must be OK
-
- lIBERATE_BOMB_SIZE = bombOutSize env
+ rhs_small_enough rhs = couldBeSmallEnoughToInline lIBERATE_BOMB_SIZE rhs
+ lIBERATE_BOMB_SIZE = bombOutSize env
\end{code}
\begin{code}
libCase :: LibCaseEnv
- -> PlainCoreExpr
- -> PlainCoreExpr
-
-libCase env (CoLit lit) = CoLit lit
-libCase env (CoVar v) = mkCoLetsNoUnboxed (libCaseId env v) (CoVar v)
-libCase env (CoApp fun arg) = mkCoLetsNoUnboxed (libCaseAtom env arg) (CoApp (libCase env fun) arg)
-libCase env (CoTyApp fun ty) = CoTyApp (libCase env fun) ty
-libCase env (CoCon con tys args) = mkCoLetsNoUnboxed (libCaseAtoms env args) (CoCon con tys args)
-libCase env (CoPrim op tys args) = mkCoLetsNoUnboxed (libCaseAtoms env args) (CoPrim op tys args)
-libCase env (CoTyLam tyvar body) = CoTyLam tyvar (libCase env body)
-libCase env (CoSCC cc body) = CoSCC cc (libCase env body)
-
-libCase env (CoLam binders body)
- = CoLam binders (libCase env' body)
- where
- env' = addBinders env binders
+ -> CoreExpr
+ -> CoreExpr
-libCase env (CoLet bind body)
- = CoLet bind' (libCase env_body body)
- where
- (env_body, bind') = libCaseBind env bind
+libCase env (Var v) = libCaseId env v
+libCase env (Lit lit) = Lit lit
+libCase env (Type ty) = Type ty
+libCase env (App fun arg) = App (libCase env fun) (libCase env arg)
+libCase env (Note note body) = Note note (libCase env body)
-libCase env (CoCase scrut alts)
- = CoCase (libCase env scrut) (libCaseAlts env_alts alts)
- where
- env_alts = case scrut of
- CoVar scrut_var -> addScrutedVar env scrut_var
- other -> env
-\end{code}
-
-
-Case alternatives
-~~~~~~~~~~~~~~~~~
+libCase env (Lam binder body)
+ = Lam binder (libCase (addBinders env [binder]) body)
-\begin{code}
-libCaseAlts env (CoAlgAlts alts deflt)
- = CoAlgAlts (map do_alt alts) (libCaseDeflt env deflt)
+libCase env (Let bind body)
+ = Let bind' (libCase env_body body)
where
- do_alt (con,args,rhs) = (con, args, libCase (addBinders env args) rhs)
+ (env_body, bind') = libCaseBind env bind
-libCaseAlts env (CoPrimAlts alts deflt)
- = CoPrimAlts (map do_alt alts) (libCaseDeflt env deflt)
+libCase env (Case scrut bndr alts)
+ = Case (libCase env scrut) bndr (map (libCaseAlt env_alts) alts)
where
- do_alt (lit,rhs) = (lit, libCase env rhs)
+ env_alts = addBinders env_with_scrut [bndr]
+ env_with_scrut = case scrut of
+ Var scrut_var -> addScrutedVar env scrut_var
+ other -> env
-libCaseDeflt env CoNoDefault
- = CoNoDefault
-libCaseDeflt env (CoBindDefault binder rhs)
- = CoBindDefault binder (libCase (addBinders env [binder]) rhs)
+libCaseAlt env (con,args,rhs) = (con, args, libCase (addBinders env args) rhs)
\end{code}
-Atoms and Ids
-~~~~~~~~~~~~~
+Ids
+~~~
\begin{code}
-libCaseAtoms :: LibCaseEnv -> [PlainCoreAtom] -> [PlainCoreBinding]
-libCaseAtoms env atoms = concat [libCaseAtom env atom | atom <- atoms]
-
-libCaseAtom :: LibCaseEnv -> PlainCoreAtom -> [PlainCoreBinding]
-libCaseAtom env (CoVarAtom arg_id) = libCaseId env arg_id
-libCaseAtom env (CoLitAtom lit) = []
-
-libCaseId :: LibCaseEnv -> Id -> [PlainCoreBinding]
+libCaseId :: LibCaseEnv -> Id -> CoreExpr
libCaseId env v
- | maybeToBool maybe_rec_bind && -- It's a use of a recursive thing
- there_are_free_scruts -- with free vars scrutinised in RHS
- = [the_bind]
+ | Just the_bind <- lookupRecId env v -- It's a use of a recursive thing
+ , not (null free_scruts) -- with free vars scrutinised in RHS
+ = Let the_bind (Var v)
| otherwise
- = []
+ = Var v
where
- maybe_rec_bind :: Maybe PlainCoreBinding -- The binding of the recursive thingy
- maybe_rec_bind = lookupRecId env v
- Just the_bind = maybe_rec_bind
-
rec_id_level = lookupLevel env v
-
- there_are_free_scruts = freeScruts env rec_id_level
-\end{code}
+ free_scruts = freeScruts env rec_id_level
+\end{code}
Utility functions
~~~~~~~~~~~~~~~~~
\begin{code}
-addBinders :: LibCaseEnv -> [Id] -> LibCaseEnv
+addBinders :: LibCaseEnv -> [CoreBndr] -> LibCaseEnv
addBinders (LibCaseEnv bomb lvl lvl_env rec_env scruts) binders
= LibCaseEnv bomb lvl lvl_env' rec_env scruts
where
- lvl_env' = growIdEnvList lvl_env (binders `zip` repeat lvl)
+ lvl_env' = extendVarEnvList lvl_env (binders `zip` repeat lvl)
-addRecBinds :: LibCaseEnv -> [(Id,PlainCoreExpr)] -> LibCaseEnv
+addRecBinds :: LibCaseEnv -> [(Id,CoreExpr)] -> LibCaseEnv
addRecBinds (LibCaseEnv bomb lvl lvl_env rec_env scruts) pairs
= LibCaseEnv bomb lvl' lvl_env' rec_env' scruts
where
lvl' = lvl + 1
- lvl_env' = growIdEnvList lvl_env [(binder,lvl) | (binder,_) <- pairs]
- rec_env' = growIdEnvList rec_env [(binder, CoRec pairs) | (binder,_) <- pairs]
+ lvl_env' = extendVarEnvList lvl_env [(binder,lvl) | (binder,_) <- pairs]
+ rec_env' = extendVarEnvList rec_env [(binder, Rec pairs) | (binder,_) <- pairs]
-addScrutedVar :: LibCaseEnv
+addScrutedVar :: LibCaseEnv
-> Id -- This Id is being scrutinised by a case expression
- -> LibCaseEnv
+ -> LibCaseEnv
addScrutedVar env@(LibCaseEnv bomb lvl lvl_env rec_env scruts) scrut_var
| bind_lvl < lvl
= LibCaseEnv bomb lvl lvl_env rec_env scruts'
-- Add to scruts iff the scrut_var is being scrutinised at
- -- a deeper level than its defn
+ -- a deeper level than its defn
| otherwise = env
where
scruts' = (scrut_var, lvl) : scruts
- bind_lvl = case lookupIdEnv lvl_env scrut_var of
+ bind_lvl = case lookupVarEnv lvl_env scrut_var of
Just lvl -> lvl
- Nothing -> --false: ASSERT(toplevelishId scrut_var)
- topLevel
+ Nothing -> topLevel
-lookupRecId :: LibCaseEnv -> Id -> Maybe PlainCoreBinding
+lookupRecId :: LibCaseEnv -> Id -> Maybe CoreBind
lookupRecId (LibCaseEnv bomb lvl lvl_env rec_env scruts) id
-#ifndef DEBUG
- = lookupIdEnv rec_env id
-#else
- = case (lookupIdEnv rec_env id) of
- xxx@(Just _) -> xxx
- xxx -> --false: ASSERT(toplevelishId id)
- xxx
-#endif
+ = lookupVarEnv rec_env id
lookupLevel :: LibCaseEnv -> Id -> LibCaseLevel
lookupLevel (LibCaseEnv bomb lvl lvl_env rec_env scruts) id
- = case lookupIdEnv lvl_env id of
+ = case lookupVarEnv lvl_env id of
Just lvl -> lvl
- Nothing -> ASSERT(toplevelishId id)
- topLevel
+ Nothing -> topLevel
-freeScruts :: LibCaseEnv
+freeScruts :: LibCaseEnv
-> LibCaseLevel -- Level of the recursive Id
- -> Bool -- True <=> there is an enclosing case of a variable
- -- bound outside (ie level <=) the recursive Id.
+ -> [Id] -- Ids that are scrutinised between the binding
+ -- of the recursive Id and here
freeScruts (LibCaseEnv bomb lvl lvl_env rec_env scruts) rec_bind_lvl
- = not (null free_scruts)
- where
- free_scruts = [v | (v,lvl) <- scruts, lvl > rec_bind_lvl]
-\end{code}
+ = [v | (v,scrut_lvl) <- scruts, scrut_lvl > rec_bind_lvl]
+\end{code}
projects / ghc-hetmet.git / blobdiff