X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FLiberateCase.lhs;h=c29a5b9c68f0eff66461e461450815bbeb882d36;hb=c5b03909e7c630a874f6f1abf76d28baf4b19d55;hp=a67c6a6f557008037fabd23eec88dab758b47a47;hpb=12899612693163154531da3285ec99c1c8ca2226;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/LiberateCase.lhs b/ghc/compiler/simplCore/LiberateCase.lhs index a67c6a6..c29a5b9 100644 --- a/ghc/compiler/simplCore/LiberateCase.lhs +++ b/ghc/compiler/simplCore/LiberateCase.lhs @@ -1,27 +1,23 @@ % -% (c) The AQUA Project, Glasgow University, 1994-1996 +% (c) The AQUA Project, Glasgow University, 1994-1998 % \section[LiberateCase]{Unroll recursion to allow evals to be lifted from a loop} -96/03: We aren't using this at the moment - \begin{code} -#include "HsVersions.h" - module LiberateCase ( liberateCase ) where -IMP_Ubiq(){-uitous-} -import Util ( panic ) - -liberateCase = panic "LiberateCase.liberateCase: ToDo" +#include "HsVersions.h" -{- LATER: to end of file: -import CoreUnfold ( UnfoldingGuidance(..) ) -import Id ( localiseId, toplevelishId{-debugging-} ) -import Maybes +import DynFlags ( DynFlags, DynFlag(..) ) +import StaticFlags ( opt_LiberateCaseThreshold ) +import CoreLint ( showPass, endPass ) +import CoreSyn +import CoreUnfold ( couldBeSmallEnoughToInline ) +import Id ( Id, setIdName, idName, setIdNotExported ) +import VarEnv +import Name ( localiseName ) import Outputable -import Pretty -import Util +import Util ( notNull ) \end{code} This module walks over @Core@, and looks for @case@ on free variables. @@ -47,16 +43,44 @@ f = \ t -> case v of \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 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) ~~~~~~~~~~~~~~ @@ -106,7 +130,7 @@ data LibCaseEnv -- (top-level and imported things have -- a level of zero) - (IdEnv CoreBinding)-- Binds *only* recursively defined + (IdEnv CoreBind) -- Binds *only* recursively defined -- Ids, to their own binding group, -- and *only* in their own RHSs @@ -120,7 +144,7 @@ data LibCaseEnv -- 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} @@ -129,9 +153,14 @@ bombOutSize (LibCaseEnv bomb_size _ _ _ _) = bomb_size Programs ~~~~~~~~ \begin{code} -liberateCase :: Int -> [CoreBinding] -> [CoreBinding] -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 @@ -143,7 +172,7 @@ Bindings ~~~~~~~~ \begin{code} -libCaseBind :: LibCaseEnv -> CoreBinding -> (LibCaseEnv, CoreBinding) +libCaseBind :: LibCaseEnv -> CoreBind -> (LibCaseEnv, CoreBind) libCaseBind env (NonRec binder rhs) = (addBinders env [binder], NonRec binder (libCase env rhs)) @@ -162,30 +191,24 @@ libCaseBind env (Rec pairs) -- We extend the rec-env by binding each Id to its rhs, first -- 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. - - rhs_small_enough rhs - = case (calcUnfoldingGuidance True{-sccs OK-} lIBERATE_BOMB_SIZE cON_DISCOUNT rhs) of - UnfoldNever -> False - _ -> True -- we didn't BOMB, so it must be OK - - lIBERATE_BOMB_SIZE = bombOutSize env - cON_DISCOUNT = error "libCaseBind" + -- + extended_env = addRecBinds env [ (adjust binder, libCase env_body rhs) + | (binder, rhs) <- pairs ] + + -- Two subtle things: + -- (a) Reset the export flags on the binders so + -- that we don't get name clashes on exported things if the + -- local binding floats out to top level. This is most unlikely + -- to happen, since the whole point concerns free variables. + -- But resetting the export flag is right regardless. + -- + -- (b) Make the name an Internal one. External Names should never be + -- nested; if it were floated to the top level, we'd get a name + -- 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 \end{code} @@ -197,15 +220,11 @@ libCase :: LibCaseEnv -> CoreExpr -> CoreExpr +libCase env (Var v) = libCaseId env v libCase env (Lit lit) = Lit lit -libCase env (Var v) = mkCoLetsNoUnboxed (libCaseId env v) (Var v) -libCase env (App fun arg) = mkCoLetsNoUnboxed (libCaseAtom env arg) (App (libCase env fun) arg) -libCase env (CoTyApp fun ty) = CoTyApp (libCase env fun) ty -libCase env (Con con tys args) = mkCoLetsNoUnboxed (libCaseAtoms env args) (Con con tys args) -libCase env (Prim op tys args) = mkCoLetsNoUnboxed (libCaseAtoms env args) (Prim op tys args) -libCase env (CoTyLam tv body) = CoTyLam tv (libCase env body) -libCase env (SCC cc body) = SCC cc (libCase env body) -libCase env (Coerce c ty body) = Coerce c ty (libCase env body) +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 (Lam binder body) = Lam binder (libCase (addBinders env [binder]) body) @@ -215,62 +234,32 @@ libCase env (Let bind body) where (env_body, bind') = libCaseBind env bind -libCase env (Case scrut alts) - = Case (libCase env scrut) (libCaseAlts env_alts alts) +libCase env (Case scrut bndr ty alts) + = Case (libCase env scrut) bndr ty (map (libCaseAlt env_alts) alts) where - env_alts = case scrut of - Var scrut_var -> addScrutedVar env scrut_var - other -> env -\end{code} - + env_alts = addBinders env_with_scrut [bndr] + env_with_scrut = case scrut of + Var scrut_var -> addScrutedVar env scrut_var + other -> env -Case alternatives -~~~~~~~~~~~~~~~~~ - -\begin{code} -libCaseAlts env (AlgAlts alts deflt) - = AlgAlts (map do_alt alts) (libCaseDeflt env deflt) - where - do_alt (con,args,rhs) = (con, args, libCase (addBinders env args) rhs) - -libCaseAlts env (PrimAlts alts deflt) - = PrimAlts (map do_alt alts) (libCaseDeflt env deflt) - where - do_alt (lit,rhs) = (lit, libCase env rhs) - -libCaseDeflt env NoDefault - = NoDefault -libCaseDeflt env (BindDefault binder rhs) - = BindDefault 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 -> [CoreArg] -> [CoreBinding] -libCaseAtoms env atoms = concat [libCaseAtom env atom | atom <- atoms] - -libCaseAtom :: LibCaseEnv -> CoreArg -> [CoreBinding] -libCaseAtom env (VarArg arg_id) = libCaseId env arg_id -libCaseAtom env (LitArg lit) = [] - -libCaseId :: LibCaseEnv -> Id -> [CoreBinding] +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 + , notNull free_scruts -- with free vars scrutinised in RHS + = Let the_bind (Var v) | otherwise - = [] + = Var v where - maybe_rec_bind :: Maybe CoreBinding -- 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 + free_scruts = freeScruts env rec_id_level \end{code} @@ -278,19 +267,19 @@ libCaseId env v 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,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, Rec pairs) | (binder,_) <- pairs] + lvl_env' = extendVarEnvList lvl_env [(binder,lvl) | (binder,_) <- pairs] + rec_env' = extendVarEnvList rec_env [(binder, Rec pairs) | (binder,_) <- pairs] addScrutedVar :: LibCaseEnv -> Id -- This Id is being scrutinised by a case expression @@ -305,36 +294,24 @@ addScrutedVar env@(LibCaseEnv bomb lvl lvl_env rec_env scruts) scrut_var | 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 CoreBinding +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 -> 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] --} + = [v | (v,scrut_lvl) <- scruts, scrut_lvl > rec_bind_lvl] \end{code}