#include "HsVersions.h"
-import CmdLineOpts ( opt_D_verbose_core2core, opt_LiberateCaseThreshold )
-import CoreLint ( beginPass, endPass )
+import CmdLineOpts ( DynFlags, DynFlag(..), opt_LiberateCaseThreshold )
+import CoreLint ( showPass, endPass )
import CoreSyn
-import CoreUnfold ( calcUnfoldingGuidance, UnfoldingGuidance(..) )
+import CoreUnfold ( couldBeSmallEnoughToInline )
import Var ( Id )
import VarEnv
-import Maybes
+import UniqFM ( ufmToList )
import Outputable
-import Util
\end{code}
This module walks over @Core@, and looks for @case@ on free variables.
\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.
-- (top-level and imported things have
-- a level of zero)
- (IdEnv CoreBind)-- Binds *only* recursively defined
+ (IdEnv CoreBind) -- Binds *only* recursively defined
-- Ids, to their own binding group,
-- and *only* in their own RHSs
Programs
~~~~~~~~
\begin{code}
-liberateCase :: [CoreBind] -> IO [CoreBind]
-liberateCase binds
+liberateCase :: DynFlags -> [CoreBind] -> IO [CoreBind]
+liberateCase dflags binds
= do {
- beginPass "Liberate case" ;
+ showPass dflags "Liberate case" ;
let { binds' = do_prog (initEnv opt_LiberateCaseThreshold) binds } ;
- endPass "Liberate case"
- opt_D_verbose_core2core {- no specific flag for dumping -}
- binds'
+ endPass dflags "Liberate case" Opt_D_verbose_core2core binds'
+ {- no specific flag for dumping -}
}
where
do_prog env [] = []
-- processing the rhs with an *un-extended* environment, so
-- that the same process doesn't occur for ever!
- extended_env
- = addRecBinds env [ (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 top-level, 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.
- --
- -- [May 98: all this is now handled by SimplCore.tidyCore]
+ extended_env = addRecBinds env [ (binder, libCase env_body rhs)
+ | (binder, rhs) <- pairs ]
- rhs_small_enough rhs
- = case (calcUnfoldingGuidance 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}
-> CoreExpr
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 (Con con args) = Con con (map (libCase env) args)
libCase env (Note note body) = Note note (libCase env body)
libCase env (Lam binder body)
libCase env (Case scrut bndr alts)
= Case (libCase env scrut) bndr (map (libCaseAlt env_alts) alts)
where
- env_alts = addBinders env [bndr]
+ env_alts = addBinders env_with_scrut [bndr]
env_with_scrut = case scrut of
Var scrut_var -> addScrutedVar env scrut_var
- other -> env
+ other -> env
libCaseAlt env (con,args,rhs) = (con, args, libCase (addBinders env args) rhs)
\end{code}
\begin{code}
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
+ | 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 CoreBind -- 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}
lookupRecId :: LibCaseEnv -> Id -> Maybe CoreBind
lookupRecId (LibCaseEnv bomb lvl lvl_env rec_env scruts) id
-#ifndef DEBUG
= lookupVarEnv rec_env id
-#else
- = case (lookupVarEnv rec_env id) of
- xxx@(Just _) -> xxx
- xxx -> xxx
-#endif
lookupLevel :: LibCaseEnv -> Id -> LibCaseLevel
lookupLevel (LibCaseEnv bomb lvl lvl_env rec_env scruts) id
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}
projects / ghc-hetmet.git / blobdiff