diff options
Diffstat (limited to 'ghc/compiler/simplCore')
| -rw-r--r-- | ghc/compiler/simplCore/BinderInfo.lhs | 12 | ||||
| -rw-r--r-- | ghc/compiler/simplCore/FloatIn.lhs | 51 | ||||
| -rw-r--r-- | ghc/compiler/simplCore/FloatOut.lhs | 4 | ||||
| -rw-r--r-- | ghc/compiler/simplCore/LiberateCase.lhs | 6 | ||||
| -rw-r--r-- | ghc/compiler/simplCore/MagicUFs.lhs | 645 | ||||
| -rw-r--r-- | ghc/compiler/simplCore/OccurAnal.lhs | 374 | ||||
| -rw-r--r-- | ghc/compiler/simplCore/SATMonad.lhs | 4 | ||||
| -rw-r--r-- | ghc/compiler/simplCore/SetLevels.lhs | 159 | ||||
| -rw-r--r-- | ghc/compiler/simplCore/SimplCore.lhs | 388 | ||||
| -rw-r--r-- | ghc/compiler/simplCore/SimplMonad.lhs | 687 | ||||
| -rw-r--r-- | ghc/compiler/simplCore/SimplUtils.lhs | 365 | ||||
| -rw-r--r-- | ghc/compiler/simplCore/Simplify.lhs | 1731 |
12 files changed, 1958 insertions, 2468 deletions
diff --git a/ghc/compiler/simplCore/BinderInfo.lhs b/ghc/compiler/simplCore/BinderInfo.lhs index 506950721b..f125975de0 100644 --- a/ghc/compiler/simplCore/BinderInfo.lhs +++ b/ghc/compiler/simplCore/BinderInfo.lhs @@ -15,7 +15,7 @@ module BinderInfo ( deadOccurrence, funOccurrence, noBinderInfo, - markLazy, markMany, markInsideLam, markInsideSCC, + markMany, markInsideLam, markInsideSCC, getBinderInfoArity, setBinderInfoArityToZero, @@ -94,9 +94,9 @@ deadOccurrence :: BinderInfo deadOccurrence = DeadCode funOccurrence :: Int -> BinderInfo -funOccurrence = OneOcc StrictOcc NotInsideSCC 1 +funOccurrence = OneOcc NotInsideLam NotInsideSCC 1 -markLazy, markMany, markInsideLam, markInsideSCC :: BinderInfo -> BinderInfo +markMany, markInsideLam, markInsideSCC :: BinderInfo -> BinderInfo markMany (OneOcc _ _ _ ar) = ManyOcc ar markMany (ManyOcc ar) = ManyOcc ar @@ -108,9 +108,6 @@ markInsideLam other = other markInsideSCC (OneOcc dup_danger _ n_alts ar) = OneOcc dup_danger InsideSCC n_alts ar markInsideSCC other = other -markLazy (OneOcc StrictOcc scc n_alts ar) = OneOcc LazyOcc scc n_alts ar -markLazy other = other - addBinderInfo, orBinderInfo :: BinderInfo -> BinderInfo -> BinderInfo addBinderInfo DeadCode info2 = info2 @@ -138,8 +135,7 @@ orBinderInfo info1 info2 or_dups InsideLam _ = InsideLam or_dups _ InsideLam = InsideLam -or_dups StrictOcc StrictOcc = StrictOcc -or_dups _ _ = LazyOcc +or_dups _ _ = NotInsideLam or_sccs InsideSCC _ = InsideSCC or_sccs _ InsideSCC = InsideSCC diff --git a/ghc/compiler/simplCore/FloatIn.lhs b/ghc/compiler/simplCore/FloatIn.lhs index 865531a718..c53315eeba 100644 --- a/ghc/compiler/simplCore/FloatIn.lhs +++ b/ghc/compiler/simplCore/FloatIn.lhs @@ -19,8 +19,10 @@ module FloatIn ( floatInwards ) where import CmdLineOpts ( opt_D_verbose_core2core ) import CoreSyn import CoreLint ( beginPass, endPass ) -import FreeVars ( CoreExprWithFVs, freeVars, freeVarsOf ) -import Var ( Id ) +import Const ( isDataCon ) +import CoreFVs ( CoreExprWithFVs, freeVars, freeVarsOf ) +import Var ( Id, idType ) +import Type ( isUnLiftedType ) import VarSet import Util ( zipEqual ) import Outputable @@ -196,6 +198,10 @@ fiExpr to_drop (_, AnnNote InlineCall expr) -- the the call it annotates mkCoLets' to_drop (Note InlineCall (fiExpr [] expr)) +fiExpr to_drop (_, AnnNote InlineMe expr) + = -- Ditto... don't float anything into an INLINE expression + mkCoLets' to_drop (Note InlineMe (fiExpr [] expr)) + fiExpr to_drop (_, AnnNote note@(Coerce _ _) expr) = -- Just float in past coercion Note note (fiExpr to_drop expr) @@ -216,12 +222,12 @@ let w = ... in { let v = ... w ... - in ... w ... + in ... v .. w ... } \end{verbatim} Look at the inner \tr{let}. As \tr{w} is used in both the bind and body of the inner let, we could panic and leave \tr{w}'s binding where -it is. But \tr{v} is floatable into the body of the inner let, and +it is. But \tr{v} is floatable further into the body of the inner let, and {\em then} \tr{w} will also be only in the body of that inner let. So: rather than drop \tr{w}'s binding here, we add it onto the list of @@ -229,13 +235,19 @@ things to drop in the outer let's body, and let nature take its course. \begin{code} -fiExpr to_drop (_,AnnLet (AnnNonRec id rhs) body) +fiExpr to_drop (_,AnnLet (AnnNonRec id rhs@(rhs_fvs, ann_rhs)) body) = fiExpr new_to_drop body where - rhs_fvs = freeVarsOf rhs body_fvs = freeVarsOf body - [shared_binds, rhs_binds, body_binds] = sepBindsByDropPoint [rhs_fvs, body_fvs] to_drop + final_body_fvs | noFloatIntoRhs ann_rhs + || isUnLiftedType (idType id) = body_fvs `unionVarSet` rhs_fvs + | otherwise = body_fvs + -- See commments with letrec below + -- No point in floating in only to float straight out again + -- Ditto ok-for-speculation unlifted RHSs + + [shared_binds, rhs_binds, body_binds] = sepBindsByDropPoint [rhs_fvs, final_body_fvs] to_drop new_to_drop = body_binds ++ -- the bindings used only in the body [(NonRec id rhs', rhs_fvs')] ++ -- the new binding itself @@ -253,7 +265,25 @@ fiExpr to_drop (_,AnnLet (AnnRec bindings) body) rhss_fvs = map freeVarsOf rhss body_fvs = freeVarsOf body - (shared_binds:body_binds:rhss_binds) = sepBindsByDropPoint (body_fvs:rhss_fvs) to_drop + -- Add to body_fvs the free vars of any RHS that has + -- a lambda at the top. This has the effect of making it seem + -- that such things are used in the body as well, and hence prevents + -- them getting floated in. The big idea is to avoid turning: + -- let x# = y# +# 1# + -- in + -- letrec f = \z. ...x#...f... + -- in ... + -- into + -- letrec f = let x# = y# +# 1# in \z. ...x#...f... in ... + -- + -- Because now we can't float the let out again, because a letrec + -- can't have unboxed bindings. + + final_body_fvs = foldr (unionVarSet . get_extras) body_fvs rhss + get_extras (rhs_fvs, rhs) | noFloatIntoRhs rhs = rhs_fvs + | otherwise = emptyVarSet + + (shared_binds:body_binds:rhss_binds) = sepBindsByDropPoint (final_body_fvs:rhss_fvs) to_drop new_to_drop = -- the bindings used only in the body body_binds ++ @@ -292,6 +322,11 @@ fiExpr to_drop (_, AnnCase scrut case_bndr alts) -- to get free vars of alt fi_alt to_drop (con, args, rhs) = (con, args, fiExpr to_drop rhs) + +noFloatIntoRhs (AnnNote InlineMe _) = True +noFloatIntoRhs (AnnLam _ _) = True +noFloatIntoRhs (AnnCon con _) = isDataCon con +noFloatIntoRhs other = False \end{code} diff --git a/ghc/compiler/simplCore/FloatOut.lhs b/ghc/compiler/simplCore/FloatOut.lhs index 659e7b2fb1..e4e47f757e 100644 --- a/ghc/compiler/simplCore/FloatOut.lhs +++ b/ghc/compiler/simplCore/FloatOut.lhs @@ -12,7 +12,7 @@ module FloatOut ( floatOutwards ) where import CoreSyn -import CmdLineOpts ( opt_D_verbose_core2core, opt_D_simplifier_stats ) +import CmdLineOpts ( opt_D_verbose_core2core, opt_D_dump_simpl_stats ) import ErrUtils ( dumpIfSet ) import CostCentre ( dupifyCC, CostCentre ) import Id ( Id ) @@ -91,7 +91,7 @@ floatOutwards us pgm let { (tlets, ntlets, lams) = get_stats (sum_stats fss) }; - dumpIfSet opt_D_simplifier_stats "FloatOut stats:" + dumpIfSet opt_D_dump_simpl_stats "FloatOut stats:" (hcat [ int tlets, ptext SLIT(" Lets floated to top level; "), int ntlets, ptext SLIT(" Lets floated elsewhere; from "), int lams, ptext SLIT(" Lambda groups")]); diff --git a/ghc/compiler/simplCore/LiberateCase.lhs b/ghc/compiler/simplCore/LiberateCase.lhs index a1bbe934e9..bb9a08f138 100644 --- a/ghc/compiler/simplCore/LiberateCase.lhs +++ b/ghc/compiler/simplCore/LiberateCase.lhs @@ -11,7 +11,7 @@ module LiberateCase ( liberateCase ) where import CmdLineOpts ( opt_D_verbose_core2core, opt_LiberateCaseThreshold ) import CoreLint ( beginPass, endPass ) import CoreSyn -import CoreUnfold ( calcUnfoldingGuidance, UnfoldingGuidance(..) ) +import CoreUnfold ( calcUnfoldingGuidance, couldBeSmallEnoughToInline ) import Var ( Id ) import VarEnv import Maybes @@ -209,9 +209,7 @@ libCaseBind env (Rec pairs) -- [May 98: all this is now handled by SimplCore.tidyCore] rhs_small_enough rhs - = case (calcUnfoldingGuidance lIBERATE_BOMB_SIZE rhs) of - UnfoldNever -> False - _ -> True -- we didn't BOMB, so it must be OK + = couldBeSmallEnoughToInline (calcUnfoldingGuidance lIBERATE_BOMB_SIZE rhs) lIBERATE_BOMB_SIZE = bombOutSize env \end{code} diff --git a/ghc/compiler/simplCore/MagicUFs.lhs b/ghc/compiler/simplCore/MagicUFs.lhs deleted file mode 100644 index 692209adaf..0000000000 --- a/ghc/compiler/simplCore/MagicUFs.lhs +++ /dev/null @@ -1,645 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 -% -\section[MagicUFs]{Magic unfoldings that the simplifier knows about} - -\begin{code} -module MagicUFs ( - MagicUnfoldingFun, -- absolutely abstract - - mkMagicUnfoldingFun, - applyMagicUnfoldingFun - ) where - -#include "HsVersions.h" - -import CoreSyn -import SimplMonad ( SimplM, SimplCont ) -import Type ( mkFunTys ) -import TysWiredIn ( mkListTy ) -import Unique ( Unique{-instances-} ) -import Util ( assoc, zipWith3Equal, nOfThem ) -import Panic ( panic ) -\end{code} - -%************************************************************************ -%* * -\subsection{Types, etc., for magic-unfolding functions} -%* * -%************************************************************************ - -\begin{code} -data MagicUnfoldingFun - = MUF ( SimplCont -> Maybe (SimplM CoreExpr)) - -- Just result, or Nothing -\end{code} - -Give us a value's @Unique@, we'll give you back the corresponding MUF. -\begin{code} -mkMagicUnfoldingFun :: Unique -> MagicUnfoldingFun - -mkMagicUnfoldingFun tag - = assoc "mkMagicUnfoldingFun" magic_UFs_table tag - -magic_UFs_table = panic "MagicUFs.magic_UFs_table:ToDo" -\end{code} - -Give us an MUF and stuff to apply it to, and we'll give you back the answer. - -\begin{code} -applyMagicUnfoldingFun - :: MagicUnfoldingFun - -> SimplCont - -> Maybe (SimplM CoreExpr) - -applyMagicUnfoldingFun (MUF fun) cont = fun cont -\end{code} - -%************************************************************************ -%* * -\subsection{The table of actual magic unfoldings} -%* * -%************************************************************************ - -\begin{code} -{- LATER: - -magic_UFs_table :: [(FAST_STRING, MagicUnfoldingFun)] - -magic_UFs_table - = [(SLIT("augment"), MUF augment_fun), - (SLIT("build"), MUF build_fun), - (SLIT("foldl"), MUF foldl_fun), - (SLIT("foldr"), MUF foldr_fun), - (SLIT("unpackFoldrPS__"), MUF unpack_foldr_fun), - (SLIT("unpackAppendPS__"), MUF unpack_append_fun)] -\end{code} - -%************************************************************************ -%* * -\subsubsection{Unfolding function for @append@} -%* * -%************************************************************************ - -\begin{code} --- First build, the way we express our lists. - -build_fun :: SimplEnv - -> [CoreArg] - -> Maybe (SimplM CoreExpr) -build_fun env [TypeArg ty,ValArg (VarArg e)] - | switchIsSet env SimplDoInlineFoldrBuild - = Just result - where - tyL = mkListTy ty - ourCons = CoTyApp (Var consDataCon) ty - ourNil = CoTyApp (Var nilDataCon) ty - - result = newIds [ mkFunTys [ty, tyL] tyL, tyL ] `thenSmpl` \ [c,n] -> - returnSmpl(Let (NonRec c ourCons) - (Let (NonRec n ourNil) - (App (App (CoTyApp (Var e) tyL) (VarArg c)) (VarArg n))) - --- ToDo: add `build' without an argument instance. --- This is strange, because of g's type. -build_fun env _ = ASSERT (not (switchIsSet env SimplDoInlineFoldrBuild)) - Nothing -\end{code} - -\begin{code} -augment_fun :: SimplEnv - -> [CoreArg] - -> Maybe (SimplM CoreExpr) - -augment_fun env [TypeArg ty,ValArg (VarArg e),ValArg nil] - | switchIsSet env SimplDoInlineFoldrBuild - = Just result - where - tyL = mkListTy ty - ourCons = CoTyApp (Var consDataCon) ty - result = newId (mkFunTys [ty, tyL] tyL) `thenSmpl` \ c -> - returnSmpl (Let (NonRec c ourCons) - (App (App (CoTyApp (Var e) tyL) (VarArg c)) nil)) --- ToDo: add `build' without an argument instance. --- This is strange, because of g's type. - -augment_fun env _ = ASSERT (not (switchIsSet env SimplDoInlineFoldrBuild)) - Nothing -\end{code} - -Now foldr, the way we consume lists. - -\begin{code} -foldr_fun :: SimplEnv - -> [CoreArg] - -> Maybe (SimplM CoreExpr) - -foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:rest_args) - | do_fb_red && isConsFun env arg_k && isNilForm env arg_z - -- foldr (:) [] ==> id - -- this transformation is *always* benificial - -- cf. foldr (:) [] (build g) == g (:) [] - -- with foldr (:) [] (build g) == build g - -- after unfolding build, they are the same thing. - = Just (tick Foldr_Cons_Nil `thenSmpl_` - newId (mkListTy ty1) `thenSmpl` \ x -> - returnSmpl({-trace "foldr (:) []"-} (mkGenApp (Lam x (Var x)) rest_args)) - ) - where - do_fb_red = switchIsSet env SimplDoFoldrBuild - -foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list:rest_args) - | do_fb_red && isNilForm env arg_list - -- foldr f z [] = z - -- again another short cut, helps with unroling of constant lists - = Just (tick Foldr_Nil `thenSmpl_` - returnSmpl (argToExpr arg_z) - ) - - | do_fb_red && arg_list_isBuildForm - -- foldr k z (build g) ==> g k z - -- this next line *is* the foldr/build rule proper. - = Just (tick FoldrBuild `thenSmpl_` - returnSmpl (mkGenApp (Var g) (TypeArg ty2:ValArg arg_k:ValArg arg_z:rest_args)) - ) - - | do_fb_red && arg_list_isAugmentForm - -- foldr k z (augment g h) ==> let v = foldr k z h in g k v - -- this next line *is* the foldr/augment rule proper. - = Just (tick FoldrAugment `thenSmpl_` - newId ty2 `thenSmpl` \ v -> - returnSmpl ( - Let (NonRec v (mkGenApp (Var foldrId) - [TypeArg ty1,TypeArg ty2, - ValArg arg_k, - ValArg arg_z, - ValArg h])) - (mkGenApp (Var g') (TypeArg ty2:ValArg arg_k:ValArg (VarArg v):rest_args))) - ) - - | do_fb_red && arg_list_isListForm - -- foldr k z (a:b:c:rest) = - -- (\ f -> f a (f b (f c (foldr f z rest)))) k rest_args - -- NB: 'k' is used just one by foldr, but 'f' is used many - -- times inside the list structure. This means that - -- 'f' needs to be inside a lambda, to make sure the simplifier - -- realises this. - -- - -- The structure of - -- f a (f b (f c (foldr f z rest))) - -- in core becomes: - -- let ele_1 = foldr f z rest - -- ele_2 = f c ele_1 - -- ele_3 = f b ele_2 - -- in f a ele_3 - -- - = Just (tick Foldr_List `thenSmpl_` - newIds ( - mkFunTys [ty1, ty2] ty2 : - nOfThem (length the_list) ty2 - ) `thenSmpl` \ (f_id:ele_id1:ele_ids) -> - let - fst_bind = NonRec - ele_id1 - (mkGenApp (Var foldrId) - [TypeArg ty1,TypeArg ty2, - ValArg (VarArg f_id), - ValArg arg_z, - ValArg the_tl]) - rest_binds = zipWith3Equal "Foldr:rest_binds" - (\ e v e' -> NonRec e (mkRhs v e')) - ele_ids - (reverse (tail the_list)) - (init (ele_id1:ele_ids)) - mkRhs v e = App (App (Var f_id) v) (VarArg e) - core_list = foldr - Let - (mkRhs (head the_list) (last (ele_id1:ele_ids))) - (fst_bind:rest_binds) - in - returnSmpl (mkGenApp (Lam f_id core_list) (ValArg arg_k:rest_args)) - ) - - - -- - - | do_fb_red && arg_list_isStringForm -- ok, its a string! - -- foldr f z "foo" => unpackFoldrPS__ f z "foo"# - = Just (tick Str_FoldrStr `thenSmpl_` - returnSmpl (mkGenApp (Var unpackCStringFoldrId) - (TypeArg ty2: - ValArg (LitArg (MachStr str_val)): - ValArg arg_k: - ValArg arg_z: - rest_args)) - ) - where - do_fb_red = switchIsSet env SimplDoFoldrBuild - - arg_list_isStringForm = maybeToBool stringForm - stringForm = getStringForm env arg_list - (Just str_val) = stringForm - - arg_list_isBuildForm = maybeToBool buildForm - buildForm = getBuildForm env arg_list - (Just g) = buildForm - - arg_list_isAugmentForm = maybeToBool augmentForm - augmentForm = getAugmentForm env arg_list - (Just (g',h)) = augmentForm - - arg_list_isListForm = maybeToBool listForm - listForm = getListForm env arg_list - (Just (the_list,the_tl)) = listForm -{- - arg_list_isAppendForm = maybeToBool appendForm - appendForm = getAppendForm env arg_list - (Just (xs,ys)) = appendForm --} - -foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:rest_args) - | doing_inlining && isConsFun env arg_k && not dont_fold_back_append - -- foldr (:) z xs = xs ++ z - = Just (tick Foldr_Cons `thenSmpl_` - newIds [ty2,mkListTy ty1] `thenSmpl` \ [z,x] -> - returnSmpl (mkGenApp - (Lam z (Lam x (mkGenApp - (Var appendId) [ - TypeArg ty1, - ValArg (VarArg x), - ValArg (VarArg z)])) - rest_args)) - ) - - | doing_inlining && (isInterestingArg env arg_k - || isConsFun env arg_k) - -- foldr k args = - -- (\ f z xs -> - -- letrec - -- h x = case x of - -- [] -> z - -- (a:b) -> f a (h b) - -- in - -- h xs) k args - -- --- tick FoldrInline `thenSmpl_` - = Just (newIds [ - ty1, -- a :: t1 - mkListTy ty1, -- b :: [t1] - ty2, -- v :: t2 - mkListTy ty1, -- x :: t1 - mkFunTys [mkListTy ty1] ty2, - -- h :: [t1] -> t2 - mkFunTys [ty1, ty2] ty2, - -- f - ty2, -- z - mkListTy ty1 -- xs - ] `thenSmpl` \ [a,b,v,x,h,f,z,xs] -> - let - h_rhs = (Lam x (Case (Var x) - (AlgAlts - [(nilDataCon,[],argToExpr (VarArg z)), - (consDataCon,[a,b],body)] - NoDefault))) - body = Let (NonRec v (App (Var h) (VarArg b))) - (App (App (argToExpr (VarArg f)) - (VarArg a)) - (VarArg v)) - in - returnSmpl ( - mkGenApp - (Lam f (Lam z (Lam xs - (Let (Rec [(h,h_rhs)]) - (App (Var h) (VarArg xs)))))) - (ValArg arg_k:rest_args)) - ) - where - doing_inlining = switchIsSet env SimplDoInlineFoldrBuild - dont_fold_back_append = switchIsSet env SimplDontFoldBackAppend - -foldr_fun _ _ = Nothing - -isConsFun :: SimplEnv -> CoreArg -> Bool -isConsFun env (VarArg v) - = case lookupUnfolding env v of - SimpleUnfolding _ (Lam (x,_) (Lam (y,_) (Con con tys [VarArg x',VarArg y']))) _ - | con == consDataCon && x==x' && y==y' - -> ASSERT ( length tys == 1 ) True - _ -> False -isConsFun env _ = False - -isNilForm :: SimplEnv -> CoreArg -> Bool -isNilForm env (VarArg v) - = case lookupUnfolding env v of - SimpleUnfolding _ (CoTyApp (Var id) _) _ | id == nilDataCon -> True - SimpleUnfolding _ (Lit (NoRepStr s)) _ | _NULL_ s -> True - _ -> False -isNilForm env _ = False - -getBuildForm :: SimplEnv -> CoreArg -> Maybe Id -getBuildForm env (VarArg v) - = case lookupUnfolding env v of - SimpleUnfolding False _ _ _ -> Nothing - -- not allowed to inline :-( - SimpleUnfolding _ (App (CoTyApp (Var bld) _) (VarArg g)) _ - | bld == buildId -> Just g - SimpleUnfolding _ (App (App (CoTyApp (Var bld) _) - (VarArg g)) h) _ - | bld == augmentId && isNilForm env h -> Just g - _ -> Nothing -getBuildForm env _ = Nothing - - - -getAugmentForm :: SimplEnv -> CoreArg -> Maybe (Id,CoreArg) -getAugmentForm env (VarArg v) - = case lookupUnfolding env v of - SimpleUnfolding False _ _ _ -> Nothing - -- not allowed to inline :-( - SimpleUnfolding _ (App (App (CoTyApp (Var bld) _) - (VarArg g)) h) _ - | bld == augmentId -> Just (g,h) - _ -> Nothing -getAugmentForm env _ = Nothing - -getStringForm :: SimplEnv -> CoreArg -> Maybe FAST_STRING -getStringForm env (LitArg (NoRepStr str)) = Just str -getStringForm env _ = Nothing - -{- -getAppendForm :: SimplEnv -> CoreArg -> Maybe (GenCoreAtom Id,GenCoreAtom Id) -getAppendForm env (VarArg v) = - case lookupUnfolding env v of - SimpleUnfolding False _ _ _ -> Nothing -- not allowed to inline :-( - SimpleUnfolding _ (App (App (App (CoTyApp (CoTyApp (Var fld) _) _) con) ys) xs) _ - | fld == foldrId && isConsFun env con -> Just (xs,ys) - _ -> Nothing -getAppendForm env _ = Nothing --} - --- --- this gets a list of the form a : b : c : d and returns ([a,b,c],d) --- it natuarally follows that [a,b,c] => ([a,b,c],e), where e = [] --- - -getListForm - :: SimplEnv - -> CoreArg - -> Maybe ([CoreArg],CoreArg) -getListForm env (VarArg v) - = case lookupUnfolding env v of - SimpleUnfolding _ (Con id [ty_arg,head,tail]) _ - | id == consDataCon -> - case getListForm env tail of - Nothing -> Just ([head],tail) - Just (lst,new_tail) -> Just (head:lst,new_tail) - _ -> Nothing -getListForm env _ = Nothing - -isInterestingArg :: SimplEnv -> CoreArg -> Bool -isInterestingArg env (VarArg v) - = case lookupUnfolding env v of - SimpleUnfolding False _ _ UnfoldNever -> False - SimpleUnfolding _ exp guide -> True - _ -> False -isInterestingArg env _ = False - -foldl_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list:rest_args) - | do_fb_red && isNilForm env arg_list - -- foldl f z [] = z - -- again another short cut, helps with unroling of constant lists - = Just (tick Foldl_Nil `thenSmpl_` - returnSmpl (argToExpr arg_z) - ) - - | do_fb_red && arg_list_isBuildForm - -- foldl t1 t2 k z (build t3 g) ==> - -- let c {- INLINE -} = \ b g' a -> g' (f a b) - -- n {- INLINE -} = \ a -> a - -- in g t1 c n z - -- this next line *is* the foldr/build rule proper. - = Just(tick FoldlBuild `thenSmpl_` - -- c :: t2 -> (t1 -> t1) -> t1 -> t1 - -- n :: t1 -> t1 - newIds [ - {- pre_c -} mkFunTys [ty2, mkFunTys [ty1] ty1, ty1] ty1, - {- pre_n -} mkFunTys [ty1] ty1, - {- b -} ty2, - {- g' -} mkFunTys [ty1] ty1, - {- a -} ty1, - {- a' -} ty1, - {- t -} ty1 - ] `thenSmpl` \ [pre_c, - pre_n, - b, - g', - a, - a', - t] -> - - let - c = addInlinePragma pre_c - c_rhs = Lam b (Lam g' (Lam a - (Let (NonRec t (App (App (argToExpr arg_k) (VarArg a)) (VarArg b))) - (App (Var g') (VarArg t))))) - n = addInlinePragma pre_n - n_rhs = Lam a' (Var a') - in - returnSmpl (Let (NonRec c c_rhs) $ - Let (NonRec n n_rhs) $ - mkGenApp (Var g) - (TypeArg (mkFunTys [ty1] ty1):ValArg (VarArg c):ValArg (VarArg n) - :ValArg arg_z:rest_args)) - ) - - | do_fb_red && arg_list_isAugmentForm - -- foldl t1 t2 k z (augment t3 g h) ==> - -- let c {- INLINE -} = \ b g' a -> g' (f a b) - -- n {- INLINE -} = \ a -> a - -- r {- INLINE -} = foldr t2 (t1 -> t1) c n h - -- in g t1 c r z - -- this next line *is* the foldr/build rule proper. - = Just (tick FoldlAugment `thenSmpl_` - -- c :: t2 -> (t1 -> t1) -> t1 -> t1 - -- n :: t1 -> t1 - newIds [ - {- pre_c -} mkFunTys [ty2, mkFunTys [ty1] ty1, ty1] ty1, - {- pre_n -} mkFunTys [ty1] ty1, - {- pre_r -} mkFunTys [ty1] ty1, - {- b -} ty2, - {- g_ -} mkFunTys [ty1] ty1, - {- a -} ty1, - {- a' -} ty1, - {- t -} ty1 - ] `thenSmpl` \ [pre_c, - pre_n, - pre_r, - b, - g_, - a, - a', - t] -> - - let - c = addInlinePragma pre_c - c_rhs = Lam b (Lam g_ (Lam a - (Let (NonRec t (App (App (argToExpr arg_k) (VarArg a)) (VarArg b))) - (App (Var g_) (VarArg t))))) - n = addInlinePragma pre_n - n_rhs = Lam a' (Var a') - r = addInlinePragma pre_r - r_rhs = mkGenApp (Var foldrId) - [TypeArg ty2,TypeArg (mkFunTys [ty1] ty1), - ValArg (VarArg c), - ValArg (VarArg n), - ValArg h] - in - returnSmpl (Let (NonRec c c_rhs) $ - Let (NonRec n n_rhs) $ - Let (NonRec r r_rhs) $ - mkGenApp (Var g') - (TypeArg (mkFunTys [ty1] ty1):ValArg (VarArg c):ValArg (VarArg r) - :ValArg arg_z:rest_args)) - ) - - | do_fb_red && arg_list_isListForm - -- foldl k z (a:b:c:rest) = - -- (\ f -> foldl f (f (f (f z a) b) c) rest) k rest_args - -- NB: 'k' is used just one by foldr, but 'f' is used many - -- times inside the list structure. This means that - -- 'f' needs to be inside a lambda, to make sure the simplifier - -- realises this. - -- - -- The structure of - -- foldl f (f (f (f z a) b) c) rest - -- f a (f b (f c (foldr f z rest))) - -- in core becomes: - -- let ele_1 = f z a - -- ele_2 = f ele_1 b - -- ele_3 = f ele_2 c - -- in foldl f ele_3 rest - -- - = Just (tick Foldl_List `thenSmpl_` - newIds ( - mkFunTys [ty1, ty2] ty1 : - nOfThem (length the_list) ty1 - ) `thenSmpl` \ (f_id:ele_ids) -> - let - rest_binds = zipWith3Equal "foldl:rest_binds" - (\ e v e' -> NonRec e (mkRhs v e')) - ele_ids -- :: [Id] - the_list -- :: [CoreArg] - (init (arg_z:map VarArg ele_ids)) -- :: [CoreArg] - mkRhs v e = App (App (Var f_id) e) v - - last_bind = mkGenApp (Var foldlId) - [TypeArg ty1,TypeArg ty2, - ValArg (VarArg f_id), - ValArg (VarArg (last ele_ids)), - ValArg the_tl] - core_list = foldr - Let - last_bind - rest_binds - in - returnSmpl (mkGenApp (Lam f_id core_list) - (ValArg arg_k:rest_args)) - ) - - where - do_fb_red = switchIsSet env SimplDoFoldrBuild - - arg_list_isAugmentForm = maybeToBool augmentForm - augmentForm = getAugmentForm env arg_list - (Just (g',h)) = augmentForm - - arg_list_isBuildForm = maybeToBool buildForm - buildForm = getBuildForm env arg_list - (Just g) = buildForm - - arg_list_isListForm = maybeToBool listForm - listForm = getListForm env arg_list - (Just (the_list,the_tl)) = listForm - -{- - arg_list_isAppendForm = maybeToBool appendForm - appendForm = getAppendForm env arg_list - (Just (xs,ys)) = appendForm --} - -foldl_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:rest_args) - | doing_inlining && (isInterestingArg env arg_k - || isConsFun env arg_k) - -- foldl k args = - -- (\ f z xs -> - -- letrec - -- h x r = case x of - -- [] -> r - -- (a:b) -> h b (f r a) - -- in - -- h xs z) k args - -- - = Just ( --- tick FoldrInline `thenSmpl_` - newIds [ - ty2, -- a :: t1 - mkListTy ty2, -- b :: [t1] - ty1, -- v :: t2 - mkListTy ty2, -- x :: t1 - mkFunTys [mkListTy ty2, ty1] ty1, - -- h :: [t2] -> t1 -> t1 - mkFunTys [ty1, ty2] ty1, - -- f - ty1, -- z - mkListTy ty2, -- xs - ty1 -- r - ] `thenSmpl` \ [a,b,v,x,h,f,z,xs,r] -> - let - h_rhs = (Lam x (Lam r (Case (Var x)) - (AlgAlts - [(nilDataCon,[],argToExpr (VarArg r)), - (consDataCon,[a,b],body)] - NoDefault))) - body = Let (NonRec v (App (App (Var f) (VarArg r)) - (VarArg a))) - (App (App (argToExpr (VarArg h)) - (VarArg b)) - (VarArg v)) - in - returnSmpl ( - (mkGenApp - (Lam f (Lam z (Lam xs - (Let (Rec [(h,h_rhs)]) - (App (App (Var h) (VarArg xs)) - (VarArg z)))))) - (ValArg arg_k:rest_args)) - ) - where - doing_inlining = switchIsSet env SimplDoInlineFoldrBuild - -foldl_fun env _ = Nothing -\end{code} - - -\begin{code} --- --- Foldr unpackFoldr "str"# (:) stuff ==> unpackAppend "str"# --- -unpack_foldr_fun env [TypeArg ty,ValArg str,ValArg arg_k,ValArg arg_z] - | switchIsSet env SimplDoFoldrBuild && isConsFun env arg_k - = Just (tick Str_UnpackCons `thenSmpl_` - returnSmpl (mkGenApp (Var unpackCStringAppendId) - [ValArg str, - ValArg arg_z]) - ) -unpack_foldr_fun env _ = Nothing - -unpack_append_fun env - [ValArg (LitArg (MachStr str_val)),ValArg arg_z] - | switchIsSet env SimplDoFoldrBuild && isNilForm env arg_z - = Just (tick Str_UnpackNil `thenSmpl_` - returnSmpl (Lit (NoRepStr str_val)) - ) -unpack_append_fun env _ = Nothing --} -\end{code} diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs index 002517297c..60f846d24d 100644 --- a/ghc/compiler/simplCore/OccurAnal.lhs +++ b/ghc/compiler/simplCore/OccurAnal.lhs @@ -13,7 +13,8 @@ core expression with (hopefully) improved usage information. \begin{code} module OccurAnal ( occurAnalyseBinds, occurAnalyseExpr, occurAnalyseGlobalExpr, - markBinderInsideLambda + markBinderInsideLambda, tagBinders, + UsageDetails ) where #include "HsVersions.h" @@ -21,28 +22,28 @@ module OccurAnal ( import BinderInfo import CmdLineOpts ( SimplifierSwitch(..) ) import CoreSyn -import CoreUtils ( exprIsTrivial, idSpecVars ) +import CoreFVs ( idRuleVars ) +import CoreUtils ( exprIsTrivial ) import Const ( Con(..), Literal(..) ) -import Id ( idWantsToBeINLINEd, isSpecPragmaId, +import Id ( isSpecPragmaId, getInlinePragma, setInlinePragma, - omitIfaceSigForId, + isExportedId, modifyIdInfo, idInfo, getIdSpecialisation, idType, idUnique, Id ) -import IdInfo ( InlinePragInfo(..), OccInfo(..) ) -import SpecEnv ( isEmptySpecEnv ) +import IdInfo ( InlinePragInfo(..), OccInfo(..), copyIdInfo ) import VarSet import VarEnv -import PrelInfo ( noRepStrIds, noRepIntegerIds ) -import Name ( isExported, isLocallyDefined ) +import ThinAir ( noRepStrIds, noRepIntegerIds ) +import Name ( isLocallyDefined ) import Type ( splitFunTy_maybe, splitForAllTys ) import Maybes ( maybeToBool ) import Digraph ( stronglyConnCompR, SCC(..) ) -import Unique ( u2i ) +import Unique ( u2i, buildIdKey, foldrIdKey, runSTRepIdKey, augmentIdKey ) import UniqFM ( keysUFM ) -import Util ( zipWithEqual, mapAndUnzip ) +import Util ( zipWithEqual, mapAndUnzip, count ) import Outputable \end{code} @@ -56,23 +57,6 @@ import Outputable Here's the externally-callable interface: \begin{code} -occurAnalyseBinds - :: (SimplifierSwitch -> Bool) - -> [CoreBind] - -> [CoreBind] - -occurAnalyseBinds simplifier_sw_chkr binds - = binds' - where - (_, _, binds') = occAnalTop initial_env binds - - initial_env = OccEnv (simplifier_sw_chkr IgnoreINLINEPragma) - (\id -> isLocallyDefined id) -- Anything local is interesting - emptyVarSet -\end{code} - - -\begin{code} occurAnalyseExpr :: (Id -> Bool) -- Tells if a variable is interesting -> CoreExpr -> (IdEnv BinderInfo, -- Occ info for interesting free vars @@ -81,9 +65,7 @@ occurAnalyseExpr :: (Id -> Bool) -- Tells if a variable is interesting occurAnalyseExpr interesting expr = occAnal initial_env expr where - initial_env = OccEnv False {- Do not ignore INLINE Pragma -} - interesting - emptyVarSet + initial_env = OccEnv interesting emptyVarSet [] occurAnalyseGlobalExpr :: CoreExpr -> CoreExpr occurAnalyseGlobalExpr expr @@ -115,7 +97,7 @@ Without this we never get rid of the exp = loc thing. This save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and makes strictness information propagate better. -This used to happen in the final phase, but its tidier to do it here. +This used to happen in the final phase, but it's tidier to do it here. If more than one exported thing is equal to a local thing (i.e., the @@ -147,81 +129,79 @@ and it's dangerous to do this fiddling in STG land because we might elminate a binding that's mentioned in the unfolding for something. - \begin{code} -occAnalTop :: OccEnv -- What's in scope - -> [CoreBind] - -> (IdEnv BinderInfo, -- Occurrence info - IdEnv Id, -- Indirection elimination info - [CoreBind] - ) - -occAnalTop env [] = (emptyDetails, emptyVarEnv, []) - --- Special case for eliminating indirections --- Note: it's a shortcoming that this only works for --- non-recursive bindings. Elminating indirections --- makes perfect sense for recursive bindings too, but --- it's more complicated to implement, so I haven't done so - -occAnalTop env (bind : binds) - = case bind of - NonRec exported_id (Var local_id) | shortMeOut ind_env exported_id local_id - -> -- Aha! An indirection; let's eliminate it! - (scope_usage, ind_env', binds') +occurAnalyseBinds :: [CoreBind] -> [CoreBind] + +occurAnalyseBinds binds + = binds' + where + (_, _, binds') = go initialTopEnv binds + + go :: OccEnv -> [CoreBind] + -> (UsageDetails, -- Occurrence info + IdEnv Id, -- Indirection elimination info + [CoreBind]) + + go env [] = (emptyDetails, emptyVarEnv, []) + + go env (bind : binds) + = let + new_env = env `addNewCands` (bindersOf bind) + (scope_usage, ind_env, binds') = go new_env binds + (final_usage, new_binds) = occAnalBind env (zapBind ind_env bind) scope_usage + -- NB: I zap before occur-analysing, so + -- I don't need to worry about getting the + -- occ info on the new bindings right. + in + case bind of + NonRec exported_id (Var local_id) + | shortMeOut ind_env exported_id local_id + -- Special case for eliminating indirections + -- Note: it's a shortcoming that this only works for + -- non-recursive bindings. Elminating indirections + -- makes perfect sense for recursive bindings too, but + -- it's more complicated to implement, so I haven't done so + -> (scope_usage, ind_env', binds') where ind_env' = extendVarEnv ind_env local_id exported_id - other -> -- Ho ho! The normal case + other -> -- Ho ho! The normal case (final_usage, ind_env, new_binds ++ binds') - where - (final_usage, new_binds) = occAnalBind env (zap_bind bind) scope_usage - where - new_env = env `addNewCands` (bindersOf bind) - (scope_usage, ind_env, binds') = occAnalTop new_env binds - - -- Deal with any indirections - zap_bind (NonRec bndr rhs) - | bndr `elemVarEnv` ind_env = Rec (zap (bndr,rhs)) - -- The Rec isn't strictly necessary, but it's convenient - zap_bind (Rec pairs) - | or [id `elemVarEnv` ind_env | (id,_) <- pairs] = Rec (concat (map zap pairs)) - - zap_bind bind = bind + +initialTopEnv = OccEnv isLocallyDefined -- Anything local is interesting + emptyVarSet + [] - zap pair@(bndr,rhs) = case lookupVarEnv ind_env bndr of - Nothing -> [pair] - Just exported_id -> [(bndr, Var exported_id), - (exported_id, rhs)] +-- Deal with any indirections +zapBind ind_env (NonRec bndr rhs) + | bndr `elemVarEnv` ind_env = Rec (zap ind_env (bndr,rhs)) + -- The Rec isn't strictly necessary, but it's convenient +zapBind ind_env (Rec pairs) + | or [id `elemVarEnv` ind_env | (id,_) <- pairs] = Rec (concat (map (zap ind_env) pairs)) + +zapBind ind_env bind = bind + +zap ind_env pair@(bndr,rhs) + = case lookupVarEnv ind_env bndr of + Nothing -> [pair] + Just exported_id -> [(bndr, Var exported_id), + (exported_id_w_info, rhs)] + where + exported_id_w_info = modifyIdInfo (copyIdInfo (idInfo bndr)) exported_id + -- See notes with copyIdInfo about propagating IdInfo from + -- one to t'other + shortMeOut ind_env exported_id local_id - = isExported exported_id && -- Only if this is exported + = isExportedId exported_id && -- Only if this is exported isLocallyDefined local_id && -- Only if this one is defined in this -- module, so that we *can* change its -- binding to be the exported thing! - not (isExported local_id) && -- Only if this one is not itself exported, + not (isExportedId local_id) && -- Only if this one is not itself exported, -- since the transformation will nuke it - not (omitIfaceSigForId local_id) && -- Don't do the transformation if rhs_id is - -- something like a constructor, whose - -- definition is implicitly exported and - -- which must not vanish. - -- To illustrate the preceding check consider - -- data T = MkT Int - -- mkT = MkT - -- f x = MkT (x+1) - -- Here, we'll make a local, non-exported, defn for MkT, and without the - -- above condition we'll transform it to: - -- mkT = \x. MkT [x] - -- f = \y. mkT (y+1) - -- This is bad because mkT will get the IdDetails of MkT, and won't - -- be exported. Also the code generator won't make a definition for - -- the MkT constructor. - -- Slightly gruesome, this. - - not (local_id `elemVarEnv` ind_env) -- Only if not already substituted for \end{code} @@ -468,21 +448,20 @@ reOrderRec env (CyclicSCC (bind : binds)) score :: Node Details2 -> Int -- Higher score => less likely to be picked as loop breaker score ((bndr, rhs), _, _) | exprIsTrivial rhs && - not (isExported bndr) = 3 -- Practically certain to be inlined - | inlineCandidate bndr = 3 -- Likely to be inlined + not (isExportedId bndr) = 3 -- Practically certain to be inlined + | inlineCandidate bndr rhs = 3 -- Likely to be inlined | not_fun_ty (idType bndr) = 2 -- Data types help with cases - | not (isEmptySpecEnv (getIdSpecialisation bndr)) = 1 - -- Avoid things with a SpecEnv; we'd like - -- to take advantage of the SpecEnv in the subsequent bindings + | not (isEmptyCoreRules (getIdSpecialisation bndr)) = 1 + -- Avoid things with specialisations; we'd like + -- to take advantage of them in the subsequent bindings | otherwise = 0 - inlineCandidate :: Id -> Bool - inlineCandidate id - = case getInlinePragma id of - IWantToBeINLINEd -> True - IMustBeINLINEd -> True - ICanSafelyBeINLINEd _ _ -> True - other -> False + inlineCandidate :: Id -> CoreExpr -> Bool + inlineCandidate id (Note InlineMe _) = True + inlineCandidate id rhs = case getInlinePragma id of + IMustBeINLINEd -> True + ICanSafelyBeINLINEd _ _ -> True + other -> False -- Real example (the Enum Ordering instance from PrelBase): -- rec f = \ x -> case d of (p,q,r) -> p x @@ -509,43 +488,27 @@ ToDo: try using the occurrence info for the inline'd binder. [March 97] We do the same for atomic RHSs. Reason: see notes with reOrderRec. [June 98, SLPJ] I've undone this change; I don't understand it. See notes with reOrderRec. -[March 98] A new wrinkle is that if the binder has specialisations inside -it then we count the specialised Ids as "extra rhs's". That way -the "parent" keeps the specialised "children" alive. If the parent -dies (because it isn't referenced any more), then the children will -die too unless they are already referenced directly. \begin{code} occAnalRhs :: OccEnv -> Id -> CoreExpr -- Binder and rhs -> (UsageDetails, CoreExpr) -{- DELETED SLPJ June 98: seems quite bogus to me -occAnalRhs env id (Var v) - | isCandidate env v - = (unitVarEnv v (markMany (funOccurrence 0)), Var v) - - | otherwise - = (emptyDetails, Var v) --} - occAnalRhs env id rhs - | idWantsToBeINLINEd id - = (mapVarEnv markMany total_usage, rhs') - - | otherwise - = (total_usage, rhs') - + = (final_usage, rhs') where (rhs_usage, rhs') = occAnal env rhs - lazy_rhs_usage = mapVarEnv markLazy rhs_usage - total_usage = foldVarSet add lazy_rhs_usage spec_ids - add v u = addOneOcc u v noBinderInfo -- Give a non-committal binder info - -- (i.e manyOcc) because many copies - -- of the specialised thing can appear - spec_ids = idSpecVars id -\end{code} + -- [March 98] A new wrinkle is that if the binder has specialisations inside + -- it then we count the specialised Ids as "extra rhs's". That way + -- the "parent" keeps the specialised "children" alive. If the parent + -- dies (because it isn't referenced any more), then the children will + -- die too unless they are already referenced directly. + + final_usage = foldVarSet add rhs_usage (idRuleVars id) + add v u = addOneOcc u v noBinderInfo -- Give a non-committal binder info + -- (i.e manyOcc) because many copies + -- of the specialised thing can appear \end{code} Expressions @@ -558,9 +521,19 @@ occAnal :: OccEnv occAnal env (Type t) = (emptyDetails, Type t) -occAnal env (Var v) - | isCandidate env v = (unitVarEnv v funOccZero, Var v) - | otherwise = (emptyDetails, Var v) +occAnal env (Var v) + = (var_uds, Var v) + where + var_uds | isCandidate env v = unitVarEnv v funOccZero + | otherwise = emptyDetails + + -- At one stage, I gathered the idRuleVars for v here too, + -- which in a way is the right thing to do. + -- But that went wrong right after specialisation, when + -- the *occurrences* of the overloaded function didn't have any + -- rules in them, so the *specialised* versions looked as if they + -- weren't used at all. + \end{code} We regard variables that occur as constructor arguments as "dangerousToDup": @@ -596,17 +569,14 @@ occAnal env expr@(Con (Literal lit) args) | otherwise = uds occAnal env (Con con args) - = case mapAndUnzip (occAnal env) args of { (arg_uds_s, args') -> + = case occAnalArgs env args of { (arg_uds, args') -> let - arg_uds = foldr combineUsageDetails emptyDetails arg_uds_s - -- We mark the free vars of the argument of a constructor as "many" -- This means that nothing gets inlined into a constructor argument -- position, which is what we want. Typically those constructor -- arguments are just variables, or trivial expressions. final_arg_uds = case con of DataCon _ -> mapVarEnv markMany arg_uds - PrimOp _ -> mapVarEnv markLazy arg_uds other -> arg_uds in (final_arg_uds, Con con args') @@ -614,6 +584,11 @@ occAnal env (Con con args) \end{code} \begin{code} +occAnal env (Note InlineMe body) + = case occAnal env body of { (usage, body') -> + (mapVarEnv markMany usage, Note InlineMe body') + } + occAnal env (Note note@(SCC cc) body) = case occAnal env body of { (usage, body') -> (mapVarEnv markInsideSCC usage, Note note body') @@ -626,12 +601,9 @@ occAnal env (Note note body) \end{code} \begin{code} -occAnal env (App fun arg) - = case occAnal env fun of { (fun_usage, fun') -> - case occAnal env arg of { (arg_usage, arg') -> - (fun_usage `combineUsageDetails` mapVarEnv markLazy arg_usage, App fun' arg') - }} - +occAnal env app@(App fun arg) + = occAnalApp env (collectArgs app) + -- Ignore type variables altogether -- (a) occurrences inside type lambdas only not marked as InsideLam -- (b) type variables not in environment @@ -651,15 +623,19 @@ occAnal env expr@(Lam x body) | isTyVar x -- Then, the simplifier is careful when partially applying lambdas. occAnal env expr@(Lam _ _) - = case occAnal (env `addNewCands` binders) body of { (body_usage, body') -> + = case occAnal (env_body `addNewCands` binders) body of { (body_usage, body') -> let (final_usage, tagged_binders) = tagBinders body_usage binders + really_final_usage = if linear then + final_usage + else + mapVarEnv markInsideLam final_usage in - (mapVarEnv markInsideLam final_usage, + (really_final_usage, mkLams tagged_binders body') } where - (binders, body) = collectBinders expr - + (binders, body) = collectBinders expr + (linear, env_body) = getCtxt env (count isId binders) occAnal env (Case scrut bndr alts) = case mapAndUnzip (occAnalAlt alt_env) alts of { (alts_usage_s, alts') -> @@ -679,8 +655,61 @@ occAnal env (Let bind body) (final_usage, mkLets new_binds body') }} where new_env = env `addNewCands` (bindersOf bind) + +occAnalArgs env args + = case mapAndUnzip (occAnal env) args of { (arg_uds_s, args') -> + (foldr combineUsageDetails emptyDetails arg_uds_s, args')} \end{code} +Applications are dealt with specially because we want +the "build hack" to work. + +\begin{code} +-- Hack for build, fold, runST +occAnalApp env (Var fun, args) + = case args_stuff of { (args_uds, args') -> + let + final_uds = fun_uds `combineUsageDetails` args_uds + in + (final_uds, mkApps (Var fun) args') } + where + fun_uniq = idUnique fun + + fun_uds | isCandidate env fun = unitVarEnv fun funOccZero + | otherwise = emptyDetails + + args_stuff | fun_uniq == buildIdKey = appSpecial env 2 [True,True] args + | fun_uniq == augmentIdKey = appSpecial env 2 [True,True] args + | fun_uniq == foldrIdKey = appSpecial env 3 [False,True] args + | fun_uniq == runSTRepIdKey = appSpecial env 2 [True] args + | otherwise = occAnalArgs env args + +occAnalApp env (fun, args) + = case occAnal env fun of { (fun_uds, fun') -> + case occAnalArgs env args of { (args_uds, args') -> + let + final_uds = fun_uds `combineUsageDetails` args_uds + in + (final_uds, mkApps fun' args') }} + +appSpecial :: OccEnv -> Int -> CtxtTy -> [CoreExpr] -> (UsageDetails, [CoreExpr]) +appSpecial env n ctxt args + = go n args + where + go n [] = (emptyDetails, []) -- Too few args + + go 1 (arg:args) -- The magic arg + = case occAnal (setCtxt env ctxt) arg of { (arg_uds, arg') -> + case occAnalArgs env args of { (args_uds, args') -> + (combineUsageDetails arg_uds args_uds, arg':args') }} + + go n (arg:args) + = case occAnal env arg of { (arg_uds, arg') -> + case go (n-1) args of { (args_uds, args') -> + (combineUsageDetails arg_uds args_uds, arg':args') }} +\end{code} + + Case alternatives ~~~~~~~~~~~~~~~~~ \begin{code} @@ -700,29 +729,44 @@ occAnalAlt env (con, bndrs, rhs) %************************************************************************ \begin{code} -data OccEnv = - OccEnv - Bool -- IgnoreINLINEPragma flag - -- False <=> OK to use INLINEPragma information - -- True <=> ignore INLINEPragma information +-- We gather inforamtion for variables that are either +-- (a) in scope or +-- (b) interesting - (Id -> Bool) -- Tells whether an Id occurrence is interesting, - -- given the set of in-scope variables +data OccEnv = + OccEnv (Id -> Bool) -- Tells whether an Id occurrence is interesting, + IdSet -- In-scope Ids + CtxtTy -- Tells about linearity - IdSet -- In-scope Ids +type CtxtTy = [Bool] + -- [] No info + -- + -- True:ctxt Analysing a function-valued expression that will be + -- applied just once + -- + -- False:ctxt Analysing a function-valued expression that may + -- be applied many times; but when it is, + -- the CtxtTy inside applies +isCandidate :: OccEnv -> Id -> Bool +isCandidate (OccEnv ifun cands _) id = id `elemVarSet` cands || ifun id addNewCands :: OccEnv -> [Id] -> OccEnv -addNewCands (OccEnv ip ifun cands) ids - = OccEnv ip ifun (cands `unionVarSet` mkVarSet ids) +addNewCands (OccEnv ifun cands ctxt) ids + = OccEnv ifun (cands `unionVarSet` mkVarSet ids) ctxt addNewCand :: OccEnv -> Id -> OccEnv -addNewCand (OccEnv ip ifun cands) id - = OccEnv ip ifun (extendVarSet cands id) +addNewCand (OccEnv ifun cands ctxt) id + = OccEnv ifun (extendVarSet cands id) ctxt -isCandidate :: OccEnv -> Id -> Bool -isCandidate (OccEnv _ ifun cands) id = id `elemVarSet` cands || ifun id +setCtxt :: OccEnv -> CtxtTy -> OccEnv +setCtxt (OccEnv ifun cands _) ctxt = OccEnv ifun cands ctxt +getCtxt :: OccEnv -> Int -> (Bool, OccEnv) -- True <=> this is a linear lambda + -- The Int is the number of lambdas +getCtxt env@(OccEnv ifun cands []) n = (False, env) +getCtxt (OccEnv ifun cands ctxt) n = (and (take n ctxt), OccEnv ifun cands (drop n ctxt)) + -- Only return True if *all* the lambdas are linear type UsageDetails = IdEnv BinderInfo -- A finite map from ids to their usage @@ -745,9 +789,7 @@ emptyDetails = (emptyVarEnv :: UsageDetails) unitDetails id info = (unitVarEnv id info :: UsageDetails) usedIn :: Id -> UsageDetails -> Bool -v `usedIn` details = isExported v - || v `elemVarEnv` details - || isSpecPragmaId v +v `usedIn` details = isExportedId v || v `elemVarEnv` details tagBinders :: UsageDetails -- Of scope -> [Id] -- Binders @@ -786,8 +828,6 @@ setBinderPrag usage bndr ICanSafelyBeINLINEd _ _ -> new_bndr -- from the previous iteration of IAmALoopBreaker -> new_bndr -- the occurrence analyser - IAmASpecPragmaId -> bndr -- Don't ever overwrite or drop these as dead - other | its_now_dead -> new_bndr -- Overwrite the others iff it's now dead | otherwise -> bndr @@ -802,7 +842,7 @@ setBinderPrag usage bndr new_prag = occInfoToInlinePrag occ_info occ_info - | isExported bndr = noBinderInfo + | isExportedId bndr = noBinderInfo -- Don't use local usage info for visible-elsewhere things -- But NB that we do set NoInlinePragma for exported things -- thereby nuking any IAmALoopBreaker from a previous pass. diff --git a/ghc/compiler/simplCore/SATMonad.lhs b/ghc/compiler/simplCore/SATMonad.lhs index 3982c8ac4e..0e75d9fdcd 100644 --- a/ghc/compiler/simplCore/SATMonad.lhs +++ b/ghc/compiler/simplCore/SATMonad.lhs @@ -35,7 +35,7 @@ import Type ( mkTyVarTy, mkSigmaTy, InstTyEnv(..) ) import MkId ( mkSysLocal ) -import Id ( idType, idName, mkUserId ) +import Id ( idType, idName, mkVanillaId ) import UniqSupply import Util @@ -139,7 +139,7 @@ newSATName id ty us env let new_name = mkCompoundName SLIT("$sat") unique (idName id) in - (mkUserId new_name ty, env) } + (mkVanillaId new_name ty, env) } getArgLists :: CoreExpr -> ([Arg Type],[Arg Id]) getArgLists expr diff --git a/ghc/compiler/simplCore/SetLevels.lhs b/ghc/compiler/simplCore/SetLevels.lhs index 10c6de626c..3b01473a5c 100644 --- a/ghc/compiler/simplCore/SetLevels.lhs +++ b/ghc/compiler/simplCore/SetLevels.lhs @@ -3,11 +3,21 @@ % \section{SetLevels} -We attach binding levels to Core bindings, in preparation for floating -outwards (@FloatOut@). + *************************** + Overview + *************************** + +* We attach binding levels to Core bindings, in preparation for floating + outwards (@FloatOut@). + +* We also let-ify many expressions (notably case scrutinees), so they + will have a fighting chance of being floated sensible. + +* We clone the binders of any floatable let-binding, so that when it is + floated out it will be unique. (This used to be done by the simplifier + but the latter now only ensures that there's no shadowing.) + -We also let-ify many applications (notably case scrutinees), so they -will have a fighting chance of being floated sensible. \begin{code} module SetLevels ( @@ -22,18 +32,16 @@ module SetLevels ( import CoreSyn -import CoreUtils ( coreExprType, exprIsTrivial, idFreeVars, exprIsBottom - ) -import FreeVars -- all of it +import CoreUtils ( coreExprType, exprIsTrivial, exprIsBottom ) +import CoreFVs -- all of it import Id ( Id, idType, mkSysLocal ) -import Var ( IdOrTyVar ) +import Var ( IdOrTyVar, Var, setVarUnique ) import VarEnv import VarSet import Type ( isUnLiftedType, mkTyVarTys, mkForAllTys, Type ) import VarSet import VarEnv -import UniqSupply ( initUs_, thenUs, returnUs, mapUs, mapAndUnzipUs, getUniqueUs, - mapAndUnzip3Us, UniqSM, UniqSupply ) +import UniqSupply import Maybes ( maybeToBool ) import Util ( zipWithEqual, zipEqual ) import Outputable @@ -96,6 +104,13 @@ incMinorLvl :: Level -> Level incMinorLvl Top = Level 0 1 incMinorLvl (Level major minor) = Level major (minor+1) +unTopify :: Type -> Level -> Level +unTopify ty lvl + | isUnLiftedType ty = case lvl of + Top -> Level 0 0 -- Unboxed floats can't go right + other -> lvl -- to the top + | otherwise = lvl + maxLvl :: Level -> Level -> Level maxLvl Top l2 = l2 maxLvl l1 Top = l1 @@ -130,25 +145,33 @@ instance Outputable Level where \end{code} \begin{code} -type LevelEnv = VarEnv Level +type LevelEnv = VarEnv (Var, Level) + -- We clone let-bound variables so that they are still + -- distinct when floated out; hence the Var in the range + +extendLvlEnv :: LevelEnv -> [(Var,Level)] -> LevelEnv + -- Used when *not* cloning +extendLvlEnv env prs = foldl add env prs + where + add env (v,l) = extendVarEnv env v (v,l) varLevel :: LevelEnv -> IdOrTyVar -> Level varLevel env v = case lookupVarEnv env v of - Just level -> level - Nothing -> tOP_LEVEL + Just (_,level) -> level + Nothing -> tOP_LEVEL maxIdLvl :: LevelEnv -> IdOrTyVar -> Level -> Level maxIdLvl env var lvl | isTyVar var = lvl | otherwise = case lookupVarEnv env var of - Just lvl' -> maxLvl lvl' lvl - Nothing -> lvl + Just (_,lvl') -> maxLvl lvl' lvl + Nothing -> lvl maxTyVarLvl :: LevelEnv -> IdOrTyVar -> Level -> Level maxTyVarLvl env var lvl | isId var = lvl | otherwise = case lookupVarEnv env var of - Just lvl' -> maxLvl lvl' lvl - Nothing -> lvl + Just (_,lvl') -> maxLvl lvl' lvl + Nothing -> lvl \end{code} %************************************************************************ @@ -200,25 +223,18 @@ lvlBind :: Level -> CoreBindWithFVs -> LvlM ([LevelledBind], LevelEnv) -lvlBind ctxt_lvl env (AnnNonRec name rhs) - = setFloatLevel (Just name) ctxt_lvl env rhs ty `thenLvl` \ (final_lvl, rhs') -> +lvlBind ctxt_lvl env (AnnNonRec bndr rhs) + = setFloatLevel (Just bndr) ctxt_lvl env rhs ty `thenLvl` \ (final_lvl, rhs') -> + cloneVar ctxt_lvl bndr `thenLvl` \ new_bndr -> let - new_env = extendVarEnv env name final_lvl + new_env = extendVarEnv env bndr (new_bndr,final_lvl) in - returnLvl ([NonRec (name, final_lvl) rhs'], new_env) + returnLvl ([NonRec (new_bndr, final_lvl) rhs'], new_env) where - ty = idType name + ty = idType bndr -lvlBind ctxt_lvl env (AnnRec pairs) - = decideRecFloatLevel ctxt_lvl env binders rhss `thenLvl` \ (final_lvl, extra_binds, rhss') -> - let - binders_w_lvls = binders `zip` repeat final_lvl - new_env = extendVarEnvList env binders_w_lvls - in - returnLvl (extra_binds ++ [Rec (zipEqual "lvlBind" binders_w_lvls rhss')], new_env) - where - (binders,rhss) = unzip pairs +lvlBind ctxt_lvl env (AnnRec pairs) = lvlRecBind ctxt_lvl env pairs \end{code} %************************************************************************ @@ -253,7 +269,9 @@ If there were another lambda in @r@'s rhs, it would get level-2 as well. \begin{code} lvlExpr _ _ (_, AnnType ty) = returnLvl (Type ty) -lvlExpr _ _ (_, AnnVar v) = returnLvl (Var v) +lvlExpr _ env (_, AnnVar v) = case lookupVarEnv env v of + Just (v',_) -> returnLvl (Var v') + Nothing -> returnLvl (Var v) lvlExpr ctxt_lvl env (_, AnnCon con args) = mapLvl (lvlExpr ctxt_lvl env) args `thenLvl` \ args' -> @@ -286,7 +304,7 @@ lvlExpr ctxt_lvl env (_, AnnLam bndr rhs) incd_lvl | bndr_is_id = incMajorLvl ctxt_lvl | otherwise = incMinorLvl ctxt_lvl lvld_bndrs = [(b,incd_lvl) | b <- (bndr:bndrs)] - new_env = extendVarEnvList env lvld_bndrs + new_env = extendLvlEnv env lvld_bndrs go (_, AnnLam bndr rhs) | bndr_is_id && isId bndr || bndr_is_tyvar && isTyVar bndr @@ -305,12 +323,12 @@ lvlExpr ctxt_lvl env (_, AnnCase expr case_bndr alts) where expr_type = coreExprType (deAnnotate expr) incd_lvl = incMinorLvl ctxt_lvl - alts_env = extendVarEnv env case_bndr incd_lvl + alts_env = extendVarEnv env case_bndr (case_bndr,incd_lvl) lvl_alt (con, bs, rhs) = let bs' = [ (b, incd_lvl) | b <- bs ] - new_env = extendVarEnvList alts_env bs' + new_env = extendLvlEnv alts_env bs' in lvlMFE incd_lvl new_env rhs `thenLvl` \ rhs' -> returnLvl (con, bs', rhs') @@ -403,10 +421,11 @@ setFloatLevel maybe_let_bound ctxt_lvl env expr@(expr_fvs, _) ty | not alreadyLetBound && (expr_is_trivial || expr_is_bottom || not will_float_past_lambda) + = -- Pin trivial non-let-bound expressions, -- or ones which aren't going anywhere useful lvlExpr ctxt_lvl env expr `thenLvl` \ expr' -> - returnLvl (ctxt_lvl, expr') + returnLvl (safe_ctxt_lvl, expr') {- SDM 7/98 The above case used to read (whnf_or_bottom || not will_float_past_lambda). @@ -420,13 +439,13 @@ the expr_is_trivial condition. = -- Process the expression with a new ctxt_lvl, obtained from -- the free vars of the expression itself lvlExpr expr_lvl env expr `thenLvl` \ expr' -> - returnLvl (expr_lvl, expr') + returnLvl (safe_expr_lvl, expr') | otherwise -- This will create a let anyway, even if there is no -- type variable to abstract, so we try to abstract anyway = abstractWrtTyVars offending_tyvars ty env lvl_after_ty_abstr expr `thenLvl` \ final_expr -> - returnLvl (expr_lvl, final_expr) + returnLvl (safe_expr_lvl, final_expr) -- OLD LIE: The body of the let, just a type application, isn't worth floating -- so pin it with ctxt_lvl -- The truth: better to give it expr_lvl in case it is pinning @@ -434,6 +453,9 @@ the expr_is_trivial condition. where alreadyLetBound = maybeToBool maybe_let_bound + safe_ctxt_lvl = unTopify ty ctxt_lvl + safe_expr_lvl = unTopify ty expr_lvl + fvs = case maybe_let_bound of Nothing -> expr_fvs Just id -> expr_fvs `unionVarSet` idFreeVars id @@ -485,7 +507,7 @@ abstractWrtTyVars offending_tyvars ty env lvl expr -- These defns are just like those in the TyLam case of lvlExpr incd_lvl = incMinorLvl lvl tyvar_lvls = [(tv,incd_lvl) | tv <- offending_tyvars] - new_env = extendVarEnvList env tyvar_lvls + new_env = extendLvlEnv env tyvar_lvls \end{code} Recursive definitions. We want to transform @@ -507,7 +529,7 @@ to let D in body where ab are the tyvars pinning the defn further in than it -need be, and D is a bunch of simple type applications: +need be, and D is a bunch of simple type applications: x1_cl = x1' ab ... @@ -525,55 +547,62 @@ but differ in their level numbers; here the ab are the newly-introduced type lambdas. \begin{code} -decideRecFloatLevel ctxt_lvl env ids rhss +lvlRecBind ctxt_lvl env pairs | ids_only_lvl `ltLvl` tyvars_only_lvl = -- Abstract wrt tyvars; -- offending_tyvars is definitely non-empty -- (I love the ASSERT to check this... WDP 95/02) let - incd_lvl = incMinorLvl ids_only_lvl - tyvars_w_lvl = [(var,incd_lvl) | var <- offending_tyvars] - ids_w_lvl = [(var,incd_lvl) | var <- ids] - new_env = extendVarEnvList env (tyvars_w_lvl ++ ids_w_lvl) + incd_lvl = incMinorLvl ids_only_lvl + tyvars_w_rhs_lvl = [(var,incd_lvl) | var <- offending_tyvars] + bndrs_w_rhs_lvl = [(var,incd_lvl) | var <- bndrs] + rhs_env = extendLvlEnv env (tyvars_w_rhs_lvl ++ bndrs_w_rhs_lvl) in - mapLvl (lvlExpr incd_lvl new_env) rhss `thenLvl` \ rhss' -> + mapLvl (lvlExpr incd_lvl rhs_env) rhss `thenLvl` \ rhss' -> mapLvl newLvlVar poly_tys `thenLvl` \ poly_vars -> + mapLvl (cloneVar ctxt_lvl) bndrs `thenLvl` \ new_bndrs -> let - ids_w_poly_vars = zipEqual "decideRec2" ids poly_vars - -- The "d_rhss" are the right-hand sides of "D" and "D'" -- in the documentation above d_rhss = [ mkTyApps (Var poly_var) offending_tyvar_tys | poly_var <- poly_vars] -- "local_binds" are "D'" in the documentation above - local_binds = zipWithEqual "SetLevels" NonRec ids_w_lvl d_rhss + local_binds = zipWithEqual "SetLevels" NonRec bndrs_w_rhs_lvl d_rhss - poly_var_rhss = [ mkLams tyvars_w_lvl (mkLets local_binds rhs') + poly_var_rhss = [ mkLams tyvars_w_rhs_lvl (mkLets local_binds rhs') | rhs' <- rhss' ] poly_binds = zipEqual "poly_binds" [(poly_var, ids_only_lvl) | poly_var <- poly_vars] poly_var_rhss + -- The new right-hand sides, just a type application, + -- aren't worth floating so pin it with ctxt_lvl + bndrs_w_lvl = new_bndrs `zip` repeat ctxt_lvl + new_env = extendVarEnvList env (bndrs `zip` bndrs_w_lvl) + + -- "d_binds" are the "D" in the documentation above + d_binds = zipWithEqual "SetLevels" NonRec bndrs_w_lvl d_rhss in - returnLvl (ctxt_lvl, [Rec poly_binds], d_rhss) - -- The new right-hand sides, just a type application, aren't worth floating - -- so pin it with ctxt_lvl + returnLvl (Rec poly_binds : d_binds, new_env) | otherwise = -- Let it float freely + mapLvl (cloneVar ctxt_lvl) bndrs `thenLvl` \ new_bndrs -> let - ids_w_lvls = ids `zip` repeat expr_lvl - new_env = extendVarEnvList env ids_w_lvls + bndrs_w_lvls = new_bndrs `zip` repeat expr_lvl + new_env = extendVarEnvList env (bndrs `zip` bndrs_w_lvls) in mapLvl (lvlExpr expr_lvl new_env) rhss `thenLvl` \ rhss' -> - returnLvl (expr_lvl, [], rhss') + returnLvl ([Rec (bndrs_w_lvls `zip` rhss')], new_env) where + (bndrs,rhss) = unzip pairs + -- Finding the free vars of the binding group is annoying - bind_fvs = (unionVarSets (map fst rhss) `unionVarSet` unionVarSets (map idFreeVars ids)) + bind_fvs = (unionVarSets (map fst rhss) `unionVarSet` unionVarSets (map idFreeVars bndrs)) `minusVarSet` - mkVarSet ids + mkVarSet bndrs ids_only_lvl = foldVarSet (maxIdLvl env) tOP_LEVEL bind_fvs tyvars_only_lvl = foldVarSet (maxTyVarLvl env) tOP_LEVEL bind_fvs @@ -584,8 +613,8 @@ decideRecFloatLevel ctxt_lvl env ids rhss | otherwise = ids_only_lvl `ltLvl` varLevel env var offending_tyvar_tys = mkTyVarTys offending_tyvars - tys = map idType ids - poly_tys = map (mkForAllTys offending_tyvars) tys + tys = map idType bndrs + poly_tys = map (mkForAllTys offending_tyvars) tys \end{code} %************************************************************************ @@ -601,15 +630,15 @@ initLvl = initUs_ thenLvl = thenUs returnLvl = returnUs mapLvl = mapUs -mapAndUnzipLvl = mapAndUnzipUs -mapAndUnzip3Lvl = mapAndUnzip3Us \end{code} -We create a let-binding for `interesting' (non-utterly-trivial) -applications, to give them a fighting chance of being floated. - \begin{code} newLvlVar :: Type -> LvlM Id newLvlVar ty = getUniqueUs `thenLvl` \ uniq -> returnUs (mkSysLocal SLIT("lvl") uniq ty) + +cloneVar :: Level -> Id -> LvlM Id +cloneVar Top v = returnUs v -- Don't clone top level things +cloneVar _ v = getUniqueUs `thenLvl` \ uniq -> + returnUs (setVarUnique v uniq) \end{code} diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index 181a38aa99..5eed5f9a84 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -9,30 +9,32 @@ module SimplCore ( core2core ) where #include "HsVersions.h" import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..), - SwitchResult, switchIsOn, - opt_D_dump_occur_anal, + SwitchResult(..), switchIsOn, intSwitchSet, + opt_D_dump_occur_anal, opt_D_dump_rules, opt_D_dump_simpl_iterations, - opt_D_simplifier_stats, - opt_D_dump_simpl, + opt_D_dump_simpl_stats, + opt_D_dump_simpl, opt_D_dump_rules, opt_D_verbose_core2core, opt_D_dump_occur_anal, opt_UsageSPOn, ) import CoreLint ( beginPass, endPass ) +import CoreTidy ( tidyCorePgm ) import CoreSyn +import Rules ( RuleBase, ProtoCoreRule(..), pprProtoCoreRule, prepareRuleBase, orphanRule ) +import CoreUnfold import PprCore ( pprCoreBindings ) import OccurAnal ( occurAnalyseBinds ) import CoreUtils ( exprIsTrivial, coreExprType ) -import Simplify ( simplBind ) -import SimplUtils ( etaCoreExpr, findDefault ) +import Simplify ( simplTopBinds, simplExpr ) +import SimplUtils ( etaCoreExpr, findDefault, simplBinders ) import SimplMonad -import CoreUnfold import Const ( Con(..), Literal(..), literalType, mkMachInt ) import ErrUtils ( dumpIfSet ) import FloatIn ( floatInwards ) import FloatOut ( floatOutwards ) -import Id ( Id, mkSysLocal, mkUserId, isBottomingId, - idType, setIdType, idName, idInfo, idDetails +import Id ( Id, mkSysLocal, mkVanillaId, isBottomingId, + idType, setIdType, idName, idInfo, setIdNoDiscard ) import IdInfo ( InlinePragInfo(..), specInfo, setSpecInfo, inlinePragInfo, setInlinePragInfo, @@ -42,7 +44,7 @@ import Demand ( wwLazy ) import VarEnv import VarSet import Module ( Module ) -import Name ( mkLocalName, tidyOccName, tidyTopName, initTidyOccEnv, isExported, +import Name ( mkLocalName, tidyOccName, tidyTopName, NamedThing(..), OccName ) import TyCon ( TyCon, isDataTyCon ) @@ -58,17 +60,15 @@ import TysWiredIn ( smallIntegerDataCon, isIntegerTy ) import LiberateCase ( liberateCase ) import SAT ( doStaticArgs ) import Specialise ( specProgram) -import SpecEnv ( specEnvToList, specEnvFromList ) import UsageSPInf ( doUsageSPInf ) import StrictAnal ( saBinds ) import WorkWrap ( wwTopBinds ) import CprAnalyse ( cprAnalyse ) -import Var ( TyVar, mkId ) import Unique ( Unique, Uniquable(..), - ratioTyConKey, mkUnique, incrUnique, initTidyUniques + ratioTyConKey ) -import UniqSupply ( UniqSupply, splitUniqSupply, uniqFromSupply ) +import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply, uniqFromSupply ) import Constants ( tARGET_MIN_INT, tARGET_MAX_INT ) import Util ( mapAccumL ) import SrcLoc ( noSrcLoc ) @@ -80,94 +80,159 @@ import Outputable import Ratio ( numerator, denominator ) \end{code} +%************************************************************************ +%* * +\subsection{The driver for the simplifier} +%* * +%************************************************************************ + \begin{code} core2core :: [CoreToDo] -- Spec of what core-to-core passes to do - -> Module -- Module name (profiling only) - -> [Class] -- Local classes - -> UniqSupply -- A name supply - -> [CoreBind] -- Input - -> IO [CoreBind] -- Result + -> [CoreBind] -- Binds in + -> [ProtoCoreRule] -- Rules + -> IO ([CoreBind], [ProtoCoreRule]) -core2core core_todos module_name classes us binds +core2core core_todos binds rules = do - let (us1, us23) = splitUniqSupply us - (us2, us3 ) = splitUniqSupply us23 + us <- mkSplitUniqSupply 's' + let (cp_us, us1) = splitUniqSupply us + (ru_us, ps_us) = splitUniqSupply us1 + + better_rules <- simplRules ru_us rules binds + + let (binds1, rule_base) = prepareRuleBase binds better_rules -- Do the main business - processed_binds <- doCorePasses us1 binds core_todos + (stats, processed_binds) <- doCorePasses zeroSimplCount cp_us binds1 + rule_base core_todos - -- Do the post-simplification business - post_simpl_binds <- doPostSimplification us2 processed_binds + dumpIfSet opt_D_dump_simpl_stats + "Grand total simplifier statistics" + (pprSimplCount stats) - -- Do the final tidy-up - final_binds <- tidyCorePgm us3 module_name classes post_simpl_binds + -- Do the post-simplification business + post_simpl_binds <- doPostSimplification ps_us processed_binds -- Return results - return final_binds + return (post_simpl_binds, filter orphanRule better_rules) + -doCorePasses us binds [] - = return binds +doCorePasses stats us binds irs [] + = return (stats, binds) -doCorePasses us binds (to_do : to_dos) +doCorePasses stats us binds irs (to_do : to_dos) = do let (us1, us2) = splitUniqSupply us - binds1 <- doCorePass us1 binds to_do - doCorePasses us2 binds1 to_dos - -doCorePass us binds (CoreDoSimplify sw_chkr) = _scc_ "Simplify" simplifyPgm sw_chkr us binds -doCorePass us binds CoreLiberateCase = _scc_ "LiberateCase" liberateCase binds -doCorePass us binds CoreDoFloatInwards = _scc_ "FloatInwards" floatInwards binds -doCorePass us binds CoreDoFullLaziness = _scc_ "CoreFloating" floatOutwards us binds -doCorePass us binds CoreDoStaticArgs = _scc_ "CoreStaticArgs" doStaticArgs us binds -doCorePass us binds CoreDoStrictness = _scc_ "CoreStranal" saBinds binds -doCorePass us binds CoreDoWorkerWrapper = _scc_ "CoreWorkWrap" wwTopBinds us binds -doCorePass us binds CoreDoSpecialising = _scc_ "Specialise" specProgram us binds -doCorePass us binds CoreDoUSPInf + (stats1, binds1) <- doCorePass us1 binds irs to_do + doCorePasses (stats `plusSimplCount` stats1) us2 binds1 irs to_dos + +doCorePass us binds rb (CoreDoSimplify sw_chkr) = _scc_ "Simplify" simplifyPgm rb sw_chkr us binds +doCorePass us binds rb CoreLiberateCase = _scc_ "LiberateCase" noStats (liberateCase binds) +doCorePass us binds rb CoreDoFloatInwards = _scc_ "FloatInwards" noStats (floatInwards binds) +doCorePass us binds rb CoreDoFullLaziness = _scc_ "FloatOutwards" noStats (floatOutwards us binds) +doCorePass us binds rb CoreDoStaticArgs = _scc_ "StaticArgs" noStats (doStaticArgs us binds) +doCorePass us binds rb CoreDoStrictness = _scc_ "Stranal" noStats (saBinds binds) +doCorePass us binds rb CoreDoWorkerWrapper = _scc_ "WorkWrap" noStats (wwTopBinds us binds) +doCorePass us binds rb CoreDoSpecialising = _scc_ "Specialise" noStats (specProgram us binds) +doCorePass us binds rb CoreDoCPResult = _scc_ "CPResult" noStats (cprAnalyse binds) +doCorePass us binds rb CoreDoPrintCore = _scc_ "PrintCore" noStats (printCore binds) +doCorePass us binds rb CoreDoUSPInf = _scc_ "CoreUsageSPInf" if opt_UsageSPOn then - doUsageSPInf us binds + noStats (doUsageSPInf us binds) else trace "WARNING: ignoring requested -fusagesp pass; requires -fusagesp-on" $ - return binds -doCorePass us binds CoreDoCPResult = _scc_ "CPResult" cprAnalyse binds -doCorePass us binds CoreDoPrintCore - = _scc_ "PrintCore" - do - putStr (showSDoc $ pprCoreBindings binds) - return binds + noStats (return binds) + +printCore binds = do dumpIfSet True "Print Core" + (pprCoreBindings binds) + return binds + +noStats thing = do { result <- thing; return (zeroSimplCount, result) } \end{code} %************************************************************************ %* * +\subsection{Dealing with rules} +%* * +%************************************************************************ + +We must do some gentle simplifiation on the template (but not the RHS) +of each rule. The case that forced me to add this was the fold/build rule, +which without simplification looked like: + fold k z (build (/\a. g a)) ==> ... +This doesn't match unless you do eta reduction on the build argument. + +\begin{code} +simplRules :: UniqSupply -> [ProtoCoreRule] -> [CoreBind] -> IO [ProtoCoreRule] +simplRules us rules binds + = do let (better_rules,_) = initSmpl sw_chkr us bind_vars black_list_all (mapSmpl simplRule rules) + + dumpIfSet opt_D_dump_rules + "Transformation rules" + (vcat (map pprProtoCoreRule better_rules)) + + return better_rules + where + black_list_all v = True -- This stops all inlining + sw_chkr any = SwBool False -- A bit bogus + + -- Boringly, we need to gather the in-scope set. + -- Typically this thunk won't even be force, but the test in + -- simpVar fails if it isn't right, and it might conceivably matter + bind_vars = foldr (unionVarSet . mkVarSet . bindersOf) emptyVarSet binds + + +simplRule rule@(ProtoCoreRule is_local id (Rule name bndrs args rhs)) + | not is_local + = returnSmpl rule -- No need to fiddle with imported rules + | otherwise + = simplBinders bndrs $ \ bndrs' -> + mapSmpl simplExpr args `thenSmpl` \ args' -> + simplExpr rhs `thenSmpl` \ rhs' -> + returnSmpl (ProtoCoreRule is_local id (Rule name bndrs' args' rhs')) +\end{code} + +%************************************************************************ +%* * \subsection{The driver for the simplifier} %* * %************************************************************************ \begin{code} -simplifyPgm :: (SimplifierSwitch -> SwitchResult) +simplifyPgm :: RuleBase + -> (SimplifierSwitch -> SwitchResult) -> UniqSupply - -> [CoreBind] -- Input - -> IO [CoreBind] -- New bindings + -> [CoreBind] -- Input + -> IO (SimplCount, [CoreBind]) -- New bindings -simplifyPgm sw_chkr us binds +simplifyPgm (imported_rule_ids, rule_lhs_fvs) + sw_chkr us binds = do { beginPass "Simplify"; - (termination_msg, it_count, counts, binds') <- iteration us 1 zeroSimplCount binds; + -- Glom all binds together in one Rec, in case any + -- transformations have introduced any new dependencies + let { recd_binds = [Rec (flattenBinds binds)] }; + + (termination_msg, it_count, counts_out, binds') <- iteration us 1 zeroSimplCount recd_binds; - dumpIfSet opt_D_simplifier_stats "Simplifier statistics" + dumpIfSet (opt_D_verbose_core2core && opt_D_dump_simpl_stats) + "Simplifier statistics" (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations", text "", - pprSimplCount counts]); + pprSimplCount counts_out]); endPass "Simplify" (opt_D_verbose_core2core && not opt_D_dump_simpl_iterations) - binds' + binds' ; + + return (counts_out, binds') } where - max_iterations = getSimplIntSwitch sw_chkr MaxSimplifierIterations - simpl_switch_is_on = switchIsOn sw_chkr + max_iterations = getSimplIntSwitch sw_chkr MaxSimplifierIterations + black_list_fn = blackListed rule_lhs_fvs (intSwitchSet sw_chkr SimplInlinePhase) core_iter_dump binds | opt_D_verbose_core2core = pprCoreBindings binds | otherwise = empty @@ -175,12 +240,15 @@ simplifyPgm sw_chkr us binds iteration us iteration_no counts binds = do { -- Occurrence analysis - let { tagged_binds = _scc_ "OccAnal" occurAnalyseBinds simpl_switch_is_on binds }; + let { tagged_binds = _scc_ "OccAnal" occurAnalyseBinds binds } ; + dumpIfSet opt_D_dump_occur_anal "Occurrence analysis" (pprCoreBindings tagged_binds); -- Simplify - let { (binds', counts') = initSmpl sw_chkr us1 (simplTopBinds tagged_binds); + let { (binds', counts') = initSmpl sw_chkr us1 imported_rule_ids + black_list_fn + (simplTopBinds tagged_binds); all_counts = counts `plusSimplCount` counts' } ; @@ -193,14 +261,19 @@ simplifyPgm sw_chkr us binds dumpIfSet opt_D_dump_simpl_iterations ("Simplifier iteration " ++ show iteration_no ++ " out of " ++ show max_iterations) - (vcat[pprSimplCount counts', - text "", - core_iter_dump binds']) ; + (pprSimplCount counts') ; + + if opt_D_dump_simpl_iterations then + endPass ("Simplifier iteration " ++ show iteration_no ++ " result") + opt_D_verbose_core2core + binds' + else + return [] ; -- Stop if we've run out of iterations if iteration_no == max_iterations then do { - if max_iterations > 1 then + if max_iterations > 2 then hPutStr stderr ("NOTE: Simplifier still going after " ++ show max_iterations ++ " iterations; bailing out.\n") @@ -214,192 +287,11 @@ simplifyPgm sw_chkr us binds } } where (us1, us2) = splitUniqSupply us - - -simplTopBinds binds = go binds `thenSmpl` \ (binds', _) -> - returnSmpl binds' - where - go [] = returnSmpl ([], ()) - go (bind1 : binds) = simplBind bind1 (go binds) \end{code} %************************************************************************ %* * -\subsection{Tidying core} -%* * -%************************************************************************ - -Several tasks are done by @tidyCorePgm@ - -1. Make certain top-level bindings into Globals. The point is that - Global things get externally-visible labels at code generation - time - - -2. Give all binders a nice print-name. Their uniques aren't changed; - rather we give them lexically unique occ-names, so that we can - safely print the OccNae only in the interface file. [Bad idea to - change the uniques, because the code generator makes global labels - from the uniques for local thunks etc.] - -3. If @opt_UsageSPOn@ then compute usage information (which is - needed by Core2Stg). ** NOTE _scc_ HERE ** - -\begin{code} -tidyCorePgm :: UniqSupply -> Module -> [Class] -> [CoreBind] -> IO [CoreBind] -tidyCorePgm us mod local_classes binds_in - = do - beginPass "Tidy Core" - let (_, binds_tidy) = mapAccumL (tidyBind (Just mod)) init_tidy_env binds_in - binds_out <- if opt_UsageSPOn - then _scc_ "CoreUsageSPInf" doUsageSPInf us binds_tidy - else return binds_tidy - endPass "Tidy Core" (opt_D_dump_simpl || opt_D_verbose_core2core) binds_out - where - -- Make sure to avoid the names of class operations - -- They don't have top-level bindings, so we won't see them - -- in binds_in; so we must initialise the tidy_env appropriately - -- - -- We also make sure to avoid any exported binders. Consider - -- f{-u1-} = 1 -- Local decl - -- ... - -- f{-u2-} = 2 -- Exported decl - -- - -- The second exported decl must 'get' the name 'f', so we - -- have to put 'f' in the avoids list before we get to the first - -- decl. Name.tidyName then does a no-op on exported binders. - init_tidy_env = (initTidyOccEnv avoids, emptyVarEnv) - avoids = [getOccName sel_id | cls <- local_classes, - sel_id <- classSelIds cls] - ++ - [getOccName bndr | bind <- binds_in, - bndr <- bindersOf bind, - isExported bndr] - -tidyBind :: Maybe Module -- (Just m) for top level, Nothing for nested - -> TidyEnv - -> CoreBind - -> (TidyEnv, CoreBind) -tidyBind maybe_mod env (NonRec bndr rhs) - = let - (env', bndr') = tidyBndr maybe_mod env bndr - rhs' = tidyExpr env rhs - in - (env', NonRec bndr' rhs') - -tidyBind maybe_mod env (Rec pairs) - = let - -- We use env' when tidying the rhss - -- When tidying the binder itself we may tidy it's - -- specialisations; if any of these mention other binders - -- in the group we should really feed env' to them too; - -- but that seems (a) unlikely and (b) a bit tiresome. - -- So I left it out for now - - (bndrs, rhss) = unzip pairs - (env', bndrs') = mapAccumL (tidyBndr maybe_mod) env bndrs - rhss' = map (tidyExpr env') rhss - in - (env', Rec (zip bndrs' rhss')) - -tidyExpr env (Type ty) = Type (tidyType env ty) -tidyExpr env (Con con args) = Con con (map (tidyExpr env) args) -tidyExpr env (App f a) = App (tidyExpr env f) (tidyExpr env a) -tidyExpr env (Note n e) = Note (tidyNote env n) (tidyExpr env e) - -tidyExpr env (Let b e) = Let b' (tidyExpr env' e) - where - (env', b') = tidyBind Nothing env b - -tidyExpr env (Case e b alts) = Case (tidyExpr env e) b' (map (tidyAlt env') alts) - where - (env', b') = tidyNestedBndr env b - -tidyExpr env (Var v) = case lookupVarEnv var_env v of - Just v' -> Var v' - Nothing -> Var v - where - (_, var_env) = env - -tidyExpr env (Lam b e) = Lam b' (tidyExpr env' e) - where - (env', b') = tidyNestedBndr env b - -tidyAlt env (con, vs, rhs) = (con, vs', tidyExpr env' rhs) - where - (env', vs') = mapAccumL tidyNestedBndr env vs - -tidyNote env (Coerce t1 t2) = Coerce (tidyType env t1) (tidyType env t2) - -tidyNote env note = note -\end{code} - -\begin{code} -tidyBndr (Just mod) env id = tidyTopBndr mod env id -tidyBndr Nothing env var = tidyNestedBndr env var - -tidyNestedBndr env tyvar - | isTyVar tyvar - = tidyTyVar env tyvar - -tidyNestedBndr env@(tidy_env, var_env) id - = -- Non-top-level variables - let - -- Give the Id a fresh print-name, *and* rename its type - -- The SrcLoc isn't important now, though we could extract it from the Id - name' = mkLocalName (getUnique id) occ' noSrcLoc - (tidy_env', occ') = tidyOccName tidy_env (getOccName id) - ty' = tidyType env (idType id) - id' = mkUserId name' ty' - -- NB: This throws away the IdInfo of the Id, which we - -- no longer need. That means we don't need to - -- run over it with env, nor renumber it. - var_env' = extendVarEnv var_env id id' - in - ((tidy_env', var_env'), id') - -tidyTopBndr mod env@(tidy_env, var_env) id - = -- Top level variables - let - (tidy_env', name') = tidyTopName mod tidy_env (idName id) - ty' = tidyTopType (idType id) - idinfo' = tidyIdInfo env (idInfo id) - id' = mkId name' ty' (idDetails id) idinfo' - var_env' = extendVarEnv var_env id id' - in - ((tidy_env', var_env'), id') - --- tidyIdInfo does these things: --- a) tidy the specialisation info (if any) --- b) zap a complicated ICanSafelyBeINLINEd pragma, --- c) zap the unfolding --- The latter two are to avoid space leaks - -tidyIdInfo env info - = info3 - where - spec_items = specEnvToList (specInfo info) - spec_env' = specEnvFromList (map tidy_item spec_items) - info1 | null spec_items = info - | otherwise = spec_env' `setSpecInfo` info - - info2 = case inlinePragInfo info of - ICanSafelyBeINLINEd _ _ -> NoInlinePragInfo `setInlinePragInfo` info1 - other -> info1 - - info3 = noUnfolding `setUnfoldingInfo` (wwLazy `setDemandInfo` info2) - - tidy_item (tyvars, tys, rhs) - = (tyvars', tidyTypes env' tys, tidyExpr env' rhs) - where - (env', tyvars') = tidyTyVars env tyvars -\end{code} - - - -%************************************************************************ -%* * \subsection{PostSimplification} %* * %************************************************************************ diff --git a/ghc/compiler/simplCore/SimplMonad.lhs b/ghc/compiler/simplCore/SimplMonad.lhs index 9c1a6671ee..17a4639fe5 100644 --- a/ghc/compiler/simplCore/SimplMonad.lhs +++ b/ghc/compiler/simplCore/SimplMonad.lhs @@ -11,19 +11,24 @@ module SimplMonad ( -- The continuation type SimplCont(..), DupFlag(..), contIsDupable, contResultType, + contIsInteresting, pushArgs, discardCont, countValArgs, countArgs, + contIsInline, discardInlineCont, -- The monad SimplM, initSmpl, returnSmpl, thenSmpl, thenSmpl_, mapSmpl, mapAndUnzipSmpl, mapAccumLSmpl, + -- The inlining black-list + getBlackList, + -- Unique supply getUniqueSmpl, getUniquesSmpl, newId, newIds, -- Counting - SimplCount, TickType(..), TickCounts, - tick, tickUnfold, + SimplCount, Tick(..), TickCounts, + tick, freeTick, getSimplCount, zeroSimplCount, pprSimplCount, plusSimplCount, isZeroSimplCount, @@ -34,31 +39,41 @@ module SimplMonad ( getEnclosingCC, setEnclosingCC, -- Environments - InScopeEnv, SubstEnv, + getSubst, setSubst, + getSubstEnv, extendSubst, extendSubstList, getInScope, setInScope, extendInScope, extendInScopes, modifyInScope, - emptySubstEnv, getSubstEnv, setSubstEnv, zapSubstEnv, - extendIdSubst, extendTySubst, - getTyEnv, getValEnv, + setSubstEnv, zapSubstEnv, getSimplBinderStuff, setSimplBinderStuff, switchOffInlining ) where #include "HsVersions.h" +import Const ( Con(DEFAULT) ) import Id ( Id, mkSysLocal, idMustBeINLINEd ) import IdInfo ( InlinePragInfo(..) ) import Demand ( Demand ) import CoreSyn -import CoreUtils ( IdSubst, SubstCoreExpr, coreExprType, coreAltsType ) +import PprCore () -- Instances +import Rules ( RuleBase ) import CostCentre ( CostCentreStack, subsumedCCS ) import Var ( TyVar ) import VarEnv import VarSet -import Type ( Type, TyVarSubst, funResultTy, fullSubstTy, applyTy ) +import qualified Subst +import Subst ( Subst, emptySubst, mkSubst, + substTy, substEnv, + InScopeSet, substInScope, isInScope, lookupInScope + ) +import Type ( Type, TyVarSubst, applyTy ) import UniqSupply ( uniqsFromSupply, uniqFromSupply, splitUniqSupply, UniqSupply ) -import CmdLineOpts ( SimplifierSwitch(..), SwitchResult(..), intSwitchSet ) +import FiniteMap +import CmdLineOpts ( SimplifierSwitch(..), SwitchResult(..), + opt_PprStyle_Debug, opt_HistorySize, + intSwitchSet + ) import Unique ( Unique ) import Maybes ( expectJust ) import Util ( zipWithEqual ) @@ -101,19 +116,21 @@ type SwitchChecker = SimplifierSwitch -> SwitchResult %************************************************************************ \begin{code} -type OutExprStuff = OutStuff (InScopeEnv, OutExpr) +type OutExprStuff = OutStuff (InScopeSet, OutExpr) type OutStuff a = ([OutBind], a) -- We return something equivalent to (let b in e), but -- in pieces to avoid the quadratic blowup when floating -- incrementally. Comments just before simplExprB in Simplify.lhs data SimplCont -- Strict contexts - = Stop + = Stop OutType -- Type of the result - | CoerceIt DupFlag - InType SubstEnv + | CoerceIt OutType -- The To-type, simplified SimplCont + | InlinePlease -- This continuation makes a function very + SimplCont -- keen to inline itelf + | ApplyTo DupFlag InExpr SubstEnv -- The argument, as yet unsimplified, SimplCont -- and its subst-env @@ -122,18 +139,23 @@ data SimplCont -- Strict contexts InId [InAlt] SubstEnv -- The case binder, alts, and subst-env SimplCont - | ArgOf DupFlag -- An arbitrary strict context: the argument - (OutExpr -> SimplM OutExprStuff) -- of a strict function, or a primitive-arg fn - -- or a PrimOp - OutType -- Type of the result of the whole thing + | ArgOf DupFlag -- An arbitrary strict context: the argument + -- of a strict function, or a primitive-arg fn + -- or a PrimOp + OutType -- The type of the expression being sought by the context + -- f (error "foo") ==> coerce t (error "foo") + -- when f is strict + -- We need to know the type t, to which to coerce. + (OutExpr -> SimplM OutExprStuff) -- What to do with the result instance Outputable SimplCont where - ppr Stop = ptext SLIT("Stop") + ppr (Stop _) = ptext SLIT("Stop") ppr (ApplyTo dup arg se cont) = (ptext SLIT("ApplyTo") <+> ppr dup <+> ppr arg) $$ ppr cont - ppr (ArgOf dup cont_fn _) = ptext SLIT("ArgOf...") <+> ppr dup + ppr (ArgOf dup _ _) = ptext SLIT("ArgOf...") <+> ppr dup ppr (Select dup bndr alts se cont) = (ptext SLIT("Select") <+> ppr dup <+> ppr bndr) $$ (nest 4 (ppr alts)) $$ ppr cont - ppr (CoerceIt dup ty se cont) = (ptext SLIT("CoerceIt") <+> ppr dup <+> ppr ty) $$ ppr cont + ppr (CoerceIt ty cont) = (ptext SLIT("CoerceIt") <+> ppr ty) $$ ppr cont + ppr (InlinePlease cont) = ptext SLIT("InlinePlease") $$ ppr cont data DupFlag = OkToDup | NoDup @@ -142,25 +164,107 @@ instance Outputable DupFlag where ppr NoDup = ptext SLIT("nodup") contIsDupable :: SimplCont -> Bool -contIsDupable Stop = True +contIsDupable (Stop _) = True contIsDupable (ApplyTo OkToDup _ _ _) = True contIsDupable (ArgOf OkToDup _ _) = True contIsDupable (Select OkToDup _ _ _ _) = True -contIsDupable (CoerceIt OkToDup _ _ _) = True +contIsDupable (CoerceIt _ cont) = contIsDupable cont +contIsDupable (InlinePlease cont) = contIsDupable cont contIsDupable other = False -contResultType :: InScopeEnv -> Type -> SimplCont -> Type -contResultType in_scope e_ty cont - = go e_ty cont - where - go e_ty Stop = e_ty - go e_ty (ApplyTo _ (Type ty) se cont) = go (applyTy e_ty (simpl se ty)) cont - go e_ty (ApplyTo _ val_arg _ cont) = go (funResultTy e_ty) cont - go e_ty (ArgOf _ fun cont_ty) = cont_ty - go e_ty (CoerceIt _ ty se cont) = go (simpl se ty) cont - go e_ty (Select _ _ alts se cont) = go (simpl se (coreAltsType alts)) cont - - simpl (ty_subst, _) ty = fullSubstTy ty_subst in_scope ty +contIsInline :: SimplCont -> Bool +contIsInline (InlinePlease cont) = True +contIsInline other = False + +discardInlineCont :: SimplCont -> SimplCont +discardInlineCont (InlinePlease cont) = cont +discardInlineCont cont = cont +\end{code} + + +Comment about contIsInteresting +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to avoid inlining an expression where there can't possibly be +any gain, such as in an argument position. Hence, if the continuation +is interesting (eg. a case scrutinee, application etc.) then we +inline, otherwise we don't. + +Previously some_benefit used to return True only if the variable was +applied to some value arguments. This didn't work: + + let x = _coerce_ (T Int) Int (I# 3) in + case _coerce_ Int (T Int) x of + I# y -> .... + +we want to inline x, but can't see that it's a constructor in a case +scrutinee position, and some_benefit is False. + +Another example: + +dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t) + +.... case dMonadST _@_ x0 of (a,b,c) -> .... + +we'd really like to inline dMonadST here, but we *don't* want to +inline if the case expression is just + + case x of y { DEFAULT -> ... } + +since we can just eliminate this case instead (x is in WHNF). Similar +applies when x is bound to a lambda expression. Hence +contIsInteresting looks for case expressions with just a single +default case. + +\begin{code} +contIsInteresting :: SimplCont -> Bool +contIsInteresting (Select _ _ alts _ _) = not (just_default alts) +contIsInteresting (CoerceIt _ cont) = contIsInteresting cont +contIsInteresting (ApplyTo _ (Type _) _ cont) = contIsInteresting cont +contIsInteresting (ApplyTo _ _ _ _) = True +contIsInteresting (ArgOf _ _ _) = True + -- If this call is the arg of a strict function, the context + -- is a bit interesting. If we inline here, we may get useful + -- evaluation information to avoid repeated evals: e.g. + -- x + (y * z) + -- Here the contIsInteresting makes the '*' keener to inline, + -- which in turn exposes a constructor which makes the '+' inline. + -- Assuming that +,* aren't small enough to inline regardless. +contIsInteresting (InlinePlease _) = True +contIsInteresting other = False + +just_default [(DEFAULT,_,_)] = True -- See notes below for why we look +just_default alts = False -- for this special case +\end{code} + + +\begin{code} +pushArgs :: SubstEnv -> [InExpr] -> SimplCont -> SimplCont +pushArgs se [] cont = cont +pushArgs se (arg:args) cont = ApplyTo NoDup arg se (pushArgs se args cont) + +discardCont :: SimplCont -- A continuation, expecting + -> SimplCont -- Replace the continuation with a suitable coerce +discardCont (Stop to_ty) = Stop to_ty +discardCont cont = CoerceIt to_ty (Stop to_ty) + where + to_ty = contResultType cont + +contResultType :: SimplCont -> OutType +contResultType (Stop to_ty) = to_ty +contResultType (ArgOf _ to_ty _) = to_ty +contResultType (ApplyTo _ _ _ cont) = contResultType cont +contResultType (CoerceIt _ cont) = contResultType cont +contResultType (InlinePlease cont) = contResultType cont +contResultType (Select _ _ _ _ cont) = contResultType cont + +countValArgs :: SimplCont -> Int +countValArgs (ApplyTo _ (Type ty) se cont) = countValArgs cont +countValArgs (ApplyTo _ val_arg se cont) = 1 + countValArgs cont +countValArgs other = 0 + +countArgs :: SimplCont -> Int +countArgs (ApplyTo _ arg se cont) = 1 + countArgs cont +countArgs other = 0 \end{code} @@ -182,21 +286,40 @@ type SimplM result -- We thread the unique supply because data SimplEnv = SimplEnv { - seChkr :: SwitchChecker, - seCC :: CostCentreStack, -- The enclosing CCS (when profiling) - seSubst :: SubstEnv, -- The current substitution - seInScope :: InScopeEnv -- Says what's in scope and gives info about it + seChkr :: SwitchChecker, + seCC :: CostCentreStack, -- The enclosing CCS (when profiling) + seBlackList :: Id -> Bool, -- True => don't inline this Id + seSubst :: Subst -- The current substitution } + -- The range of the substitution is OutType and OutExpr resp + -- + -- The substitution is idempotent + -- It *must* be applied; things in its domain simply aren't + -- bound in the result. + -- + -- The substitution usually maps an Id to its clone, + -- but if the orig defn is a let-binding, and + -- the RHS of the let simplifies to an atom, + -- we just add the binding to the substitution and elide the let. + + -- The in-scope part of Subst includes *all* in-scope TyVars and Ids + -- The elements of the set may have better IdInfo than the + -- occurrences of in-scope Ids, and (more important) they will + -- have a correctly-substituted type. So we use a lookup in this + -- set to replace occurrences \end{code} \begin{code} initSmpl :: SwitchChecker -> UniqSupply -- No init count; set to 0 + -> VarSet -- In scope (usually empty, but useful for nested calls) + -> (Id -> Bool) -- Black-list function -> SimplM a -> (a, SimplCount) -initSmpl chkr us m = case m (emptySimplEnv chkr) us zeroSimplCount of - (result, _, count) -> (result, count) +initSmpl chkr us in_scope black_list m + = case m (emptySimplEnv chkr in_scope black_list) us zeroSimplCount of + (result, _, count) -> (result, count) {-# INLINE thenSmpl #-} @@ -266,135 +389,262 @@ getUniquesSmpl n env us sc = case splitUniqSupply us of %************************************************************************ \begin{code} -doTickSmpl :: (SimplCount -> SimplCount) -> SimplM () -doTickSmpl f env us sc = sc' `seq` ((), us, sc') - where - sc' = f sc - getSimplCount :: SimplM SimplCount getSimplCount env us sc = (sc, us, sc) -\end{code} - -The assoc list isn't particularly costly, because we only use -the number of ticks in ``real life.'' +tick :: Tick -> SimplM () +tick t env us sc = sc' `seq` ((), us, sc') + where + sc' = doTick t sc + +freeTick :: Tick -> SimplM () +-- Record a tick, but don't add to the total tick count, which is +-- used to decide when nothing further has happened +freeTick t env us sc = sc' `seq` ((), us, sc') + where + sc' = doFreeTick t sc +\end{code} -The right thing to do, if you want that to go fast, is thread -a mutable array through @SimplM@. +\begin{code} +verboseSimplStats = opt_PprStyle_Debug -- For now, anyway + +-- Defined both with and without debugging +zeroSimplCount :: SimplCount +isZeroSimplCount :: SimplCount -> Bool +pprSimplCount :: SimplCount -> SDoc +doTick, doFreeTick :: Tick -> SimplCount -> SimplCount +plusSimplCount :: SimplCount -> SimplCount -> SimplCount +\end{code} \begin{code} -data SimplCount - = SimplCount !TickCounts - !UnfoldingHistory - -type TickCounts = [(TickType, Int)] -- Assoc list of all diff kinds of ticks - -- Kept in increasing order of TickType - -- Zeros not present - -type UnfoldingHistory = (Int, -- N - [Id], -- Last N unfoldings - [Id]) -- The MaxUnfoldHistory unfoldings before that - -data TickType - = PreInlineUnconditionally - | PostInlineUnconditionally - | UnfoldingDone - | MagicUnfold - | CaseOfCase - | LetFloatFromLet - | KnownBranch - | Let2Case - | Case2Let - | CaseMerge - | CaseElim - | CaseIdentity - | EtaExpansion - | CaseOfError - | BetaReduction - | SpecialisationDone - | FillInCaseDefault - | LeavesExamined - deriving (Eq, Ord, Show) - -pprSimplCount :: SimplCount -> SDoc -pprSimplCount (SimplCount stuff (_, unf1, unf2)) - = vcat (map ppr_item stuff) - $$ (text "Most recent unfoldings (most recent at top):" - $$ nest 4 (vcat (map ppr (unf1 ++ unf2)))) - where - ppr_item (t,n) = text (show t) <+> char '\t' <+> ppr n +#ifndef DEBUG +---------------------------------------------------------- +-- Debugging OFF +---------------------------------------------------------- +type SimplCount = Int zeroSimplCount :: SimplCount -zeroSimplCount = SimplCount [] (0, [], []) - -isZeroSimplCount :: SimplCount -> Bool -isZeroSimplCount (SimplCount [] _) = True -isZeroSimplCount (SimplCount [(LeavesExamined,_)] _) = True -isZeroSimplCount other = False - --- incTick is careful to be pretty strict, so we don't --- get a huge buildup of thunks -incTick :: TickType -> FAST_INT -> TickCounts -> TickCounts -incTick tick_type n [] - = [(tick_type, IBOX(n))] - -incTick tick_type n (x@(ttype, I# cnt#) : xs) - = case tick_type `compare` ttype of - LT -> -- Insert here - (tick_type, IBOX(n)) : x : xs - - EQ -> -- Increment - case cnt# +# n of - incd -> (ttype, IBOX(incd)) : xs - - GT -> -- Move on - rest `seq` x : rest - where - rest = incTick tick_type n xs - --- Second argument is more recent stuff -plusSimplCount :: SimplCount -> SimplCount -> SimplCount -plusSimplCount (SimplCount tc1 uh1) (SimplCount tc2 uh2) - = SimplCount (plusTickCounts tc1 tc2) (plusUnfolds uh1 uh2) - -plusTickCounts :: TickCounts -> TickCounts -> TickCounts -plusTickCounts ts1 [] = ts1 -plusTickCounts [] ts2 = ts2 -plusTickCounts ((tt1,n1) : ts1) ((tt2,n2) : ts2) - = case tt1 `compare` tt2 of - LT -> (tt1,n1) : plusTickCounts ts1 ((tt2,n2) : ts2) - EQ -> (tt1,n1+n2) : plusTickCounts ts1 ts2 - GT -> (tt2,n2) : plusTickCounts ((tt1,n1) : ts1) ts2 - --- Second argument is the more recent stuff -plusUnfolds uh1 (0, h2, t2) = uh1 -- Nothing recent -plusUnfolds (n1, h1, t1) (n2, h2, []) = (n2, h2, (h1++t1)) -- Small amount recent -plusUnfolds (n1, h1, t1) uh2 = uh2 -- Decent batch recent -\end{code} +zeroSimplCount = 0 +isZeroSimplCount n = n==0 -Counting-related monad functions: +doTick t n = n+1 -- Very basic when not debugging +doFreeTick t n = n -- Don't count leaf visits -\begin{code} -tick :: TickType -> SimplM () +pprSimplCount n = ptext SLIT("Total ticks:") <+> int n + +plusSimplCount n m = n+m + +#else +---------------------------------------------------------- +-- Debugging ON +---------------------------------------------------------- + +data SimplCount = SimplCount { + ticks :: !Int, -- Total ticks + details :: !TickCounts, -- How many of each type + n_log :: !Int, -- N + log1 :: [Tick], -- Last N events; <= opt_HistorySize + log2 :: [Tick] -- Last opt_HistorySize events before that + } -tick tick_type - = doTickSmpl f +type TickCounts = FiniteMap Tick Int + +zeroSimplCount = SimplCount {ticks = 0, details = emptyFM, + n_log = 0, log1 = [], log2 = []} + +isZeroSimplCount sc = ticks sc == 0 + +doFreeTick tick sc@SimplCount { details = dts } + = dts' `seqFM` sc { details = dts' } + where + dts' = dts `addTick` tick + +-- Gross hack to persuade GHC 3.03 to do this important seq +seqFM fm x | isEmptyFM fm = x + | otherwise = x + +doTick tick sc@SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1, log2 = l2 } + | nl >= opt_HistorySize = sc1 { n_log = 1, log1 = [tick], log2 = l1 } + | otherwise = sc1 { n_log = nl+1, log1 = tick : l1 } + where + sc1 = sc { ticks = tks+1, details = dts `addTick` tick } + +-- Don't use plusFM_C because that's lazy, and we want to +-- be pretty strict here! +addTick :: TickCounts -> Tick -> TickCounts +addTick fm tick = case lookupFM fm tick of + Nothing -> addToFM fm tick 1 + Just n -> n1 `seq` addToFM fm tick n1 + where + n1 = n+1 + +plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 }) + sc2@(SimplCount { ticks = tks2, details = dts2 }) + = log_base { ticks = tks1 + tks2, details = plusFM_C (+) dts1 dts2 } where - f (SimplCount stuff unf) = SimplCount (incTick tick_type ILIT(1) stuff) unf - -maxUnfoldHistory :: Int -maxUnfoldHistory = 20 - -tickUnfold :: Id -> SimplM () -tickUnfold id - = doTickSmpl f - where - f (SimplCount stuff (n_unf, unf1, unf2)) - | n_unf >= maxUnfoldHistory = SimplCount new_stuff (1, [id], unf1) - | otherwise = SimplCount new_stuff (n_unf+1, id:unf1, unf2) - where - new_stuff = incTick UnfoldingDone ILIT(1) stuff + -- A hackish way of getting recent log info + log_base | null (log1 sc2) = sc1 -- Nothing at all in sc2 + | null (log2 sc2) = sc2 { log2 = log1 sc1 } + | otherwise = sc2 + + +pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 }) + = vcat [ptext SLIT("Total ticks: ") <+> int tks, + text "", + pprTickCounts (fmToList dts), + if verboseSimplStats then + vcat [text "", + ptext SLIT("Log (most recent first)"), + nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))] + else empty + ] + +pprTickCounts :: [(Tick,Int)] -> SDoc +pprTickCounts [] = empty +pprTickCounts ((tick1,n1):ticks) + = vcat [int tot_n <+> text (tickString tick1), + pprTCDetails real_these, + pprTickCounts others + ] + where + tick1_tag = tickToTag tick1 + (these, others) = span same_tick ticks + real_these = (tick1,n1):these + same_tick (tick2,_) = tickToTag tick2 == tick1_tag + tot_n = sum [n | (_,n) <- real_these] + +pprTCDetails ticks@((tick,_):_) + | verboseSimplStats || isRuleFired tick + = nest 4 (vcat [int n <+> pprTickCts tick | (tick,n) <- ticks]) + | otherwise + = empty +#endif +\end{code} + +%************************************************************************ +%* * +\subsection{Ticks} +%* * +%************************************************************************ + +\begin{code} +data Tick + = PreInlineUnconditionally Id + | PostInlineUnconditionally Id + + | UnfoldingDone Id + | RuleFired FAST_STRING -- Rule name + + | LetFloatFromLet Id -- Thing floated out + | EtaExpansion Id -- LHS binder + | EtaReduction Id -- Binder on outer lambda + | BetaReduction Id -- Lambda binder + + + | CaseOfCase Id -- Bndr on *inner* case + | KnownBranch Id -- Case binder + | CaseMerge Id -- Binder on outer case + | CaseElim Id -- Case binder + | CaseIdentity Id -- Case binder + | FillInCaseDefault Id -- Case binder + + | BottomFound + | LeafVisit + | SimplifierDone -- Ticked at each iteration of the simplifier + +isRuleFired (RuleFired _) = True +isRuleFired other = False + +instance Outputable Tick where + ppr tick = text (tickString tick) <+> pprTickCts tick + +instance Eq Tick where + a == b = case a `cmpTick` b of { EQ -> True; other -> False } + +instance Ord Tick where + compare = cmpTick + +tickToTag :: Tick -> Int +tickToTag (PreInlineUnconditionally _) = 0 +tickToTag (PostInlineUnconditionally _) = 1 +tickToTag (UnfoldingDone _) = 2 +tickToTag (RuleFired _) = 3 +tickToTag (LetFloatFromLet _) = 4 +tickToTag (EtaExpansion _) = 5 +tickToTag (EtaReduction _) = 6 +tickToTag (BetaReduction _) = 7 +tickToTag (CaseOfCase _) = 8 +tickToTag (KnownBranch _) = 9 +tickToTag (CaseMerge _) = 10 +tickToTag (CaseElim _) = 11 +tickToTag (CaseIdentity _) = 12 +tickToTag (FillInCaseDefault _) = 13 +tickToTag BottomFound = 14 +tickToTag LeafVisit = 15 +tickToTag SimplifierDone = 16 + +tickString :: Tick -> String +tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally" +tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally" +tickString (UnfoldingDone _) = "UnfoldingDone" +tickString (RuleFired _) = "RuleFired" +tickString (LetFloatFromLet _) = "LetFloatFromLet" +tickString (EtaExpansion _) = "EtaExpansion" +tickString (EtaReduction _) = "EtaReduction" +tickString (BetaReduction _) = "BetaReduction" +tickString (CaseOfCase _) = "CaseOfCase" +tickString (KnownBranch _) = "KnownBranch" +tickString (CaseMerge _) = "CaseMerge" +tickString (CaseElim _) = "CaseElim" +tickString (CaseIdentity _) = "CaseIdentity" +tickString (FillInCaseDefault _) = "FillInCaseDefault" +tickString BottomFound = "BottomFound" +tickString SimplifierDone = "SimplifierDone" +tickString LeafVisit = "LeafVisit" + +pprTickCts :: Tick -> SDoc +pprTickCts (PreInlineUnconditionally v) = ppr v +pprTickCts (PostInlineUnconditionally v)= ppr v +pprTickCts (UnfoldingDone v) = ppr v +pprTickCts (RuleFired v) = ppr v +pprTickCts (LetFloatFromLet v) = ppr v +pprTickCts (EtaExpansion v) = ppr v +pprTickCts (EtaReduction v) = ppr v +pprTickCts (BetaReduction v) = ppr v +pprTickCts (CaseOfCase v) = ppr v +pprTickCts (KnownBranch v) = ppr v +pprTickCts (CaseMerge v) = ppr v +pprTickCts (CaseElim v) = ppr v +pprTickCts (CaseIdentity v) = ppr v +pprTickCts (FillInCaseDefault v) = ppr v +pprTickCts other = empty + +cmpTick :: Tick -> Tick -> Ordering +cmpTick a b = case (tickToTag a `compare` tickToTag b) of + GT -> GT + EQ | isRuleFired a || verboseSimplStats -> cmpEqTick a b + | otherwise -> EQ + LT -> LT + -- Always distinguish RuleFired, so that the stats + -- can report them even in non-verbose mode + +cmpEqTick :: Tick -> Tick -> Ordering +cmpEqTick (PreInlineUnconditionally a) (PreInlineUnconditionally b) = a `compare` b +cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b) = a `compare` b +cmpEqTick (UnfoldingDone a) (UnfoldingDone b) = a `compare` b +cmpEqTick (RuleFired a) (RuleFired b) = a `compare` b +cmpEqTick (LetFloatFromLet a) (LetFloatFromLet b) = a `compare` b +cmpEqTick (EtaExpansion a) (EtaExpansion b) = a `compare` b +cmpEqTick (EtaReduction a) (EtaReduction b) = a `compare` b +cmpEqTick (BetaReduction a) (BetaReduction b) = a `compare` b +cmpEqTick (CaseOfCase a) (CaseOfCase b) = a `compare` b +cmpEqTick (KnownBranch a) (KnownBranch b) = a `compare` b +cmpEqTick (CaseMerge a) (CaseMerge b) = a `compare` b +cmpEqTick (CaseElim a) (CaseElim b) = a `compare` b +cmpEqTick (CaseIdentity a) (CaseIdentity b) = a `compare` b +cmpEqTick (FillInCaseDefault a) (FillInCaseDefault b) = a `compare` b +cmpEqTick other1 other2 = EQ \end{code} @@ -476,11 +726,8 @@ environment seems like wild overkill. \begin{code} switchOffInlining :: SimplM a -> SimplM a -switchOffInlining m env@(SimplEnv { seChkr = sw_chkr }) us sc - = m (env { seChkr = new_chkr }) us sc - where - new_chkr EssentialUnfoldingsOnly = SwBool True - new_chkr other = sw_chkr other +switchOffInlining m env us sc + = m (env { seBlackList = \v -> True }) us sc \end{code} @@ -505,120 +752,94 @@ setEnclosingCC cc m env us sc = m (env { seCC = cc }) us sc %* * %************************************************************************ -\begin{code} -type SubstEnv = (TyVarSubst, IdSubst) - -- The range of these substitutions is OutType and OutExpr resp - -- - -- The substitution is idempotent - -- It *must* be applied; things in its domain simply aren't - -- bound in the result. - -- - -- The substitution usually maps an Id to its clone, - -- but if the orig defn is a let-binding, and - -- the RHS of the let simplifies to an atom, - -- we just add the binding to the substitution and elide the let. - -type InScopeEnv = IdOrTyVarSet - -- Domain includes *all* in-scope TyVars and Ids - -- - -- The elements of the set may have better IdInfo than the - -- occurrences of in-scope Ids, and (more important) they will - -- have a correctly-substituted type. So we use a lookup in this - -- set to replace occurrences - --- INVARIANT: If t is in the in-scope set, it certainly won't be --- in the domain of the SubstEnv, and vice versa -\end{code} - \begin{code} -emptySubstEnv :: SubstEnv -emptySubstEnv = (emptyVarEnv, emptyVarEnv) - -emptySimplEnv :: SwitchChecker -> SimplEnv +emptySimplEnv :: SwitchChecker -> InScopeSet -> (Id -> Bool) -> SimplEnv -emptySimplEnv sw_chkr +emptySimplEnv sw_chkr in_scope black_list = SimplEnv { seChkr = sw_chkr, seCC = subsumedCCS, - seSubst = emptySubstEnv, - seInScope = emptyVarSet } - + seBlackList = black_list, + seSubst = mkSubst in_scope emptySubstEnv } -- The top level "enclosing CC" is "SUBSUMED". -getTyEnv :: SimplM (TyVarSubst, InScopeEnv) -getTyEnv (SimplEnv {seSubst = (ty_subst,_), seInScope = in_scope}) us sc - = ((ty_subst, in_scope), us, sc) +getSubst :: SimplM Subst +getSubst env us sc = (seSubst env, us, sc) -getValEnv :: SimplM (IdSubst, InScopeEnv) -getValEnv (SimplEnv {seSubst = (_, id_subst), seInScope = in_scope}) us sc - = ((id_subst, in_scope), us, sc) +getBlackList :: SimplM (Id -> Bool) +getBlackList env us sc = (seBlackList env, us, sc) -getInScope :: SimplM InScopeEnv -getInScope env us sc = (seInScope env, us, sc) +setSubst :: Subst -> SimplM a -> SimplM a +setSubst subst m env us sc = m (env {seSubst = subst}) us sc -setInScope :: InScopeEnv -> SimplM a -> SimplM a -setInScope in_scope m env us sc = m (env {seInScope = in_scope}) us sc +getSubstEnv :: SimplM SubstEnv +getSubstEnv env us sc = (substEnv (seSubst env), us, sc) extendInScope :: CoreBndr -> SimplM a -> SimplM a -extendInScope v m env@(SimplEnv {seInScope = in_scope}) us sc - = m (env {seInScope = extendVarSet in_scope v}) us sc +extendInScope v m env@(SimplEnv {seSubst = subst}) us sc + = m (env {seSubst = Subst.extendInScope subst v}) us sc extendInScopes :: [CoreBndr] -> SimplM a -> SimplM a -extendInScopes vs m env@(SimplEnv {seInScope = in_scope}) us sc - = m (env {seInScope = foldl extendVarSet in_scope vs}) us sc +extendInScopes vs m env@(SimplEnv {seSubst = subst}) us sc + = m (env {seSubst = Subst.extendInScopes subst vs}) us sc + +getInScope :: SimplM InScopeSet +getInScope env us sc = (substInScope (seSubst env), us, sc) + +setInScope :: InScopeSet -> SimplM a -> SimplM a +setInScope in_scope m env@(SimplEnv {seSubst = subst}) us sc + = m (env {seSubst = Subst.setInScope subst in_scope}) us sc modifyInScope :: CoreBndr -> SimplM a -> SimplM a modifyInScope v m env us sc #ifdef DEBUG - | not (v `elemVarSet` seInScope env ) + | not (v `isInScope` seSubst env) = pprTrace "modifyInScope: not in scope:" (ppr v) m env us sc #endif | otherwise = extendInScope v m env us sc -getSubstEnv :: SimplM SubstEnv -getSubstEnv env us sc = (seSubst env, us, sc) - -setSubstEnv :: SubstEnv -> SimplM a -> SimplM a -setSubstEnv subst_env m env us sc = m (env {seSubst = subst_env}) us sc +extendSubst :: CoreBndr -> SubstResult -> SimplM a -> SimplM a +extendSubst var res m env@(SimplEnv {seSubst = subst}) us sc + = m (env { seSubst = Subst.extendSubst subst var res }) us sc -extendIdSubst :: Id -> SubstCoreExpr -> SimplM a -> SimplM a -extendIdSubst id expr m env@(SimplEnv {seSubst = (ty_subst, id_subst)}) us sc - = m (env { seSubst = (ty_subst, extendVarEnv id_subst id expr) }) us sc +extendSubstList :: [CoreBndr] -> [SubstResult] -> SimplM a -> SimplM a +extendSubstList vars ress m env@(SimplEnv {seSubst = subst}) us sc + = m (env { seSubst = Subst.extendSubstList subst vars ress }) us sc -extendTySubst :: TyVar -> OutType -> SimplM a -> SimplM a -extendTySubst tv ty m env@(SimplEnv {seSubst = (ty_subst, id_subst)}) us sc - = m (env { seSubst = (extendVarEnv ty_subst tv ty, id_subst) }) us sc +setSubstEnv :: SubstEnv -> SimplM a -> SimplM a +setSubstEnv senv m env@(SimplEnv {seSubst = subst}) us sc + = m (env {seSubst = Subst.setSubstEnv subst senv}) us sc zapSubstEnv :: SimplM a -> SimplM a -zapSubstEnv m env us sc = m (env {seSubst = emptySubstEnv}) us sc +zapSubstEnv m env@(SimplEnv {seSubst = subst}) us sc + = m (env {seSubst = Subst.zapSubstEnv subst}) us sc -getSimplBinderStuff :: SimplM (TyVarSubst, IdSubst, InScopeEnv, UniqSupply) -getSimplBinderStuff (SimplEnv {seSubst = (ty_subst, id_subst), seInScope = in_scope}) us sc - = ((ty_subst, id_subst, in_scope, us), us, sc) +getSimplBinderStuff :: SimplM (Subst, UniqSupply) +getSimplBinderStuff (SimplEnv {seSubst = subst}) us sc + = ((subst, us), us, sc) -setSimplBinderStuff :: (TyVarSubst, IdSubst, InScopeEnv, UniqSupply) - -> SimplM a -> SimplM a -setSimplBinderStuff (ty_subst, id_subst, in_scope, us) m env _ sc - = m (env {seSubst = (ty_subst, id_subst), seInScope = in_scope}) us sc +setSimplBinderStuff :: (Subst, UniqSupply) -> SimplM a -> SimplM a +setSimplBinderStuff (subst, us) m env _ sc + = m (env {seSubst = subst}) us sc \end{code} \begin{code} newId :: Type -> (Id -> SimplM a) -> SimplM a -- Extends the in-scope-env too -newId ty m env@(SimplEnv {seInScope = in_scope}) us sc +newId ty m env@(SimplEnv {seSubst = subst}) us sc = case splitUniqSupply us of - (us1, us2) -> m v (env {seInScope = extendVarSet in_scope v}) us2 sc + (us1, us2) -> m v (env {seSubst = Subst.extendInScope subst v}) us2 sc where v = mkSysLocal SLIT("s") (uniqFromSupply us1) ty newIds :: [Type] -> ([Id] -> SimplM a) -> SimplM a -newIds tys m env@(SimplEnv {seInScope = in_scope}) us sc +newIds tys m env@(SimplEnv {seSubst = subst}) us sc = case splitUniqSupply us of - (us1, us2) -> m vs (env {seInScope = foldl extendVarSet in_scope vs}) us2 sc + (us1, us2) -> m vs (env {seSubst = Subst.extendInScopes subst vs}) us2 sc where vs = zipWithEqual "newIds" (mkSysLocal SLIT("s")) (uniqsFromSupply (length tys) us1) tys -\end{code} +\end{code} diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs index 9c5c64743d..3615dbfb80 100644 --- a/ghc/compiler/simplCore/SimplUtils.lhs +++ b/ghc/compiler/simplCore/SimplUtils.lhs @@ -6,33 +6,35 @@ \begin{code} module SimplUtils ( simplBinder, simplBinders, simplIds, - mkRhsTyLam, + transformRhs, etaCoreExpr, - etaExpandCount, - mkCase, findAlt, findDefault + mkCase, findAlt, findDefault, + mkCoerce ) where #include "HsVersions.h" import BinderInfo -import CmdLineOpts ( opt_DoEtaReduction, switchIsOn, SimplifierSwitch(..) ) +import CmdLineOpts ( opt_SimplDoLambdaEtaExpansion, opt_SimplCaseMerge ) import CoreSyn -import CoreUtils ( exprIsCheap, exprIsTrivial, exprFreeVars, cheapEqExpr, - FormSummary(..), - substId, substIds +import CoreFVs ( exprFreeVars ) +import CoreUtils ( exprIsCheap, exprIsTrivial, cheapEqExpr, coreExprType, + exprIsWHNF, FormSummary(..) ) +import Subst ( substBndrs, substBndr, substIds ) import Id ( Id, idType, getIdArity, isId, idName, getInlinePragma, setInlinePragma, - getIdDemandInfo + getIdDemandInfo, mkId ) -import IdInfo ( arityLowerBound, InlinePragInfo(..) ) -import Maybes ( maybeToBool ) +import IdInfo ( arityLowerBound, InlinePragInfo(..), setInlinePragInfo, vanillaIdInfo ) +import Maybes ( maybeToBool, catMaybes ) import Const ( Con(..) ) -import Name ( isLocalName ) +import Name ( isLocalName, setNameUnique ) import SimplMonad import Type ( Type, tyVarsOfType, tyVarsOfTypes, mkForAllTys, - splitTyConApp_maybe, substTyVar, mkTyVarTys + splitTyConApp_maybe, mkTyVarTys, applyTys, splitFunTys, mkFunTys ) +import TysPrim ( statePrimTyCon ) import Var ( setVarUnique ) import VarSet import UniqSupply ( splitUniqSupply, uniqFromSupply ) @@ -47,67 +49,56 @@ import Outputable %* * %************************************************************************ -When we hit a binder we may need to - (a) apply the the type envt (if non-empty) to its type - (b) apply the type envt and id envt to its SpecEnv (if it has one) - (c) give it a new unique to avoid name clashes - \begin{code} simplBinders :: [InBinder] -> ([OutBinder] -> SimplM a) -> SimplM a simplBinders bndrs thing_inside - = getSwitchChecker `thenSmpl` \ sw_chkr -> - getSimplBinderStuff `thenSmpl` \ stuff -> + = getSubst `thenSmpl` \ subst -> let - must_clone = switchIsOn sw_chkr SimplPleaseClone - (stuff', bndrs') = mapAccumL (subst_binder must_clone) stuff bndrs + (subst', bndrs') = substBndrs subst bndrs in - setSimplBinderStuff stuff' $ + setSubst subst' $ thing_inside bndrs' simplBinder :: InBinder -> (OutBinder -> SimplM a) -> SimplM a simplBinder bndr thing_inside - = getSwitchChecker `thenSmpl` \ sw_chkr -> - getSimplBinderStuff `thenSmpl` \ stuff -> + = getSubst `thenSmpl` \ subst -> let - must_clone = switchIsOn sw_chkr SimplPleaseClone - (stuff', bndr') = subst_binder must_clone stuff bndr + (subst', bndr') = substBndr subst bndr in - setSimplBinderStuff stuff' $ + setSubst subst' $ thing_inside bndr' + -- Same semantics as simplBinders, but a little less -- plumbing and hence a little more efficient. -- Maybe not worth the candle? simplIds :: [InBinder] -> ([OutBinder] -> SimplM a) -> SimplM a simplIds ids thing_inside - = getSwitchChecker `thenSmpl` \ sw_chkr -> - getSimplBinderStuff `thenSmpl` \ (ty_subst, id_subst, in_scope, us) -> + = getSubst `thenSmpl` \ subst -> let - must_clone = switchIsOn sw_chkr SimplPleaseClone - (id_subst', in_scope', us', ids') = substIds (simpl_clone_fn must_clone) - ty_subst id_subst in_scope us ids + (subst', bndrs') = substIds subst ids in - setSimplBinderStuff (ty_subst, id_subst', in_scope', us') $ - thing_inside ids' + setSubst subst' $ + thing_inside bndrs' +\end{code} -subst_binder must_clone (ty_subst, id_subst, in_scope, us) bndr - | isTyVar bndr - = case substTyVar ty_subst in_scope bndr of - (ty_subst', in_scope', bndr') -> ((ty_subst', id_subst, in_scope', us), bndr') - | otherwise - = case substId (simpl_clone_fn must_clone) ty_subst id_subst in_scope us bndr of - (id_subst', in_scope', us', bndr') - -> ((ty_subst, id_subst', in_scope', us'), bndr') - -simpl_clone_fn must_clone in_scope us id - | (must_clone && isLocalName (idName id)) - || id `elemVarSet` in_scope - = case splitUniqSupply us of - (us1, us2) -> Just (us1, setVarUnique id (uniqFromSupply us2)) - - | otherwise - = Nothing +%************************************************************************ +%* * +\subsection{Transform a RHS} +%* * +%************************************************************************ + +Try (a) eta expansion + (b) type-lambda swizzling + +\begin{code} +transformRhs :: InExpr -> SimplM InExpr +transformRhs rhs + = tryEtaExpansion body `thenSmpl` \ body' -> + mkRhsTyLam tyvars body' + where + (tyvars, body) = collectTyBinders rhs \end{code} @@ -159,18 +150,40 @@ So far as the implemtation is concerned: where G = F . Let {xi = xi' tvs} -\begin{code} -mkRhsTyLam (Lam b e) - | isTyVar b = case collectTyBinders e of - (bs,body) -> mkRhsTyLam_help (b:bs) body +[May 1999] If we do this transformation *regardless* then we can +end up with some pretty silly stuff. For example, -mkRhsTyLam other_expr -- No-op if not a type lambda - = returnSmpl other_expr + let + st = /\ s -> let { x1=r1 ; x2=r2 } in ... + in .. +becomes + let y1 = /\s -> r1 + y2 = /\s -> r2 + st = /\s -> ...[y1 s/x1, y2 s/x2] + in .. +Unless the "..." is a WHNF there is really no point in doing this. +Indeed it can make things worse. Suppose x1 is used strictly, +and is of the form -mkRhsTyLam_help tyvars body + x1* = case f y of { (a,b) -> e } + +If we abstract this wrt the tyvar we then can't do the case inline +as we would normally do. + + +\begin{code} +mkRhsTyLam tyvars body -- Only does something if there's a let + | null tyvars || not (worth_it body) -- inside a type lambda, and a WHNF inside that + = returnSmpl (mkLams tyvars body) + | otherwise = go (\x -> x) body where + worth_it (Let _ e) = whnf_in_middle e + worth_it other = False + whnf_in_middle (Let _ e) = whnf_in_middle e + whnf_in_middle e = exprIsWHNF e + main_tyvar_set = mkVarSet tyvars go fn (Let bind@(NonRec var rhs) body) | exprIsTrivial rhs @@ -190,7 +203,7 @@ mkRhsTyLam_help tyvars body -- /\ a b -> let t :: (a,b) = (e1, e2) -- x :: a = fst t -- in ... - -- Here, b isn't free in a's type, but we must nevertheless + -- Here, b isn't free in x's type, but we must nevertheless -- abstract wrt b as well, because t's type mentions b. -- Since t is floated too, we'd end up with the bogus: -- poly_t = /\ a b -> (e1, e2) @@ -219,29 +232,29 @@ mkRhsTyLam_help tyvars body go fn body = returnSmpl (mkLams tyvars (fn body)) mk_poly tyvars_here var - = newId (mkForAllTys tyvars_here (idType var)) $ \ poly_id -> + = getUniqueSmpl `thenSmpl` \ uniq -> let + poly_name = setNameUnique (idName var) uniq -- Keep same name + poly_ty = mkForAllTys tyvars_here (idType var) -- But new type of course + -- It's crucial to copy the inline-prag of the original var, because -- we're looking at occurrence-analysed but as yet unsimplified code! -- In particular, we mustn't lose the loop breakers. -- - -- *However* we don't want to retain a single-occurrence or dead-var info - -- because we're adding a load of "silly bindings" of the form - -- var _U_ = poly_var t1 t2 - -- with a must-inline pragma on the silly binding to prevent the - -- poly-var from being inlined right back in. Since poly_var now - -- occurs inside an INLINE binding, it should be given a ManyOcc, - -- else it may get inlined unconditionally - poly_inline_prag = case getInlinePragma var of - ICanSafelyBeINLINEd _ _ -> NoInlinePragInfo - IAmDead -> NoInlinePragInfo - var_inline_prag -> var_inline_prag - - poly_id' = setInlinePragma poly_id poly_inline_prag + -- It's even right to retain single-occurrence or dead-var info: + -- Suppose we started with /\a -> let x = E in B + -- where x occurs once in E. Then we transform to: + -- let x' = /\a -> E in /\a -> let x* = x' a in B + -- where x* has an INLINE prag on it. Now, once x* is inlined, + -- the occurrences of x' will be just the occurrences originaly + -- pinned on x. + poly_info = vanillaIdInfo `setInlinePragInfo` getInlinePragma var + + poly_id = mkId poly_name poly_ty poly_info in - returnSmpl (poly_id', mkTyApps (Var poly_id') (mkTyVarTys tyvars_here)) + returnSmpl (poly_id, mkTyApps (Var poly_id) (mkTyVarTys tyvars_here)) - mk_silly_bind var rhs = NonRec (setInlinePragma var IWantToBeINLINEd) rhs + mk_silly_bind var rhs = NonRec (setInlinePragma var IMustBeINLINEd) rhs -- The addInlinePragma is really important! If we don't say -- INLINE on these silly little bindings then look what happens! -- Suppose we start with: @@ -254,12 +267,104 @@ mkRhsTyLam_help tyvars body -- * but then it gets inlined into the rhs of g* -- * then the binding for g* is floated out of the /\b -- * so we're back to square one - -- The silly binding for g* must be INLINE, so that no inlining - -- will happen in its RHS. - -- PS: Jun 98: actually this isn't important any more; - -- inlineUnconditionally will catch the type applicn - -- and inline it unconditionally, without ever trying - -- to simplify the RHS + -- The silly binding for g* must be IMustBeINLINEs, so that + -- we simply substitute for g* throughout. +\end{code} + + +%************************************************************************ +%* * +\subsection{Eta expansion} +%* * +%************************************************************************ + + Try eta expansion for RHSs + +We go for: + \x1..xn -> N ==> \x1..xn y1..ym -> N y1..ym + AND + N E1..En ==> let z1=E1 .. zn=En in \y1..ym -> N z1..zn y1..ym + +where (in both cases) N is a NORMAL FORM (i.e. no redexes anywhere) +wanting a suitable number of extra args. + +NB: the Ei may have unlifted type, but the simplifier (which is applied +to the result) deals OK with this). + +There is no point in looking for a combination of the two, +because that would leave use with some lets sandwiched between lambdas; +but it's awkward to detect that case, so we don't bother. + +\begin{code} +tryEtaExpansion :: InExpr -> SimplM InExpr +tryEtaExpansion rhs + | not opt_SimplDoLambdaEtaExpansion + || exprIsTrivial rhs -- Don't eta-expand a trival RHS + || null y_tys -- No useful expansion + = returnSmpl rhs + + | otherwise -- Consider eta expansion + = newIds y_tys ( \ y_bndrs -> + tick (EtaExpansion (head y_bndrs)) `thenSmpl_` + mapAndUnzipSmpl bind_z_arg args `thenSmpl` (\ (z_binds, z_args) -> + returnSmpl (mkLams x_bndrs $ + mkLets (catMaybes z_binds) $ + mkLams y_bndrs $ + mkApps (mkApps fun z_args) (map Var y_bndrs)))) + where + (x_bndrs, body) = collectValBinders rhs + (fun, args) = collectArgs body + no_of_xs = length x_bndrs + fun_arity = case fun of + Var v -> arityLowerBound (getIdArity v) + other -> 0 + + bind_z_arg arg | exprIsTrivial arg = returnSmpl (Nothing, arg) + | otherwise = newId (coreExprType arg) $ \ z -> + returnSmpl (Just (NonRec z arg), Var z) + + -- Note: I used to try to avoid the coreExprType call by using + -- the type of the binder. But this type doesn't necessarily + -- belong to the same substitution environment as this rhs; + -- and we are going to make extra term binders (y_bndrs) from the type + -- which will be processed with the rhs substitution environment. + -- This only went wrong in a mind bendingly complicated case. + (potential_extra_arg_tys, inner_ty) = splitFunTys (coreExprType body) + + y_tys :: [InType] + y_tys = take no_extras_wanted potential_extra_arg_tys + + no_extras_wanted :: Int + no_extras_wanted = + + -- We used to expand the arity to the previous arity fo the + -- function; but this is pretty dangerous. Consdier + -- f = \xy -> e + -- so that f has arity 2. Now float something into f's RHS: + -- f = let z = BIG in \xy -> e + -- The last thing we want to do now is to put some lambdas + -- outside, to get + -- f = \xy -> let z = BIG in e + -- + -- (bndr_arity - no_of_xs) `max` + + -- See if the body could obviously do with more args + (fun_arity - valArgCount args) `max` + + -- Finally, see if it's a state transformer, and xs is non-null + -- (so it's also a function not a thunk) in which + -- case we eta-expand on principle! This can waste work, + -- but usually doesn't. + -- I originally checked for a singleton type [ty] in this case + -- but then I found a situation in which I had + -- \ x -> let {..} in \ s -> f (...) s + -- AND f RETURNED A FUNCTION. That is, 's' wasn't the only + -- potential extra arg. + case (x_bndrs, potential_extra_arg_tys) of + (_:_, ty:_) -> case splitTyConApp_maybe ty of + Just (tycon,_) | tycon == statePrimTyCon -> 1 + other -> 0 + other -> 0 \end{code} @@ -274,8 +379,9 @@ mkRhsTyLam_help tyvars body e.g. \ x y -> f x y ===> f It is used - a) Before constructing an Unfolding, to - try to make the unfolding smaller; +-- OLD +-- a) Before constructing an Unfolding, to +-- try to make the unfolding smaller; b) In tidyCoreExpr, which is done just before converting to STG. But we only do this if @@ -283,8 +389,9 @@ But we only do this if The idea is that lambdas are often quite helpful: they indicate head normal forms, so we don't want to chuck them away lightly. - ii) It exposes a simple variable or a type application; in short - it exposes a "trivial" expression. (exprIsTrivial) +-- OLD: in core2stg we want to do this even if the result isn't trivial +-- ii) It exposes a simple variable or a type application; in short +-- it exposes a "trivial" expression. (exprIsTrivial) \begin{code} etaCoreExpr :: CoreExpr -> CoreExpr @@ -292,13 +399,12 @@ etaCoreExpr :: CoreExpr -> CoreExpr -- lambda into a bottom variable. Sigh etaCoreExpr expr@(Lam bndr body) - | opt_DoEtaReduction = check (reverse binders) body where (binders, body) = collectBinders expr check [] body - | exprIsTrivial body && not (any (`elemVarSet` body_fvs) binders) + | not (any (`elemVarSet` body_fvs) binders) = body -- Success! where body_fvs = exprFreeVars body @@ -315,76 +421,12 @@ etaCoreExpr expr = expr -- The common case %************************************************************************ %* * -\subsection{Eta expansion} -%* * -%************************************************************************ - -@etaExpandCount@ takes an expression, E, and returns an integer n, -such that - - E ===> (\x1::t1 x1::t2 ... xn::tn -> E x1 x2 ... xn) - -is a safe transformation. In particular, the transformation should -not cause work to be duplicated, unless it is ``cheap'' (see -@manifestlyCheap@ below). - -@etaExpandCount@ errs on the conservative side. It is always safe to -return 0. - -An application of @error@ is special, because it can absorb as many -arguments as you care to give it. For this special case we return -100, to represent "infinity", which is a bit of a hack. - -\begin{code} -etaExpandCount :: CoreExpr - -> Int -- Number of extra args you can safely abstract - -etaExpandCount (Lam b body) - | isId b - = 1 + etaExpandCount body - -etaExpandCount (Let bind body) - | all exprIsCheap (rhssOfBind bind) - = etaExpandCount body - -etaExpandCount (Case scrut _ alts) - | exprIsCheap scrut - = minimum [etaExpandCount rhs | (_,_,rhs) <- alts] - -etaExpandCount fun@(Var _) = eta_fun fun - -etaExpandCount (App fun (Type ty)) - = eta_fun fun -etaExpandCount (App fun arg) - | exprIsCheap arg = case etaExpandCount fun of - 0 -> 0 - n -> n-1 -- Knock off one - -etaExpandCount other = 0 -- Give up - -- Lit, Con, Prim, - -- non-val Lam, - -- Scc (pessimistic; ToDo), - -- Let with non-whnf rhs(s), - -- Case with non-whnf scrutinee - ------------------------------ -eta_fun :: CoreExpr -- The function - -> Int -- How many args it can safely be applied to - -eta_fun (App fun (Type ty)) = eta_fun fun -eta_fun (Var v) = arityLowerBound (getIdArity v) -eta_fun other = 0 -- Give up -\end{code} - - -%************************************************************************ -%* * \subsection{Case absorption and identity-case elimination} %* * %************************************************************************ \begin{code} -mkCase :: SwitchChecker -> OutExpr -> OutId -> [OutAlt] -> SimplM OutExpr +mkCase :: OutExpr -> OutId -> [OutAlt] -> SimplM OutExpr \end{code} @mkCase@ tries the following transformation (if possible): @@ -407,11 +449,11 @@ transformation is called Case Merging. It avoids that the same variable is scrutinised multiple times. \begin{code} -mkCase sw_chkr scrut outer_bndr outer_alts - | switchIsOn sw_chkr SimplCaseMerge +mkCase scrut outer_bndr outer_alts + | opt_SimplCaseMerge && maybeToBool maybe_case_in_default - = tick CaseMerge `thenSmpl_` + = tick (CaseMerge outer_bndr) `thenSmpl_` returnSmpl (Case scrut outer_bndr new_alts) -- Warning: don't call mkCase recursively! -- Firstly, there's no point, because inner alts have already had @@ -449,9 +491,9 @@ Now the identity-case transformation: and similar friends. \begin{code} -mkCase sw_chkr scrut case_bndr alts +mkCase scrut case_bndr alts | all identity_alt alts - = tick CaseIdentity `thenSmpl_` + = tick (CaseIdentity case_bndr) `thenSmpl_` returnSmpl scrut where identity_alt (DEFAULT, [], Var v) = v == case_bndr @@ -469,7 +511,7 @@ mkCase sw_chkr scrut case_bndr alts The catch-all case \begin{code} -mkCase sw_chkr other_scrut case_bndr other_alts +mkCase other_scrut case_bndr other_alts = returnSmpl (Case other_scrut case_bndr other_alts) \end{code} @@ -492,4 +534,11 @@ findAlt con alts matches (DEFAULT, _, _) = True matches (con1, _, _) = con == con1 + + +mkCoerce to_ty (Note (Coerce _ from_ty) expr) + | to_ty == from_ty = expr + | otherwise = Note (Coerce to_ty from_ty) expr +mkCoerce to_ty expr + = Note (Coerce to_ty (coreExprType expr)) expr \end{code} diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index aca723c605..5940184702 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -4,70 +4,115 @@ \section[Simplify]{The main module of the simplifier} \begin{code} -module Simplify ( simplBind ) where +module Simplify ( simplTopBinds, simplExpr ) where #include "HsVersions.h" -import CmdLineOpts ( switchIsOn, opt_SccProfilingOn, opt_PprStyle_Debug, - opt_NoPreInlining, opt_DictsStrict, opt_D_dump_inlinings, +import CmdLineOpts ( intSwitchSet, + opt_SccProfilingOn, opt_PprStyle_Debug, opt_SimplDoEtaReduction, + opt_SimplNoPreInlining, opt_DictsStrict, opt_SimplPedanticBottoms, + opt_SimplDoCaseElim, SimplifierSwitch(..) ) import SimplMonad -import SimplUtils ( mkCase, etaCoreExpr, etaExpandCount, findAlt, mkRhsTyLam, - simplBinder, simplBinders, simplIds, findDefault +import SimplUtils ( mkCase, transformRhs, findAlt, + simplBinder, simplBinders, simplIds, findDefault, mkCoerce ) -import Var ( TyVar, mkSysTyVar, tyVarKind ) +import Var ( TyVar, mkSysTyVar, tyVarKind, maybeModifyIdInfo ) import VarEnv import VarSet -import Id ( Id, idType, - getIdUnfolding, setIdUnfolding, +import Id ( Id, idType, idInfo, idUnique, + getIdUnfolding, setIdUnfolding, isExportedId, getIdSpecialisation, setIdSpecialisation, getIdDemandInfo, setIdDemandInfo, getIdArity, setIdArity, - getIdStrictness, - setInlinePragma, getInlinePragma, idMustBeINLINEd, - idWantsToBeINLINEd + getIdStrictness, + setInlinePragma, getInlinePragma, idMustBeINLINEd ) import IdInfo ( InlinePragInfo(..), OccInfo(..), StrictnessInfo(..), - ArityInfo, atLeastArity, arityLowerBound, unknownArity + ArityInfo(..), atLeastArity, arityLowerBound, unknownArity, + specInfo, inlinePragInfo, zapLamIdInfo ) import Demand ( Demand, isStrict, wwLazy ) import Const ( isWHNFCon, conOkForAlt ) import ConFold ( tryPrimOp ) -import PrimOp ( PrimOp, primOpStrictness ) -import DataCon ( DataCon, dataConNumInstArgs, dataConStrictMarks, dataConSig, dataConArgTys ) +import PrimOp ( PrimOp, primOpStrictness, primOpType ) +import DataCon ( DataCon, dataConNumInstArgs, dataConRepStrictness, dataConSig, dataConArgTys ) import Const ( Con(..) ) -import MagicUFs ( applyMagicUnfoldingFun ) -import Name ( isExported, isLocallyDefined ) +import Name ( isLocallyDefined ) import CoreSyn -import CoreUnfold ( Unfolding(..), UnfoldingGuidance(..), - mkUnfolding, smallEnoughToInline, - isEvaldUnfolding, unfoldAlways - ) -import CoreUtils ( IdSubst, SubstCoreExpr(..), - cheapEqExpr, exprIsDupable, exprIsWHNF, exprIsTrivial, - coreExprType, coreAltsType, exprIsCheap, substExpr, +import CoreFVs ( exprFreeVars ) +import CoreUnfold ( Unfolding(..), mkUnfolding, callSiteInline, + isEvaldUnfolding, blackListed ) +import CoreUtils ( cheapEqExpr, exprIsDupable, exprIsWHNF, exprIsTrivial, + coreExprType, coreAltsType, exprIsCheap, exprArity, + exprOkForSpeculation, FormSummary(..), mkFormSummary, whnfOrBottom ) -import SpecEnv ( lookupSpecEnv, isEmptySpecEnv, substSpecEnv ) +import Rules ( lookupRule ) import CostCentre ( isSubsumedCCS, currentCCS, isEmptyCC ) -import Type ( Type, mkTyVarTy, mkTyVarTys, isUnLiftedType, fullSubstTy, +import Type ( Type, mkTyVarTy, mkTyVarTys, isUnLiftedType, mkFunTy, splitFunTys, splitTyConApp_maybe, splitFunTy_maybe, - applyTy, applyTys, funResultTy, isDictTy, isDataType + funResultTy, isDictTy, isDataType, applyTy, applyTys, mkFunTys + ) +import Subst ( Subst, mkSubst, emptySubst, substExpr, substTy, + substEnv, lookupInScope, lookupSubst, substRules ) import TyCon ( isDataTyCon, tyConDataCons, tyConClass_maybe, tyConArity, isDataTyCon ) import TysPrim ( realWorldStatePrimTy ) -import PrelVals ( realWorldPrimId ) -import BasicTypes ( StrictnessMark(..) ) +import PrelInfo ( realWorldPrimId ) +import BasicTypes ( TopLevelFlag(..), isTopLevel ) import Maybes ( maybeToBool ) -import Util ( zipWithEqual, stretchZipEqual ) +import Util ( zipWithEqual, stretchZipEqual, lengthExceeds ) import PprCore import Outputable \end{code} The guts of the simplifier is in this module, but the driver -loop for the simplifier is in SimplPgm.lhs. +loop for the simplifier is in SimplCore.lhs. + + +%************************************************************************ +%* * +\subsection{Bindings} +%* * +%************************************************************************ + +\begin{code} +simplTopBinds :: [InBind] -> SimplM [OutBind] + +simplTopBinds binds + = -- Put all the top-level binders into scope at the start + -- so that if a transformation rule has unexpectedly brought + -- anything into scope, then we don't get a complaint about that. + -- It's rather as if the top-level binders were imported. + extendInScopes top_binders $ + simpl_binds binds `thenSmpl` \ (binds', _) -> + freeTick SimplifierDone `thenSmpl_` + returnSmpl binds' + where + top_binders = bindersOfBinds binds + + simpl_binds [] = returnSmpl ([], panic "simplTopBinds corner") + simpl_binds (NonRec bndr rhs : binds) = simplLazyBind TopLevel bndr bndr rhs (simpl_binds binds) + simpl_binds (Rec pairs : binds) = simplRecBind TopLevel pairs (map fst pairs) (simpl_binds binds) + + +simplRecBind :: TopLevelFlag -> [(InId, InExpr)] -> [OutId] + -> SimplM (OutStuff a) -> SimplM (OutStuff a) +simplRecBind top_lvl pairs bndrs' thing_inside + = go pairs bndrs' `thenSmpl` \ (binds', stuff) -> + returnSmpl (addBind (Rec (flattenBinds binds')) stuff) + where + go [] _ = thing_inside `thenSmpl` \ stuff -> + returnSmpl ([], stuff) + + go ((bndr, rhs) : pairs) (bndr' : bndrs') + = simplLazyBind top_lvl bndr bndr' rhs (go pairs bndrs') + -- Don't float unboxed bindings out, + -- because we can't "rec" them +\end{code} %************************************************************************ @@ -124,130 +169,219 @@ might do the same again. \begin{code} -simplExpr :: CoreExpr -> SimplCont -> SimplM CoreExpr -simplExpr expr cont = simplExprB expr cont `thenSmpl` \ (binds, (_, body)) -> - returnSmpl (mkLetBinds binds body) +simplExpr :: CoreExpr -> SimplM CoreExpr +simplExpr expr = getSubst `thenSmpl` \ subst -> + simplExprC expr (Stop (substTy subst (coreExprType expr))) + -- The type in the Stop continuation is usually not used + -- It's only needed when discarding continuations after finding + -- a function that returns bottom -simplExprB :: InExpr -> SimplCont -> SimplM OutExprStuff +simplExprC :: CoreExpr -> SimplCont -> SimplM CoreExpr + -- Simplify an expression, given a continuation -simplExprB (Note InlineCall (Var v)) cont - = simplVar True v cont +simplExprC expr cont = simplExprF expr cont `thenSmpl` \ (floats, (_, body)) -> + returnSmpl (mkLets floats body) -simplExprB (Var v) cont - = simplVar False v cont +simplExprF :: InExpr -> SimplCont -> SimplM OutExprStuff + -- Simplify an expression, returning floated binds -simplExprB expr@(Con (PrimOp op) args) cont - = simplType (coreExprType expr) `thenSmpl` \ expr_ty -> - getInScope `thenSmpl` \ in_scope -> - getSubstEnv `thenSmpl` \ se -> - let - (val_arg_demands, _) = primOpStrictness op +simplExprF (Var v) cont + = simplVar v cont - -- Main game plan: loop through the arguments, simplifying - -- each of them with an ArgOf continuation. Getting the right - -- cont_ty in the ArgOf continuation is a bit of a nuisance. - go [] ds args' = rebuild_primop (reverse args') - go (arg:args) ds args' - | isTypeArg arg = setSubstEnv se (simplArg arg) `thenSmpl` \ arg' -> - go args ds (arg':args') - go (arg:args) (d:ds) args' - | not (isStrict d) = setSubstEnv se (simplArg arg) `thenSmpl` \ arg' -> - go args ds (arg':args') - | otherwise = setSubstEnv se (simplExprB arg (mk_cont args ds args')) - - cont_ty = contResultType in_scope expr_ty cont - mk_cont args ds args' = ArgOf NoDup (\ arg' -> go args ds (arg':args')) cont_ty - in - go args val_arg_demands [] - where +simplExprF expr@(Con (PrimOp op) args) cont + = getSubstEnv `thenSmpl` \ se -> + prepareArgs (ppr op) + (primOpType op) + (primOpStrictness op) + (pushArgs se args cont) $ \ args1 cont1 -> - rebuild_primop args' - = -- Try the prim op simplification + let + -- Boring... we may have too many arguments now, so we push them back + n_args = length args + args2 = ASSERT( length args1 >= n_args ) + take n_args args1 + cont2 = pushArgs emptySubstEnv (drop n_args args1) cont1 + in + -- Try the prim op simplification -- It's really worth trying simplExpr again if it succeeds, -- because you can find -- case (eqChar# x 'a') of ... -- ==> -- case (case x of 'a' -> True; other -> False) of ... - case tryPrimOp op args' of - Just e' -> zapSubstEnv (simplExprB e' cont) - Nothing -> rebuild (Con (PrimOp op) args') cont + case tryPrimOp op args2 of + Just e' -> zapSubstEnv (simplExprF e' cont2) + Nothing -> rebuild (Con (PrimOp op) args2) cont2 -simplExprB (Con con@(DataCon _) args) cont - = simplConArgs args $ \ args' -> - rebuild (Con con args') cont +simplExprF (Con con@(DataCon _) args) cont + = freeTick LeafVisit `thenSmpl_` + simplConArgs args ( \ args' -> + rebuild (Con con args') cont) -simplExprB expr@(Con con@(Literal _) args) cont +simplExprF expr@(Con con@(Literal _) args) cont = ASSERT( null args ) + freeTick LeafVisit `thenSmpl_` rebuild expr cont -simplExprB (App fun arg) cont +simplExprF (App fun arg) cont = getSubstEnv `thenSmpl` \ se -> - simplExprB fun (ApplyTo NoDup arg se cont) + simplExprF fun (ApplyTo NoDup arg se cont) -simplExprB (Case scrut bndr alts) cont +simplExprF (Case scrut bndr alts) cont = getSubstEnv `thenSmpl` \ se -> - simplExprB scrut (Select NoDup bndr alts se cont) + simplExprF scrut (Select NoDup bndr alts se cont) + + +simplExprF (Let (Rec pairs) body) cont + = simplIds (map fst pairs) $ \ bndrs' -> + -- NB: bndrs' don't have unfoldings or spec-envs + -- We add them as we go down, using simplPrags -simplExprB (Note (Coerce to from) e) cont - | to == from = simplExprB e cont - | otherwise = getSubstEnv `thenSmpl` \ se -> - simplExprB e (CoerceIt NoDup to se cont) + simplRecBind NotTopLevel pairs bndrs' (simplExprF body cont) + +simplExprF expr@(Lam _ _) cont = simplLam expr cont +simplExprF (Type ty) cont + = ASSERT( case cont of { Stop _ -> True; ArgOf _ _ _ -> True; other -> False } ) + simplType ty `thenSmpl` \ ty' -> + rebuild (Type ty') cont + +simplExprF (Note (Coerce to from) e) cont + | to == from = simplExprF e cont + | otherwise = getSubst `thenSmpl` \ subst -> + simplExprF e (CoerceIt (substTy subst to) cont) -- hack: we only distinguish subsumed cost centre stacks for the purposes of -- inlining. All other CCCSs are mapped to currentCCS. -simplExprB (Note (SCC cc) e) cont +simplExprF (Note (SCC cc) e) cont = setEnclosingCC currentCCS $ - simplExpr e Stop `thenSmpl` \ e -> + simplExpr e `thenSmpl` \ e -> rebuild (mkNote (SCC cc) e) cont -simplExprB (Note note e) cont - = simplExpr e Stop `thenSmpl` \ e' -> - rebuild (mkNote note e') cont +simplExprF (Note InlineCall e) cont + = simplExprF e (InlinePlease cont) + +-- Comments about the InlineMe case +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Don't inline in the RHS of something that has an +-- inline pragma. But be careful that the InScopeEnv that +-- we return does still have inlinings on! +-- +-- It really is important to switch off inlinings. This function +-- may be inlinined in other modules, so we don't want to remove +-- (by inlining) calls to functions that have specialisations, or +-- that may have transformation rules in an importing scope. +-- E.g. {-# INLINE f #-} +-- f x = ...g... +-- and suppose that g is strict *and* has specialisations. +-- If we inline g's wrapper, we deny f the chance of getting +-- the specialised version of g when f is inlined at some call site +-- (perhaps in some other module). + +simplExprF (Note InlineMe e) cont + = case cont of + Stop _ -> -- Totally boring continuation + -- Don't inline inside an INLINE expression + switchOffInlining (simplExpr e) `thenSmpl` \ e' -> + rebuild (mkNote InlineMe e') cont + + other -> -- Dissolve the InlineMe note if there's + -- an interesting context of any kind to combine with + -- (even a type application -- anything except Stop) + simplExprF e cont -- A non-recursive let is dealt with by simplBeta -simplExprB (Let (NonRec bndr rhs) body) cont - = getSubstEnv `thenSmpl` \ se -> - simplBeta bndr rhs se body cont - -simplExprB (Let (Rec pairs) body) cont - = simplRecBind pairs (simplExprB body cont) - --- Type-beta reduction -simplExprB expr@(Lam bndr body) cont@(ApplyTo _ (Type ty_arg) arg_se body_cont) - = ASSERT( isTyVar bndr ) - tick BetaReduction `thenSmpl_` - setSubstEnv arg_se (simplType ty_arg) `thenSmpl` \ ty' -> - extendTySubst bndr ty' $ - simplExprB body body_cont - --- Ordinary beta reduction -simplExprB expr@(Lam bndr body) cont@(ApplyTo _ arg arg_se body_cont) - = tick BetaReduction `thenSmpl_` - simplBeta bndr' arg arg_se body body_cont +simplExprF (Let (NonRec bndr rhs) body) cont + = getSubstEnv `thenSmpl` \ se -> + simplBeta bndr rhs se (contResultType cont) $ + simplExprF body cont +\end{code} + + +--------------------------------- + +\begin{code} +simplLam fun cont + = go fun cont where - bndr' = zapLambdaBndr bndr body body_cont + zap_it = mkLamBndrZapper fun (countArgs cont) + cont_ty = contResultType cont + + -- Type-beta reduction + go (Lam bndr body) (ApplyTo _ (Type ty_arg) arg_se body_cont) + = ASSERT( isTyVar bndr ) + tick (BetaReduction bndr) `thenSmpl_` + getInScope `thenSmpl` \ in_scope -> + let + ty' = substTy (mkSubst in_scope arg_se) ty_arg + in + extendSubst bndr (DoneTy ty') + (go body body_cont) + + -- Ordinary beta reduction + go (Lam bndr body) cont@(ApplyTo _ arg arg_se body_cont) + = tick (BetaReduction bndr) `thenSmpl_` + simplBeta zapped_bndr arg arg_se cont_ty + (go body body_cont) + where + zapped_bndr = zap_it bndr + + -- Not enough args + go lam@(Lam _ _) cont = completeLam [] lam cont + + -- Exactly enough args + go expr cont = simplExprF expr cont -simplExprB (Lam bndr body) cont + +-- completeLam deals with the case where a lambda doesn't have an ApplyTo +-- continuation. Try for eta reduction, but *only* if we get all +-- the way to an exprIsTrivial expression. +-- 'acc' holds the simplified binders, in reverse order + +completeLam acc (Lam bndr body) cont = simplBinder bndr $ \ bndr' -> - simplExpr body Stop `thenSmpl` \ body' -> - rebuild (Lam bndr' body') cont + completeLam (bndr':acc) body cont -simplExprB (Type ty) cont - = ASSERT( case cont of { Stop -> True; ArgOf _ _ _ -> True; other -> False } ) - simplType ty `thenSmpl` \ ty' -> - rebuild (Type ty') cont -\end{code} +completeLam acc body cont + = simplExpr body `thenSmpl` \ body' -> + case (opt_SimplDoEtaReduction, check_eta acc body') of + (True, Just body'') -- Eta reduce! + -> tick (EtaReduction (head acc)) `thenSmpl_` + rebuild body'' cont ---------------------------------- -\begin{code} -simplArg :: InArg -> SimplM OutArg -simplArg arg = simplExpr arg Stop + other -> -- No eta reduction + rebuild (foldl (flip Lam) body' acc) cont + -- Remember, acc is the reversed binders + where + -- NB: the binders are reversed + check_eta (b : bs) (App fun arg) + | (varToCoreExpr b `cheapEqExpr` arg) + = check_eta bs fun + + check_eta [] body + | exprIsTrivial body && -- ONLY if the body is trivial + not (any (`elemVarSet` body_fvs) acc) + = Just body -- Success! + where + body_fvs = exprFreeVars body + + check_eta _ _ = Nothing -- Bale out + +mkLamBndrZapper :: CoreExpr -- Function + -> Int -- Number of args + -> Id -> Id -- Use this to zap the binders +mkLamBndrZapper fun n_args + | saturated fun n_args = \b -> b + | otherwise = \b -> maybeModifyIdInfo zapLamIdInfo b + where + saturated (Lam b e) 0 = False + saturated (Lam b e) n = saturated e (n-1) + saturated e n = True \end{code} + --------------------------------- simplConArgs makes sure that the arguments all end up being atomic. -That means it may generate some Lets, hence the +That means it may generate some Lets, hence the strange type \begin{code} simplConArgs :: [InArg] -> ([OutArg] -> SimplM OutExprStuff) -> SimplM OutExprStuff @@ -255,7 +389,7 @@ simplConArgs [] thing_inside = thing_inside [] simplConArgs (arg:args) thing_inside - = switchOffInlining (simplArg arg) `thenSmpl` \ arg' -> + = switchOffInlining (simplExpr arg) `thenSmpl` \ arg' -> -- Simplify the RHS with inlining switched off, so that -- only absolutely essential things will happen. @@ -275,282 +409,159 @@ simplConArgs (arg:args) thing_inside \begin{code} simplType :: InType -> SimplM OutType simplType ty - = getTyEnv `thenSmpl` \ (ty_subst, in_scope) -> - returnSmpl (fullSubstTy ty_subst in_scope ty) + = getSubst `thenSmpl` \ subst -> + returnSmpl (substTy subst ty) \end{code} -\begin{code} --- Find out whether the lambda is saturated, --- if not zap the over-optimistic info in the binder - -zapLambdaBndr bndr body body_cont - | isTyVar bndr || safe_info || definitely_saturated 20 body body_cont - -- The "20" is to catch pathalogical cases with bazillions of arguments - -- because we are using an n**2 algorithm here - = bndr -- No need to zap - | otherwise - = setInlinePragma (setIdDemandInfo bndr wwLazy) - safe_inline_prag - - where - inline_prag = getInlinePragma bndr - demand = getIdDemandInfo bndr - - safe_info = is_safe_inline_prag && not (isStrict demand) - - is_safe_inline_prag = case inline_prag of - ICanSafelyBeINLINEd StrictOcc nalts -> False - ICanSafelyBeINLINEd LazyOcc nalts -> False - other -> True - - safe_inline_prag = case inline_prag of - ICanSafelyBeINLINEd _ nalts - -> ICanSafelyBeINLINEd InsideLam nalts - other -> inline_prag - - definitely_saturated :: Int -> CoreExpr -> SimplCont -> Bool - definitely_saturated 0 _ _ = False -- Too expensive to find out - definitely_saturated n (Lam _ body) (ApplyTo _ _ _ cont) = definitely_saturated (n-1) body cont - definitely_saturated n (Lam _ _) other_cont = False - definitely_saturated n _ _ = True -\end{code} - %************************************************************************ %* * -\subsection{Variables} +\subsection{Binding} %* * %************************************************************************ -Coercions -~~~~~~~~~ -\begin{code} -simplVar inline_call var cont - = getValEnv `thenSmpl` \ (id_subst, in_scope) -> - case lookupVarEnv id_subst var of - Just (Done e) - -> zapSubstEnv (simplExprB e cont) - - Just (SubstMe e ty_subst id_subst) - -> setSubstEnv (ty_subst, id_subst) (simplExprB e cont) - - Nothing -> let - var' = case lookupVarSet in_scope var of - Just v' -> v' - Nothing -> -#ifdef DEBUG - if isLocallyDefined var && not (idMustBeINLINEd var) then - -- Not in scope - pprTrace "simplVar:" (ppr var) var - else -#endif - var - in - getSwitchChecker `thenSmpl` \ sw_chkr -> - completeVar sw_chkr in_scope inline_call var' cont - -completeVar sw_chkr in_scope inline_call var cont - -{- MAGIC UNFOLDINGS NOT USED NOW - | maybeToBool maybe_magic_result - = tick MagicUnfold `thenSmpl_` - magic_result --} - -- Look for existing specialisations before trying inlining - | maybeToBool maybe_specialisation - = tick SpecialisationDone `thenSmpl_` - setSubstEnv (spec_bindings, emptyVarEnv) ( - -- See note below about zapping the substitution here - - simplExprB spec_template remaining_cont - ) +@simplBeta@ is used for non-recursive lets in expressions, +as well as true beta reduction. - -- Don't actually inline the scrutinee when we see - -- case x of y { .... } - -- and x has unfolding (C a b). Why not? Because - -- we get a silly binding y = C a b. If we don't - -- inline knownCon can directly substitute x for y instead. - | has_unfolding && var_is_case_scrutinee && unfolding_is_constr - = knownCon (Var var) con con_args cont +Very similar to @simplLazyBind@, but not quite the same. - -- Look for an unfolding. There's a binding for the - -- thing, but perhaps we want to inline it anyway - | has_unfolding && (inline_call || ok_to_inline) - = getEnclosingCC `thenSmpl` \ encl_cc -> - if must_be_unfolded || costCentreOk encl_cc var - then -- OK to unfold - - tickUnfold var `thenSmpl_` ( - - zapSubstEnv $ - -- The template is already simplified, so don't re-substitute. - -- This is VITAL. Consider - -- let x = e in - -- let y = \z -> ...x... in - -- \ x -> ...y... - -- We'll clone the inner \x, adding x->x' in the id_subst - -- Then when we inline y, we must *not* replace x by x' in - -- the inlined copy!! -#ifdef DEBUG - if opt_D_dump_inlinings then - pprTrace "Inlining:" (ppr var <+> ppr unf_template) $ - simplExprB unf_template cont - else -#endif - simplExprB unf_template cont - ) - else +\begin{code} +simplBeta :: InId -- Binder + -> InExpr -> SubstEnv -- Arg, with its subst-env + -> OutType -- Type of thing computed by the context + -> SimplM OutExprStuff -- The body + -> SimplM OutExprStuff #ifdef DEBUG - pprTrace "Inlining disallowed due to CC:\n" (ppr encl_cc <+> ppr unf_template <+> ppr (coreExprCc unf_template)) $ +simplBeta bndr rhs rhs_se cont_ty thing_inside + | isTyVar bndr + = pprPanic "simplBeta" (ppr bndr <+> ppr rhs) #endif - -- Can't unfold because of bad cost centre - rebuild (Var var) cont - | inline_call -- There was an InlineCall note, but we didn't inline! - = rebuild (Note InlineCall (Var var)) cont +simplBeta bndr rhs rhs_se cont_ty thing_inside + | preInlineUnconditionally bndr && not opt_SimplNoPreInlining + = tick (PreInlineUnconditionally bndr) `thenSmpl_` + extendSubst bndr (ContEx rhs_se rhs) thing_inside | otherwise - = rebuild (Var var) cont - - where - unfolding = getIdUnfolding var - -{- MAGIC UNFOLDINGS NOT USED CURRENTLY - ---------- Magic unfolding stuff - maybe_magic_result = case unfolding of - MagicUnfolding _ magic_fn -> applyMagicUnfoldingFun magic_fn - cont - other -> Nothing - Just magic_result = maybe_magic_result --} + = -- Simplify the RHS + simplBinder bndr $ \ bndr' -> + simplArg (idType bndr') (getIdDemandInfo bndr) + rhs rhs_se cont_ty $ \ rhs' -> + + -- Now complete the binding and simplify the body + completeBeta bndr bndr' rhs' thing_inside + +completeBeta bndr bndr' rhs' thing_inside + | isUnLiftedType (idType bndr') && not (exprOkForSpeculation rhs') + -- Make a case expression instead of a let + -- These can arise either from the desugarer, + -- or from beta reductions: (\x.e) (x +# y) + = getInScope `thenSmpl` \ in_scope -> + thing_inside `thenSmpl` \ (floats, (_, body)) -> + returnSmpl ([], (in_scope, Case rhs' bndr' [(DEFAULT, [], mkLets floats body)])) - ---------- Unfolding stuff - has_unfolding = case unfolding of - CoreUnfolding _ _ _ -> True - other -> False - CoreUnfolding form guidance unf_template = unfolding - - -- overrides cost-centre business - must_be_unfolded = case getInlinePragma var of - IMustBeINLINEd -> True - _ -> False - - ok_to_inline = okToInline sw_chkr in_scope var form guidance cont - unfolding_is_constr = case unf_template of - Con con _ -> conOkForAlt con - other -> False - Con con con_args = unf_template + | otherwise + = completeBinding bndr bndr' rhs' thing_inside +\end{code} - ---------- Specialisation stuff - ty_args = initial_ty_args cont - remaining_cont = drop_ty_args cont - maybe_specialisation = lookupSpecEnv (ppr var) (getIdSpecialisation var) ty_args - Just (spec_bindings, spec_template) = maybe_specialisation - initial_ty_args (ApplyTo _ (Type ty) (ty_subst,_) cont) - = fullSubstTy ty_subst in_scope ty : initial_ty_args cont - -- Having to do the substitution here is a bit of a bore - initial_ty_args other_cont = [] +\begin{code} +simplArg :: OutType -> Demand + -> InExpr -> SubstEnv + -> OutType -- Type of thing computed by the context + -> (OutExpr -> SimplM OutExprStuff) + -> SimplM OutExprStuff +simplArg arg_ty demand arg arg_se cont_ty thing_inside + | isStrict demand || + isUnLiftedType arg_ty || + (opt_DictsStrict && isDictTy arg_ty && isDataType arg_ty) + -- Return true only for dictionary types where the dictionary + -- has more than one component (else we risk poking on the component + -- of a newtype dictionary) + = getSubstEnv `thenSmpl` \ body_se -> + transformRhs arg `thenSmpl` \ t_arg -> + setSubstEnv arg_se (simplExprF t_arg (ArgOf NoDup cont_ty $ \ arg' -> + setSubstEnv body_se (thing_inside arg') + )) -- NB: we must restore body_se before carrying on with thing_inside!! - drop_ty_args (ApplyTo _ (Type _) _ cont) = drop_ty_args cont - drop_ty_args other_cont = other_cont + | otherwise + = simplRhs NotTopLevel True arg_ty arg arg_se thing_inside +\end{code} - ---------- Switches - var_is_case_scrutinee = case cont of - Select _ _ _ _ _ -> True - other -> False +completeBinding + - deals only with Ids, not TyVars + - take an already-simplified RHS ------------ costCentreOk --- costCentreOk checks that it's ok to inline this thing --- The time it *isn't* is this: --- --- f x = let y = E in --- scc "foo" (...y...) --- --- Here y has a "current cost centre", and we can't inline it inside "foo", --- regardless of whether E is a WHNF or not. --- --- We can inline a top-level binding anywhere. - -costCentreOk ccs_encl x - = not opt_SccProfilingOn - || isSubsumedCCS ccs_encl -- can unfold anything into a subsumed scope - || not (isLocallyDefined x) -\end{code} +It does *not* attempt to do let-to-case. Why? Because they are used for + - top-level bindings + (when let-to-case is impossible) -%************************************************************************ -%* * -\subsection{Bindings} -%* * -%************************************************************************ + - many situations where the "rhs" is known to be a WHNF + (so let-to-case is inappropriate). \begin{code} -simplBind :: InBind -> SimplM (OutStuff a) -> SimplM (OutStuff a) - -simplBind (NonRec bndr rhs) thing_inside - = simplTopRhs bndr rhs `thenSmpl` \ (binds, in_scope, rhs', arity) -> - setInScope in_scope $ - completeBindNonRec (bndr `setIdArity` arity) rhs' thing_inside `thenSmpl` \ stuff -> - returnSmpl (addBinds binds stuff) - -simplBind (Rec pairs) thing_inside - = simplRecBind pairs thing_inside - -- The assymetry between the two cases is a bit unclean - -simplRecBind :: [(InId, InExpr)] -> SimplM (OutStuff a) -> SimplM (OutStuff a) -simplRecBind pairs thing_inside - = simplIds (map fst pairs) $ \ bndrs' -> - -- NB: bndrs' don't have unfoldings or spec-envs - -- We add them as we go down, using simplPrags - - go (pairs `zip` bndrs') `thenSmpl` \ (pairs', stuff) -> - returnSmpl (addBind (Rec pairs') stuff) - where - go [] = thing_inside `thenSmpl` \ stuff -> - returnSmpl ([], stuff) - - go (((bndr, rhs), bndr') : pairs) - = simplTopRhs bndr rhs `thenSmpl` \ (rhs_binds, in_scope, rhs', arity) -> - setInScope in_scope $ - completeBindRec bndr (bndr' `setIdArity` arity) - rhs' (go pairs) `thenSmpl` \ (pairs', stuff) -> - returnSmpl (flatten rhs_binds pairs', stuff) - - flatten (NonRec b r : binds) prs = (b,r) : flatten binds prs - flatten (Rec prs1 : binds) prs2 = prs1 ++ flatten binds prs2 - flatten [] prs = prs +completeBinding :: InId -- Binder + -> OutId -- New binder + -> OutExpr -- Simplified RHS + -> SimplM (OutStuff a) -- Thing inside + -> SimplM (OutStuff a) +completeBinding old_bndr new_bndr new_rhs thing_inside + | isDeadBinder old_bndr -- This happens; for example, the case_bndr during case of + -- known constructor: case (a,b) of x { (p,q) -> ... } + -- Here x isn't mentioned in the RHS, so we don't want to + -- create the (dead) let-binding let x = (a,b) in ... + = thing_inside -completeBindRec bndr bndr' rhs' thing_inside - | postInlineUnconditionally bndr etad_rhs + | postInlineUnconditionally old_bndr new_rhs + -- Maybe we don't need a let-binding! Maybe we can just + -- inline it right away. Unlike the preInlineUnconditionally case + -- we are allowed to look at the RHS. + -- -- NB: a loop breaker never has postInlineUnconditionally True -- and non-loop-breakers only have *forward* references -- Hence, it's safe to discard the binding - = tick PostInlineUnconditionally `thenSmpl_` - extendIdSubst bndr (Done etad_rhs) thing_inside + = tick (PostInlineUnconditionally old_bndr) `thenSmpl_` + extendSubst old_bndr (DoneEx new_rhs) + thing_inside | otherwise - = -- Here's the only difference from completeBindNonRec: we - -- don't do simplBinder first, because we've already - -- done simplBinder on the recursive binders - simplPrags bndr bndr' etad_rhs `thenSmpl` \ bndr'' -> - modifyInScope bndr'' $ - thing_inside `thenSmpl` \ (pairs, res) -> - returnSmpl ((bndr'', etad_rhs) : pairs, res) - where - etad_rhs = etaCoreExpr rhs' -\end{code} + = getSubst `thenSmpl` \ subst -> + let + bndr_info = idInfo old_bndr + old_rules = specInfo bndr_info + new_rules = substRules subst old_rules + + -- The new binding site Id needs its specialisations re-attached + bndr_w_arity = new_bndr `setIdArity` ArityAtLeast (exprArity new_rhs) + + binding_site_id + | isEmptyCoreRules old_rules = bndr_w_arity + | otherwise = bndr_w_arity `setIdSpecialisation` new_rules + + -- At the occurrence sites we want to know the unfolding, + -- and the occurrence info of the original + -- (simplBinder cleaned up the inline prag of the original + -- to eliminate un-stable info, in case this expression is + -- simplified a second time; hence the need to reattach it) + occ_site_id = binding_site_id + `setIdUnfolding` mkUnfolding new_rhs + `setInlinePragma` inlinePragInfo bndr_info + in + modifyInScope occ_site_id thing_inside `thenSmpl` \ stuff -> + returnSmpl (addBind (NonRec binding_site_id new_rhs) stuff) +\end{code} %************************************************************************ %* * -\subsection{Right hand sides} +\subsection{simplLazyBind} %* * %************************************************************************ -simplRhs basically just simplifies the RHS of a let(rec). +simplLazyBind basically just simplifies the RHS of a let(rec). It does two important optimisations though: * It floats let(rec)s out of the RHS, even if they @@ -559,237 +570,325 @@ It does two important optimisations though: * It does eta expansion \begin{code} -simplTopRhs :: InId -> InExpr - -> SimplM ([OutBind], InScopeEnv, OutExpr, ArityInfo) -simplTopRhs bndr rhs - = getSubstEnv `thenSmpl` \ bndr_se -> - simplRhs bndr bndr_se rhs - -simplRhs bndr bndr_se rhs - | idWantsToBeINLINEd bndr -- Don't inline in the RHS of something that has an - -- inline pragma. But be careful that the InScopeEnv that - -- we return does still have inlinings on! - = switchOffInlining (simplExpr rhs Stop) `thenSmpl` \ rhs' -> - getInScope `thenSmpl` \ in_scope -> - returnSmpl ([], in_scope, rhs', unknownArity) +simplLazyBind :: TopLevelFlag + -> InId -> OutId + -> InExpr -- The RHS + -> SimplM (OutStuff a) -- The body of the binding + -> SimplM (OutStuff a) +-- When called, the subst env is correct for the entire let-binding +-- and hence right for the RHS. +-- Also the binder has already been simplified, and hence is in scope + +simplLazyBind top_lvl bndr bndr' rhs thing_inside + | preInlineUnconditionally bndr && not opt_SimplNoPreInlining + = tick (PreInlineUnconditionally bndr) `thenSmpl_` + getSubstEnv `thenSmpl` \ rhs_se -> + (extendSubst bndr (ContEx rhs_se rhs) thing_inside) | otherwise - = -- Swizzle the inner lets past the big lambda (if any) - mkRhsTyLam rhs `thenSmpl` \ swizzled_rhs -> - - -- Simplify the swizzled RHS - simplRhs2 bndr bndr_se swizzled_rhs `thenSmpl` \ (floats, (in_scope, rhs', arity)) -> - - if not (null floats) && exprIsWHNF rhs' then -- Do the float - tick LetFloatFromLet `thenSmpl_` - returnSmpl (floats, in_scope, rhs', arity) - else -- Don't do it - getInScope `thenSmpl` \ in_scope -> - returnSmpl ([], in_scope, mkLetBinds floats rhs', arity) + = -- Simplify the RHS + getSubstEnv `thenSmpl` \ rhs_se -> + + simplRhs top_lvl False {- Not ok to float unboxed -} + (idType bndr') + rhs rhs_se $ \ rhs' -> + + -- Now compete the binding and simplify the body + completeBinding bndr bndr' rhs' thing_inside \end{code} ---------------------------------------------------------- - Try eta expansion for RHSs -We need to pass in the substitution environment for the RHS, because -it might be different to the current one (see simplBeta, as called -from simplExpr for an applied lambda). The binder needs to \begin{code} -simplRhs2 bndr bndr_se (Let bind body) - = simplBind bind (simplRhs2 bndr bndr_se body) - -simplRhs2 bndr bndr_se rhs - | null ids -- Prevent eta expansion for both thunks - -- (would lose sharing) and variables (nothing gained). - -- To see why we ignore it for thunks, consider - -- let f = lookup env key in (f 1, f 2) - -- We'd better not eta expand f just because it is - -- always applied! - -- - -- Also if there isn't a lambda at the top we use - -- simplExprB so that we can do (more) let-floating - = simplExprB rhs Stop `thenSmpl` \ (binds, (in_scope, rhs')) -> - returnSmpl (binds, (in_scope, rhs', unknownArity)) - - | otherwise -- Consider eta expansion - = getSwitchChecker `thenSmpl` \ sw_chkr -> - getInScope `thenSmpl` \ in_scope -> - simplBinders tyvars $ \ tyvars' -> - simplBinders ids $ \ ids' -> - - if switchIsOn sw_chkr SimplDoLambdaEtaExpansion - && not (null extra_arg_tys) +simplRhs :: TopLevelFlag + -> Bool -- True <=> OK to float unboxed (speculative) bindings + -> OutType -> InExpr -> SubstEnv + -> (OutExpr -> SimplM (OutStuff a)) + -> SimplM (OutStuff a) +simplRhs top_lvl float_ubx rhs_ty rhs rhs_se thing_inside + = -- Swizzle the inner lets past the big lambda (if any) + -- and try eta expansion + transformRhs rhs `thenSmpl` \ t_rhs -> + + -- Simplify it + setSubstEnv rhs_se (simplExprF t_rhs (Stop rhs_ty)) `thenSmpl` \ (floats, (in_scope', rhs')) -> + + -- Float lets out of RHS + let + (floats_out, rhs'') | float_ubx = (floats, rhs') + | otherwise = splitFloats floats rhs' + in + if (isTopLevel top_lvl || exprIsWHNF rhs') && -- Float lets if (a) we're at the top level + not (null floats_out) -- or (b) it exposes a HNF then - tick EtaExpansion `thenSmpl_` - setSubstEnv bndr_se (mapSmpl simplType extra_arg_tys) - `thenSmpl` \ extra_arg_tys' -> - newIds extra_arg_tys' $ \ extra_bndrs' -> - simplExpr body (mk_cont extra_bndrs') `thenSmpl` \ body' -> - let - expanded_rhs = mkLams tyvars' - $ mkLams ids' - $ mkLams extra_bndrs' body' - expanded_arity = atLeastArity (no_of_ids + no_of_extras) - in - returnSmpl ([], (in_scope, expanded_rhs, expanded_arity)) - - else - simplExpr body Stop `thenSmpl` \ body' -> - let - unexpanded_rhs = mkLams tyvars' - $ mkLams ids' body' - unexpanded_arity = atLeastArity no_of_ids - in - returnSmpl ([], (in_scope, unexpanded_rhs, unexpanded_arity)) - + tickLetFloat floats_out `thenSmpl_` + -- Do the float + -- + -- There's a subtlety here. There may be a binding (x* = e) in the + -- floats, where the '*' means 'will be demanded'. So is it safe + -- to float it out? Answer no, but it won't matter because + -- we only float if arg' is a WHNF, + -- and so there can't be any 'will be demanded' bindings in the floats. + -- Hence the assert + WARN( any demanded_float floats_out, ppr floats_out ) + setInScope in_scope' (thing_inside rhs'') `thenSmpl` \ stuff -> + -- in_scope' may be excessive, but that's OK; + -- it's a superset of what's in scope + returnSmpl (addBinds floats_out stuff) + else + -- Don't do the float + thing_inside (mkLets floats rhs') + +-- In a let-from-let float, we just tick once, arbitrarily +-- choosing the first floated binder to identify it +tickLetFloat (NonRec b r : fs) = tick (LetFloatFromLet b) +tickLetFloat (Rec ((b,r):prs) : fs) = tick (LetFloatFromLet b) + +demanded_float (NonRec b r) = isStrict (getIdDemandInfo b) && not (isUnLiftedType (idType b)) + -- Unlifted-type (cheap-eagerness) lets may well have a demanded flag on them +demanded_float (Rec _) = False + +-- Don't float any unlifted bindings out, because the context +-- is either a Rec group, or the top level, neither of which +-- can tolerate them. +splitFloats floats rhs + = go floats where - (tyvars, ids, body) = collectTyAndValBinders rhs - no_of_ids = length ids + go [] = ([], rhs) + go (f:fs) | must_stay f = ([], mkLets (f:fs) rhs) + | otherwise = case go fs of + (out, rhs') -> (f:out, rhs') - potential_extra_arg_tys :: [InType] -- NB: InType - potential_extra_arg_tys = case splitFunTys (applyTys (idType bndr) (mkTyVarTys tyvars)) of - (arg_tys, _) -> drop no_of_ids arg_tys - - extra_arg_tys :: [InType] - extra_arg_tys = take no_extras_wanted potential_extra_arg_tys - no_of_extras = length extra_arg_tys - - no_extras_wanted = -- Use information about how many args the fn is applied to - (arity - no_of_ids) `max` - - -- See if the body could obviously do with more args - etaExpandCount body `max` - - -- Finally, see if it's a state transformer, in which - -- case we eta-expand on principle! This can waste work, - -- but usually doesn't - case potential_extra_arg_tys of - [ty] | ty == realWorldStatePrimTy -> 1 - other -> 0 - - arity = arityLowerBound (getIdArity bndr) - - mk_cont [] = Stop - mk_cont (b:bs) = ApplyTo OkToDup (Var b) emptySubstEnv (mk_cont bs) + must_stay (Rec prs) = False -- No unlifted bindings in here + must_stay (NonRec b r) = isUnLiftedType (idType b) \end{code} + %************************************************************************ %* * -\subsection{Binding} +\subsection{Variables} %* * %************************************************************************ \begin{code} -simplBeta :: InId -- Binder - -> InExpr -> SubstEnv -- Arg, with its subst-env - -> InExpr -> SimplCont -- Lambda body - -> SimplM OutExprStuff +simplVar var cont + = freeTick LeafVisit `thenSmpl_` + getSubst `thenSmpl` \ subst -> + case lookupSubst subst var of + Just (DoneEx (Var v)) -> zapSubstEnv (simplVar v cont) + Just (DoneEx e) -> zapSubstEnv (simplExprF e cont) + Just (ContEx env' e) -> setSubstEnv env' (simplExprF e cont) + + Nothing -> let + var' = case lookupInScope subst var of + Just v' -> v' + Nothing -> #ifdef DEBUG -simplBeta bndr rhs rhs_se body cont - | isTyVar bndr - = pprPanic "simplBeta" ((ppr bndr <+> ppr rhs) $$ ppr cont) + if isLocallyDefined var && not (idMustBeINLINEd var) + -- The idMustBeINLINEd test accouunts for the fact + -- that class method selectors don't have top level + -- bindings and hence aren't in scope. + then + -- Not in scope + pprTrace "simplVar:" (ppr var) var + else #endif + var + in + getBlackList `thenSmpl` \ black_list -> + getInScope `thenSmpl` \ in_scope -> -simplBeta bndr rhs rhs_se body cont - | isUnLiftedType bndr_ty - || (isStrict (getIdDemandInfo bndr) || is_dict bndr) && not (exprIsWHNF rhs) - = tick Let2Case `thenSmpl_` - getSubstEnv `thenSmpl` \ body_se -> - setSubstEnv rhs_se $ - simplExprB rhs (Select NoDup bndr [(DEFAULT, [], body)] body_se cont) - - | preInlineUnconditionally bndr && not opt_NoPreInlining - = tick PreInlineUnconditionally `thenSmpl_` - case rhs_se of { (ty_subst, id_subst) -> - extendIdSubst bndr (SubstMe rhs ty_subst id_subst) $ - simplExprB body cont } - - | otherwise - = getSubstEnv `thenSmpl` \ bndr_se -> - setSubstEnv rhs_se (simplRhs bndr bndr_se rhs) - `thenSmpl` \ (floats, in_scope, rhs', arity) -> - setInScope in_scope $ - completeBindNonRec (bndr `setIdArity` arity) rhs' ( - simplExprB body cont - ) `thenSmpl` \ stuff -> - returnSmpl (addBinds floats stuff) + prepareArgs (ppr var') (idType var') (get_str var') cont $ \ args' cont' -> + completeCall black_list in_scope var' args' cont' where - -- Return true only for dictionary types where the dictionary - -- has more than one component (else we risk poking on the component - -- of a newtype dictionary) - is_dict bndr = opt_DictsStrict && isDictTy bndr_ty && isDataType bndr_ty - bndr_ty = idType bndr -\end{code} + get_str var = case getIdStrictness var of + NoStrictnessInfo -> (repeat wwLazy, False) + StrictnessInfo demands result_bot -> (demands, result_bot) -completeBindNonRec - - deals only with Ids, not TyVars - - take an already-simplified RHS - - always produce let bindings +--------------------------------------------------------- +-- Preparing arguments for a call -It does *not* attempt to do let-to-case. Why? Because they are used for +prepareArgs :: SDoc -- Error message info + -> OutType -> ([Demand],Bool) -> SimplCont + -> ([OutExpr] -> SimplCont -> SimplM OutExprStuff) + -> SimplM OutExprStuff - - top-level bindings - (when let-to-case is impossible) +prepareArgs pp_fun orig_fun_ty (fun_demands, result_bot) orig_cont thing_inside + = go [] demands orig_fun_ty orig_cont + where + not_enough_args = fun_demands `lengthExceeds` countValArgs orig_cont + -- "No strictness info" is signalled by an infinite list of wwLazy + + demands | not_enough_args = repeat wwLazy -- Not enough args, or no strictness + | result_bot = fun_demands -- Enough args, and function returns bottom + | otherwise = fun_demands ++ repeat wwLazy -- Enough args and function does not return bottom + -- NB: demands is finite iff enough args and result_bot is True - - many situations where the "rhs" is known to be a WHNF - (so let-to-case is inappropriate). + -- Main game plan: loop through the arguments, simplifying + -- each of them in turn. We carry with us a list of demands, + -- and the type of the function-applied-to-earlier-args -\begin{code} -completeBindNonRec :: InId -- Binder - -> OutExpr -- Simplified RHS - -> SimplM (OutStuff a) -- Thing inside - -> SimplM (OutStuff a) -completeBindNonRec bndr rhs thing_inside - | isDeadBinder bndr -- This happens; for example, the case_bndr during case of - -- known constructor: case (a,b) of x { (p,q) -> ... } - -- Here x isn't mentioned in the RHS, so we don't want to - -- create the (dead) let-binding let x = (a,b) in ... - = thing_inside + -- Type argument + go acc ds fun_ty (ApplyTo _ arg@(Type ty_arg) se cont) + = getInScope `thenSmpl` \ in_scope -> + let + ty_arg' = substTy (mkSubst in_scope se) ty_arg + res_ty = applyTy fun_ty ty_arg' + in + go (Type ty_arg' : acc) ds res_ty cont + + -- Value argument + go acc (d:ds) fun_ty (ApplyTo _ val_arg se cont) + = case splitFunTy_maybe fun_ty of { + Nothing -> pprTrace "prepareArgs" (pp_fun $$ ppr orig_fun_ty $$ ppr orig_cont) + (thing_inside (reverse acc) cont) ; + Just (arg_ty, res_ty) -> + simplArg arg_ty d val_arg se (contResultType cont) $ \ arg' -> + go (arg':acc) ds res_ty cont } + + -- We've run out of demands, which only happens for functions + -- we *know* now return bottom + -- This deals with + -- * case (error "hello") of { ... } + -- * (error "Hello") arg + -- * f (error "Hello") where f is strict + -- etc + go acc [] fun_ty cont = tick_case_of_error cont `thenSmpl_` + thing_inside (reverse acc) (discardCont cont) + + -- We're run out of arguments + go acc ds fun_ty cont = thing_inside (reverse acc) cont + +-- Boring: we must only record a tick if there was an interesting +-- continuation to discard. If not, we tick forever. +tick_case_of_error (Stop _) = returnSmpl () +tick_case_of_error (CoerceIt _ (Stop _)) = returnSmpl () +tick_case_of_error other = tick BottomFound - | postInlineUnconditionally bndr etad_rhs - = tick PostInlineUnconditionally `thenSmpl_` - extendIdSubst bndr (Done etad_rhs) - thing_inside +--------------------------------------------------------- +-- Dealing with a call + +completeCall black_list_fn in_scope var args cont + -- Look for rules or specialisations that match + -- Do this *before* trying inlining because some functions + -- have specialisations *and* are strict; we don't want to + -- inline the wrapper of the non-specialised thing... better + -- to call the specialised thing instead. + | maybeToBool maybe_rule_match + = tick (RuleFired rule_name) `thenSmpl_` + zapSubstEnv (completeApp rule_rhs rule_args cont) + -- See note below about zapping the substitution here + + -- Look for an unfolding. There's a binding for the + -- thing, but perhaps we want to inline it anyway + | maybeToBool maybe_inline + = tick (UnfoldingDone var) `thenSmpl_` + zapSubstEnv (completeInlining var unf_template args (discardInlineCont cont)) + -- The template is already simplified, so don't re-substitute. + -- This is VITAL. Consider + -- let x = e in + -- let y = \z -> ...x... in + -- \ x -> ...y... + -- We'll clone the inner \x, adding x->x' in the id_subst + -- Then when we inline y, we must *not* replace x by x' in + -- the inlined copy!! + + | otherwise -- Neither rule nor inlining + = rebuild (mkApps (Var var) args) cont + + where + ---------- Unfolding stuff + maybe_inline = callSiteInline black_listed inline_call + var args interesting_cont + Just unf_template = maybe_inline + interesting_cont = contIsInteresting cont + inline_call = contIsInline cont + black_listed = black_list_fn var - | otherwise -- Note that we use etad_rhs here - -- This gives maximum chance for a remaining binding - -- to be zapped by the indirection zapper in OccurAnal - = simplBinder bndr $ \ bndr' -> - simplPrags bndr bndr' etad_rhs `thenSmpl` \ bndr'' -> - modifyInScope bndr'' $ - thing_inside `thenSmpl` \ stuff -> - returnSmpl (addBind (NonRec bndr'' etad_rhs) stuff) + ---------- Specialisation stuff + maybe_rule_match = lookupRule in_scope var args + Just (rule_name, rule_rhs, rule_args) = maybe_rule_match + + +-- First a special case +-- Don't actually inline the scrutinee when we see +-- case x of y { .... } +-- and x has unfolding (C a b). Why not? Because +-- we get a silly binding y = C a b. If we don't +-- inline knownCon can directly substitute x for y instead. +completeInlining var (Con con con_args) args (Select _ bndr alts se cont) + | conOkForAlt con + = ASSERT( null args ) + knownCon (Var var) con con_args bndr alts se cont + +-- Now the normal case +completeInlining var unfolding args cont + = completeApp unfolding args cont + +-- completeApp applies a new InExpr (from an unfolding or rule) +-- to an *already simplified* set of arguments +completeApp :: InExpr -- (\xs. body) + -> [OutExpr] -- Args; already simplified + -> SimplCont -- What to do with result of applicatoin + -> SimplM OutExprStuff +completeApp fun args cont + = go fun args where - etad_rhs = etaCoreExpr rhs + zap_it = mkLamBndrZapper fun (length args) + cont_ty = contResultType cont + + -- These equations are very similar to simplLam and simplBeta combined, + -- except that they deal with already-simplified arguments + + -- Type argument + go (Lam bndr fun) (Type ty:args) = tick (BetaReduction bndr) `thenSmpl_` + extendSubst bndr (DoneTy ty) + (go fun args) + + -- Value argument + go (Lam bndr fun) (arg:args) + | preInlineUnconditionally bndr && not opt_SimplNoPreInlining + = tick (BetaReduction bndr) `thenSmpl_` + tick (PreInlineUnconditionally bndr) `thenSmpl_` + extendSubst bndr (DoneEx arg) + (go fun args) + | otherwise + = tick (BetaReduction bndr) `thenSmpl_` + simplBinder zapped_bndr ( \ bndr' -> + completeBeta zapped_bndr bndr' arg $ + go fun args + ) + where + zapped_bndr = zap_it bndr --- (simplPrags old_bndr new_bndr new_rhs) does two things --- (a) it attaches the new unfolding to new_bndr --- (b) it grabs the SpecEnv from old_bndr, applies the current --- substitution to it, and attaches it to new_bndr --- The assumption is that new_bndr, which is produced by simplBinder --- has no unfolding or specenv. + -- Consumed all the lambda binders or args + go fun args = simplExprF fun (pushArgs emptySubstEnv args cont) -simplPrags old_bndr new_bndr new_rhs - | isEmptySpecEnv spec_env - = returnSmpl (bndr_w_unfolding) - | otherwise - = getSimplBinderStuff `thenSmpl` \ (ty_subst, id_subst, in_scope, us) -> - let - spec_env' = substSpecEnv ty_subst in_scope (subst_val id_subst) spec_env - final_bndr = bndr_w_unfolding `setIdSpecialisation` spec_env' - in - returnSmpl final_bndr - where - bndr_w_unfolding = new_bndr `setIdUnfolding` mkUnfolding new_rhs +----------- costCentreOk +-- costCentreOk checks that it's ok to inline this thing +-- The time it *isn't* is this: +-- +-- f x = let y = E in +-- scc "foo" (...y...) +-- +-- Here y has a "current cost centre", and we can't inline it inside "foo", +-- regardless of whether E is a WHNF or not. + +costCentreOk ccs_encl cc_rhs + = not opt_SccProfilingOn + || isSubsumedCCS ccs_encl -- can unfold anything into a subsumed scope + || not (isEmptyCC cc_rhs) -- otherwise need a cc on the unfolding +\end{code} - spec_env = getIdSpecialisation old_bndr - subst_val id_subst ty_subst in_scope expr - = substExpr ty_subst id_subst in_scope expr -\end{code} + +%************************************************************************ +%* * +\subsection{Decisions about inlining} +%* * +%************************************************************************ \begin{code} preInlineUnconditionally :: InId -> Bool @@ -810,8 +909,14 @@ preInlineUnconditionally :: InId -> Bool -- we'd do the same for y -- aargh! So we must base this -- pre-rhs-simplification decision solely on x's occurrences, not -- on its rhs. + -- + -- Evne RHSs labelled InlineMe aren't caught here, because + -- there might be no benefit from inlining at the call site. + -- But things labelled 'IMustBeINLINEd' *are* caught. We use this + -- for the trivial bindings introduced by SimplUtils.mkRhsTyLam preInlineUnconditionally bndr = case getInlinePragma bndr of + IMustBeINLINEd -> True ICanSafelyBeINLINEd InsideLam _ -> False ICanSafelyBeINLINEd not_in_lam True -> True -- Not inside a lambda, -- one occurrence ==> safe! @@ -828,46 +933,38 @@ postInlineUnconditionally :: InId -> OutExpr -> Bool -- we'll get another opportunity when we get to the ocurrence(s) postInlineUnconditionally bndr rhs - | isExported bndr + | isExportedId bndr = False | otherwise = case getInlinePragma bndr of IAmALoopBreaker -> False - IMustNotBeINLINEd -> False - IAmASpecPragmaId -> False -- Don't discard SpecPrag Ids ICanSafelyBeINLINEd InsideLam one_branch -> exprIsTrivial rhs - -- Don't inline even WHNFs inside lambdas; this - -- isn't the last chance; see NOTE above. + -- Don't inline even WHNFs inside lambdas; doing so may + -- simply increase allocation when the function is called + -- This isn't the last chance; see NOTE above. - ICanSafelyBeINLINEd not_in_lam one_branch -> one_branch || exprIsDupable rhs + ICanSafelyBeINLINEd not_in_lam one_branch -> one_branch || exprIsTrivial rhs + -- Was 'exprIsDupable' instead of 'exprIsTrivial' but the + -- decision about duplicating code is best left to callSiteInline other -> exprIsTrivial rhs -- Duplicating is *free* - -- NB: Even IWantToBeINLINEd and IMustBeINLINEd are ignored here + -- NB: Even InlineMe and IMustBeINLINEd are ignored here -- Why? Because we don't even want to inline them into the -- RHS of constructor arguments. See NOTE above + -- NB: Even IMustBeINLINEd is ignored here: if the rhs is trivial + -- it's best to inline it anyway. We often get a=E; b=a + -- from desugaring, with both a and b marked NOINLINE. +\end{code} +\begin{code} inlineCase bndr scrut - = case getInlinePragma bndr of - -- Not expecting IAmALoopBreaker etc; this is a case binder! - - ICanSafelyBeINLINEd StrictOcc one_branch - -> one_branch || exprIsDupable scrut - -- This case is the entire reason we distinguish StrictOcc from LazyOcc - -- We want eliminate the "case" only if we aren't going to - -- build a thunk instead, and that's what StrictOcc finds - -- For example: - -- case (f x) of y { DEFAULT -> g y } - -- Here we DO NOT WANT: - -- g (f x) - -- *even* if g is strict. We want to avoid constructing the - -- thunk for (f x)! So y gets a LazyOcc. - - other -> exprIsTrivial scrut -- Duplication is free - && ( isUnLiftedType (idType bndr) - || scrut_is_evald_var -- So dropping the case won't change termination - || isStrict (getIdDemandInfo bndr)) -- It's going to get evaluated later, so again - -- termination doesn't change + = exprIsTrivial scrut -- Duplication is free + && ( isUnLiftedType (idType bndr) + || scrut_is_evald_var -- So dropping the case won't change termination + || isStrict (getIdDemandInfo bndr) -- It's going to get evaluated later, so again + -- termination doesn't change + || not opt_SimplPedanticBottoms) -- Or we don't care! where -- Check whether or not scrut is known to be evaluted -- It's not going to be a visible value (else the previous @@ -877,150 +974,6 @@ inlineCase bndr scrut other -> False \end{code} -okToInline is used at call sites, so it is a bit more generous. -It's a very important function that embodies lots of heuristics. - -\begin{code} -okToInline :: SwitchChecker - -> InScopeEnv - -> Id -- The Id - -> FormSummary -- The thing is WHNF or bottom; - -> UnfoldingGuidance - -> SimplCont - -> Bool -- True <=> inline it - --- A non-WHNF can be inlined if it doesn't occur inside a lambda, --- and occurs exactly once or --- occurs once in each branch of a case and is small --- --- If the thing is in WHNF, there's no danger of duplicating work, --- so we can inline if it occurs once, or is small - -okToInline sw_chkr in_scope id form guidance cont - = -#ifdef DEBUG - if opt_D_dump_inlinings then - pprTrace "Considering inlining" - (ppr id <+> vcat [text "inline prag:" <+> ppr inline_prag, - text "whnf" <+> ppr whnf, - text "small enough" <+> ppr small_enough, - text "some benefit" <+> ppr some_benefit, - text "arg evals" <+> ppr arg_evals, - text "result scrut" <+> ppr result_scrut, - text "ANSWER =" <+> if result then text "YES" else text "NO"]) - result - else -#endif - result - where - result = - case inline_prag of - IAmDead -> pprTrace "okToInline: dead" (ppr id) False - IAmASpecPragmaId -> False - IMustNotBeINLINEd -> False - IAmALoopBreaker -> False - IMustBeINLINEd -> True -- If "essential_unfoldings_only" is true we do no inlinings at all, - -- EXCEPT for things that absolutely have to be done - -- (see comments with idMustBeINLINEd) - IWantToBeINLINEd -> inlinings_enabled - ICanSafelyBeINLINEd inside_lam one_branch - -> inlinings_enabled && (unfold_always || consider_single inside_lam one_branch) - NoInlinePragInfo -> inlinings_enabled && (unfold_always || consider_multi) - - inlinings_enabled = not (switchIsOn sw_chkr EssentialUnfoldingsOnly) - unfold_always = unfoldAlways guidance - - -- Consider benefit for ICanSafelyBeINLINEd - consider_single inside_lam one_branch - = (small_enough || one_branch) && some_benefit && (whnf || not_inside_lam) - where - not_inside_lam = case inside_lam of {InsideLam -> False; other -> True} - - -- Consider benefit for NoInlinePragInfo - consider_multi = whnf && small_enough && some_benefit - -- We could consider using exprIsCheap here, - -- as in postInlineUnconditionally, but unlike the latter we wouldn't - -- necessarily eliminate a thunk; and the "form" doesn't tell - -- us that. - - inline_prag = getInlinePragma id - whnf = whnfOrBottom form - small_enough = smallEnoughToInline id arg_evals result_scrut guidance - (arg_evals, result_scrut) = get_evals cont - - -- some_benefit checks that *something* interesting happens to - -- the variable after it's inlined. - some_benefit = contIsInteresting cont - - -- Finding out whether the args are evaluated. This isn't completely easy - -- because the args are not yet simplified, so we have to peek into them. - get_evals (ApplyTo _ arg (te,ve) cont) - | isValArg arg = case get_evals cont of - (args, res) -> (get_arg_eval arg ve : args, res) - | otherwise = get_evals cont - - get_evals (Select _ _ _ _ _) = ([], True) - get_evals other = ([], False) - - get_arg_eval (Con con _) ve = isWHNFCon con - get_arg_eval (Var v) ve = case lookupVarEnv ve v of - Just (SubstMe e' _ ve') -> get_arg_eval e' ve' - Just (Done (Con con _)) -> isWHNFCon con - Just (Done (Var v')) -> get_var_eval v' - Just (Done other) -> False - Nothing -> get_var_eval v - get_arg_eval other ve = False - - get_var_eval v = case lookupVarSet in_scope v of - Just v' -> isEvaldUnfolding (getIdUnfolding v') - Nothing -> isEvaldUnfolding (getIdUnfolding v) - - -contIsInteresting :: SimplCont -> Bool -contIsInteresting Stop = False -contIsInteresting (ArgOf _ _ _) = False -contIsInteresting (ApplyTo _ (Type _) _ cont) = contIsInteresting cont -contIsInteresting (CoerceIt _ _ _ cont) = contIsInteresting cont - --- See notes below on why a case with only a DEFAULT case is not intersting --- contIsInteresting (Select _ _ [(DEFAULT,_,_)] _ _) = False - -contIsInteresting _ = True -\end{code} - -Comment about some_benefit above -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -We want to avoid inlining an expression where there can't possibly be -any gain, such as in an argument position. Hence, if the continuation -is interesting (eg. a case scrutinee, application etc.) then we -inline, otherwise we don't. - -Previously some_benefit used to return True only if the variable was -applied to some value arguments. This didn't work: - - let x = _coerce_ (T Int) Int (I# 3) in - case _coerce_ Int (T Int) x of - I# y -> .... - -we want to inline x, but can't see that it's a constructor in a case -scrutinee position, and some_benefit is False. - -Another example: - -dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t) - -.... case dMonadST _@_ x0 of (a,b,c) -> .... - -we'd really like to inline dMonadST here, but we *don't* want to -inline if the case expression is just - - case x of y { DEFAULT -> ... } - -since we can just eliminate this case instead (x is in WHNF). Similar -applies when x is bound to a lambda expression. Hence -contIsInteresting looks for case expressions with just a single -default case. %************************************************************************ @@ -1031,95 +984,68 @@ default case. \begin{code} ------------------------------------------------------------------- -rebuild :: OutExpr -> SimplCont -> SimplM OutExprStuff - -rebuild expr cont - = tick LeavesExamined `thenSmpl_` - case expr of - Var v -> case getIdStrictness v of - NoStrictnessInfo -> do_rebuild expr cont - StrictnessInfo demands result_bot -> ASSERT( not (null demands) || result_bot ) - -- If this happened we'd get an infinite loop - rebuild_strict demands result_bot expr (idType v) cont - other -> do_rebuild expr cont - +-- Finish rebuilding rebuild_done expr - = getInScope `thenSmpl` \ in_scope -> + = getInScope `thenSmpl` \ in_scope -> returnSmpl ([], (in_scope, expr)) --------------------------------------------------------- --- Stop continuation - -do_rebuild expr Stop = rebuild_done expr +rebuild :: OutExpr -> SimplCont -> SimplM OutExprStuff +-- Stop continuation +rebuild expr (Stop _) = rebuild_done expr ---------------------------------------------------------- -- ArgOf continuation +rebuild expr (ArgOf _ _ cont_fn) = cont_fn expr -do_rebuild expr (ArgOf _ cont_fn _) = cont_fn expr - ---------------------------------------------------------- -- ApplyTo continuation +rebuild expr cont@(ApplyTo _ arg se cont') + = setSubstEnv se (simplExpr arg) `thenSmpl` \ arg' -> + rebuild (App expr arg') cont' -do_rebuild expr cont@(ApplyTo _ arg se cont') - = setSubstEnv se (simplArg arg) `thenSmpl` \ arg' -> - do_rebuild (App expr arg') cont' - - ---------------------------------------------------------- -- Coerce continuation +rebuild expr (CoerceIt to_ty cont) + = rebuild (mkCoerce to_ty expr) cont -do_rebuild expr (CoerceIt _ to_ty se cont) - = setSubstEnv se $ - simplType to_ty `thenSmpl` \ to_ty' -> - do_rebuild (mk_coerce to_ty' expr) cont - +-- Inline continuation +rebuild expr (InlinePlease cont) + = rebuild (Note InlineCall expr) cont ---------------------------------------------------------- -- Case of known constructor or literal - -do_rebuild expr@(Con con args) cont@(Select _ _ _ _ _) +rebuild expr@(Con con args) (Select _ bndr alts se cont) | conOkForAlt con -- Knocks out PrimOps and NoRepLits - = knownCon expr con args cont - - ---------------------------------------------------------- + = knownCon expr con args bndr alts se cont -- Case of other value (e.g. a partial application or lambda) -- Turn it back into a let - -do_rebuild expr (Select _ bndr ((DEFAULT, bs, rhs):alts) se cont) - | case mkFormSummary expr of { ValueForm -> True; other -> False } +rebuild scrut (Select _ bndr ((DEFAULT, bs, rhs):alts) se cont) + | isUnLiftedType (idType bndr) && exprOkForSpeculation scrut + || exprIsWHNF scrut = ASSERT( null bs && null alts ) - tick Case2Let `thenSmpl_` - setSubstEnv se ( - completeBindNonRec bndr expr $ - simplExprB rhs cont - ) + setSubstEnv se $ + simplBinder bndr $ \ bndr' -> + completeBinding bndr bndr' scrut $ + simplExprF rhs cont --------------------------------------------------------- -- The other Select cases -do_rebuild scrut (Select _ bndr alts se cont) - = getSwitchChecker `thenSmpl` \ chkr -> - - if all (cheapEqExpr rhs1) other_rhss - && inlineCase bndr scrut - && all binders_unused alts - && switchIsOn chkr SimplDoCaseElim - then - -- Get rid of the case altogether +rebuild scrut (Select _ bndr alts se cont) + | all (cheapEqExpr rhs1) other_rhss + && inlineCase bndr scrut + && all binders_unused alts + && opt_SimplDoCaseElim + = -- Get rid of the case altogether -- See the extensive notes on case-elimination below -- Remember to bind the binder though! - tick CaseElim `thenSmpl_` + tick (CaseElim bndr) `thenSmpl_` setSubstEnv se ( - extendIdSubst bndr (Done scrut) $ - simplExprB rhs1 cont + extendSubst bndr (DoneEx scrut) $ + simplExprF rhs1 cont ) - - else - rebuild_case chkr scrut bndr alts se cont + | otherwise + = rebuild_case scrut bndr alts se cont where (rhs1:other_rhss) = [rhs | (_,_,rhs) <- alts] binders_unused (_, bndrs, _) = all isDeadBinder bndrs @@ -1204,90 +1130,15 @@ So the case-elimination algorithm is: If so, then we can replace the case with one of the rhss. -\begin{code} ---------------------------------------------------------- --- Rebuiling a function with strictness info --- This just a version of do_rebuild, enhanced with info about --- the strictness of the thing being rebuilt. - -rebuild_strict :: [Demand] -> Bool -- Stricness info - -> OutExpr -> OutType -- Function and type - -> SimplCont -- Continuation - -> SimplM OutExprStuff - -rebuild_strict [] True fun fun_ty cont = rebuild_bot fun fun_ty cont -rebuild_strict [] False fun fun_ty cont = do_rebuild fun cont - -rebuild_strict ds result_bot fun fun_ty (CoerceIt _ to_ty se cont) - = setSubstEnv se $ - simplType to_ty `thenSmpl` \ to_ty' -> - rebuild_strict ds result_bot (mk_coerce to_ty' fun) to_ty' cont - -rebuild_strict ds result_bot fun fun_ty (ApplyTo _ (Type ty_arg) se cont) - -- Type arg; don't consume a demand - = setSubstEnv se (simplType ty_arg) `thenSmpl` \ ty_arg' -> - rebuild_strict ds result_bot (App fun (Type ty_arg')) - (applyTy fun_ty ty_arg') cont - -rebuild_strict (d:ds) result_bot fun fun_ty (ApplyTo _ val_arg se cont) - | isStrict d || isUnLiftedType arg_ty - -- Strict value argument - = getInScope `thenSmpl` \ in_scope -> - let - cont_ty = contResultType in_scope res_ty cont - in - setSubstEnv se (simplExprB val_arg (ArgOf NoDup cont_fn cont_ty)) - - | otherwise -- Lazy value argument - = setSubstEnv se (simplArg val_arg) `thenSmpl` \ val_arg' -> - cont_fn val_arg' - - where - Just (arg_ty, res_ty) = splitFunTy_maybe fun_ty - cont_fn arg' = rebuild_strict ds result_bot - (App fun arg') res_ty - cont - -rebuild_strict ds result_bot fun fun_ty cont = do_rebuild fun cont - ---------------------------------------------------------- --- Dealing with --- * case (error "hello") of { ... } --- * (error "Hello") arg --- * f (error "Hello") where f is strict --- etc - -rebuild_bot expr expr_ty Stop -- No coerce needed - = rebuild_done expr - -rebuild_bot expr expr_ty (CoerceIt _ to_ty se Stop) -- Don't "tick" on this, - -- else simplifier never stops - = setSubstEnv se $ - simplType to_ty `thenSmpl` \ to_ty' -> - rebuild_done (mkNote (Coerce to_ty' expr_ty) expr) - -rebuild_bot expr expr_ty cont -- Abandon the (strict) continuation, - -- and just return expr - = tick CaseOfError `thenSmpl_` - getInScope `thenSmpl` \ in_scope -> - let - result_ty = contResultType in_scope expr_ty cont - in - rebuild_done (mkNote (Coerce result_ty expr_ty) expr) - -mk_coerce to_ty (Note (Coerce _ from_ty) expr) = Note (Coerce to_ty from_ty) expr -mk_coerce to_ty expr = Note (Coerce to_ty (coreExprType expr)) expr -\end{code} - Blob of helper functions for the "case-of-something-else" situation. \begin{code} --------------------------------------------------------- -- Case of something else -rebuild_case sw_chkr scrut case_bndr alts se cont +rebuild_case scrut case_bndr alts se cont = -- Prepare case alternatives - prepareCaseAlts (splitTyConApp_maybe (idType case_bndr)) + prepareCaseAlts case_bndr (splitTyConApp_maybe (idType case_bndr)) scrut_cons alts `thenSmpl` \ better_alts -> -- Set the new subst-env in place (before dealing with the case binder) @@ -1309,7 +1160,7 @@ rebuild_case sw_chkr scrut case_bndr alts se cont simplAlts zap_occ_info scrut_cons case_bndr'' better_alts cont' `thenSmpl` \ alts' -> - mkCase sw_chkr scrut case_bndr'' alts' `thenSmpl` \ case_expr -> + mkCase scrut case_bndr'' alts' `thenSmpl` \ case_expr -> rebuild_done case_expr where -- scrut_cons tells what constructors the scrutinee can't possibly match @@ -1320,32 +1171,38 @@ rebuild_case sw_chkr scrut case_bndr alts se cont other -> [] -knownCon expr con args (Select _ bndr alts se cont) - = tick KnownBranch `thenSmpl_` - setSubstEnv se ( +knownCon expr con args bndr alts se cont + = tick (KnownBranch bndr) `thenSmpl_` + setSubstEnv se ( + simplBinder bndr $ \ bndr' -> case findAlt con alts of (DEFAULT, bs, rhs) -> ASSERT( null bs ) - completeBindNonRec bndr expr $ - simplExprB rhs cont + completeBinding bndr bndr' expr $ + -- Don't use completeBeta here. The expr might be + -- an unboxed literal, like 3, or a variable + -- whose unfolding is an unboxed literal... and + -- completeBeta will just construct another case + -- expression! + simplExprF rhs cont (Literal lit, bs, rhs) -> ASSERT( null bs ) - extendIdSubst bndr (Done expr) $ + extendSubst bndr (DoneEx expr) $ -- Unconditionally substitute, because expr must -- be a variable or a literal. It can't be a -- NoRep literal because they don't occur in -- case patterns. - simplExprB rhs cont + simplExprF rhs cont - (DataCon dc, bs, rhs) -> completeBindNonRec bndr expr $ - extend bs real_args $ - simplExprB rhs cont + (DataCon dc, bs, rhs) -> ASSERT( length bs == length real_args ) + completeBinding bndr bndr' expr $ + -- See note above + extendSubstList bs (map mk real_args) $ + simplExprF rhs cont where - real_args = drop (dataConNumInstArgs dc) args + real_args = drop (dataConNumInstArgs dc) args + mk (Type ty) = DoneTy ty + mk other = DoneEx other ) - where - extend [] [] thing_inside = thing_inside - extend (b:bs) (arg:args) thing_inside = extendIdSubst b (Done arg) $ - extend bs args thing_inside \end{code} \begin{code} @@ -1372,7 +1229,7 @@ variables! Example: Here, b and p are dead. But when we move the argment inside the first case RHS, and eliminate the second case, we get - case x or { (a,b) -> a b + case x or { (a,b) -> a b } Urk! b is alive! Reason: the scrutinee was a variable, and case elimination happened. Hence the zap_occ_info function returned by substForVarScrut @@ -1405,12 +1262,12 @@ prepareCaseAlts does two things: when rhs also scrutinises x or e. \begin{code} -prepareCaseAlts (Just (tycon, inst_tys)) scrut_cons alts +prepareCaseAlts bndr (Just (tycon, inst_tys)) scrut_cons alts | isDataTyCon tycon = case (findDefault filtered_alts, missing_cons) of ((alts_no_deflt, Just rhs), [data_con]) -- Just one missing constructor! - -> tick FillInCaseDefault `thenSmpl_` + -> tick (FillInCaseDefault bndr) `thenSmpl_` let (_,_,ex_tyvars,_,_,_) = dataConSig data_con in @@ -1437,7 +1294,7 @@ prepareCaseAlts (Just (tycon, inst_tys)) scrut_cons alts [data_con | (DataCon data_con, _, _) <- filtered_alts] -- The default case -prepareCaseAlts _ scrut_cons alts +prepareCaseAlts _ _ scrut_cons alts = returnSmpl alts -- Functions @@ -1456,8 +1313,8 @@ simplAlts zap_occ_info scrut_cons case_bndr'' alts cont' = -- In the default case we record the constructors that the -- case-binder *can't* be. -- We take advantage of any OtherCon info in the case scrutinee - modifyInScope (case_bndr'' `setIdUnfolding` OtherCon handled_cons) $ - simplExpr rhs cont' `thenSmpl` \ rhs' -> + modifyInScope (case_bndr'' `setIdUnfolding` OtherCon handled_cons) $ + simplExprC rhs cont' `thenSmpl` \ rhs' -> returnSmpl (DEFAULT, [], rhs') simpl_alt (con, vs, rhs) @@ -1471,7 +1328,7 @@ simplAlts zap_occ_info scrut_cons case_bndr'' alts cont' con_app = Con con (map Type inst_tys' ++ map varToCoreExpr vs') in modifyInScope (case_bndr'' `setIdUnfolding` mkUnfolding con_app) $ - simplExpr rhs cont' `thenSmpl` \ rhs' -> + simplExprC rhs cont' `thenSmpl` \ rhs' -> returnSmpl (con, vs', rhs') @@ -1484,24 +1341,19 @@ simplAlts zap_occ_info scrut_cons case_bndr'' alts cont' -- We really must record that b is already evaluated so that we don't -- go and re-evaluate it when constructing the result. - add_evals (DataCon dc) vs = cat_evals vs (dataConStrictMarks dc) + add_evals (DataCon dc) vs = cat_evals vs (dataConRepStrictness dc) add_evals other_con vs = vs cat_evals [] [] = [] cat_evals (v:vs) (str:strs) - | isTyVar v = v : cat_evals vs (str:strs) - | otherwise = - case str of - MarkedStrict -> - (zap_occ_info v `setIdUnfolding` OtherCon []) - : cat_evals vs strs - MarkedUnboxed con _ -> - cat_evals (v:vs) (dataConStrictMarks con ++ strs) - NotMarkedStrict -> zap_occ_info v : cat_evals vs strs + | isTyVar v = v : cat_evals vs (str:strs) + | isStrict str = (v' `setIdUnfolding` OtherCon []) : cat_evals vs strs + | otherwise = v' : cat_evals vs strs + where + v' = zap_occ_info v \end{code} - %************************************************************************ %* * \subsection{Duplicating continuations} @@ -1517,25 +1369,28 @@ mkDupableCont ty cont thing_inside | contIsDupable cont = thing_inside cont -mkDupableCont _ (CoerceIt _ ty se cont) thing_inside +mkDupableCont _ (CoerceIt ty cont) thing_inside = mkDupableCont ty cont $ \ cont' -> - thing_inside (CoerceIt OkToDup ty se cont') + thing_inside (CoerceIt ty cont') -mkDupableCont join_arg_ty (ArgOf _ cont_fn res_ty) thing_inside +mkDupableCont ty (InlinePlease cont) thing_inside + = mkDupableCont ty cont $ \ cont' -> + thing_inside (InlinePlease cont') + +mkDupableCont join_arg_ty (ArgOf _ cont_ty cont_fn) thing_inside = -- Build the RHS of the join point simplType join_arg_ty `thenSmpl` \ join_arg_ty' -> newId join_arg_ty' ( \ arg_id -> getSwitchChecker `thenSmpl` \ chkr -> cont_fn (Var arg_id) `thenSmpl` \ (binds, (_, rhs)) -> - returnSmpl (Lam arg_id (mkLetBinds binds rhs)) + returnSmpl (Lam arg_id (mkLets binds rhs)) ) `thenSmpl` \ join_rhs -> -- Build the join Id and continuation newId (coreExprType join_rhs) $ \ join_id -> let - new_cont = ArgOf OkToDup + new_cont = ArgOf OkToDup cont_ty (\arg' -> rebuild_done (App (Var join_id) arg')) - res_ty in -- Do the thing inside @@ -1544,7 +1399,7 @@ mkDupableCont join_arg_ty (ArgOf _ cont_fn res_ty) thing_inside mkDupableCont ty (ApplyTo _ arg se cont) thing_inside = mkDupableCont (funResultTy ty) cont $ \ cont' -> - setSubstEnv se (simplArg arg) `thenSmpl` \ arg' -> + setSubstEnv se (simplExpr arg) `thenSmpl` \ arg' -> if exprIsDupable arg' then thing_inside (ApplyTo OkToDup arg' emptySubstEnv cont') else @@ -1553,40 +1408,44 @@ mkDupableCont ty (ApplyTo _ arg se cont) thing_inside returnSmpl (addBind (NonRec bndr arg') res) mkDupableCont ty (Select _ case_bndr alts se cont) thing_inside - = tick CaseOfCase `thenSmpl_` ( - setSubstEnv se ( - simplBinder case_bndr $ \ case_bndr' -> - prepareCaseCont alts cont $ \ cont' -> - mapAndUnzipSmpl (mkDupableAlt case_bndr' cont') alts `thenSmpl` \ (alt_binds_s, alts') -> - returnSmpl (concat alt_binds_s, (case_bndr', alts')) - ) `thenSmpl` \ (alt_binds, (case_bndr', alts')) -> - - extendInScopes [b | NonRec b _ <- alt_binds] $ - thing_inside (Select OkToDup case_bndr' alts' emptySubstEnv Stop) `thenSmpl` \ res -> + = tick (CaseOfCase case_bndr) `thenSmpl_` + setSubstEnv se ( + simplBinder case_bndr $ \ case_bndr' -> + prepareCaseCont alts cont $ \ cont' -> + mapAndUnzipSmpl (mkDupableAlt case_bndr case_bndr' cont') alts `thenSmpl` \ (alt_binds_s, alts') -> + returnSmpl (concat alt_binds_s, alts') + ) `thenSmpl` \ (alt_binds, alts') -> + + extendInScopes [b | NonRec b _ <- alt_binds] $ + + -- NB that the new alternatives, alts', are still InAlts, using the original + -- binders. That means we can keep the case_bndr intact. This is important + -- because another case-of-case might strike, and so we want to keep the + -- info that the case_bndr is dead (if it is, which is often the case). + -- This is VITAL when the type of case_bndr is an unboxed pair (often the + -- case in I/O rich code. We aren't allowed a lambda bound + -- arg of unboxed tuple type, and indeed such a case_bndr is always dead + thing_inside (Select OkToDup case_bndr alts' se (Stop (contResultType cont))) `thenSmpl` \ res -> + returnSmpl (addBinds alt_binds res) - ) -mkDupableAlt :: OutId -> SimplCont -> InAlt -> SimplM (OutStuff CoreAlt) -mkDupableAlt case_bndr' cont alt@(con, bndrs, rhs) - = simplBinders bndrs $ \ bndrs' -> - simplExpr rhs cont `thenSmpl` \ rhs' -> - if exprIsDupable rhs' then - -- It's small, so don't bother to let-bind it - returnSmpl ([], (con, bndrs', rhs')) - else - -- It's big, so let-bind it + +mkDupableAlt :: InId -> OutId -> SimplCont -> InAlt -> SimplM (OutStuff InAlt) +mkDupableAlt case_bndr case_bndr' cont alt@(con, bndrs, rhs) + = -- Not worth checking whether the rhs is small; the + -- inliner will inline it if so. + simplBinders bndrs $ \ bndrs' -> + simplExprC rhs cont `thenSmpl` \ rhs' -> let rhs_ty' = coreExprType rhs' - used_bndrs' = filter (not . isDeadBinder) (case_bndr' : bndrs') + (used_bndrs, used_bndrs') + = unzip [pr | pr@(bndr,bndr') <- zip (case_bndr : bndrs) + (case_bndr' : bndrs'), + not (isDeadBinder bndr)] + -- The new binders have lost their occurrence info, + -- so we have to extract it from the old ones in - ( if null used_bndrs' && isUnLiftedType rhs_ty' - then newId realWorldStatePrimTy $ \ rw_id -> - returnSmpl ([rw_id], [varToCoreExpr realWorldPrimId]) - else - returnSmpl (used_bndrs', map varToCoreExpr used_bndrs') - ) - `thenSmpl` \ (final_bndrs', final_args) -> - + ( if null used_bndrs' -- If we try to lift a primitive-typed something out -- for let-binding-purposes, we will *caseify* it (!), -- with potentially-disastrous strictness results. So @@ -1598,7 +1457,23 @@ mkDupableAlt case_bndr' cont alt@(con, bndrs, rhs) -- case_bndr to all the join points if it's used in *any* RHS, -- because we don't know its usage in each RHS separately + -- We used to say "&& isUnLiftedType rhs_ty'" here, but now + -- we make the join point into a function whenever used_bndrs' + -- is empty. This makes the join-point more CPR friendly. + -- Consider: let j = if .. then I# 3 else I# 4 + -- in case .. of { A -> j; B -> j; C -> ... } + -- + -- Now CPR should not w/w j because it's a thunk, so + -- that means that the enclosing function can't w/w either, + -- which is a BIG LOSE. This actually happens in practice + then newId realWorldStatePrimTy $ \ rw_id -> + returnSmpl ([rw_id], [Var realWorldPrimId]) + else + returnSmpl (used_bndrs', map varToCoreExpr used_bndrs) + ) + `thenSmpl` \ (final_bndrs', final_args) -> + newId (foldr (mkFunTy . idType) rhs_ty' final_bndrs') $ \ join_bndr -> returnSmpl ([NonRec join_bndr (mkLams final_bndrs' rhs')], - (con, bndrs', mkApps (Var join_bndr) final_args)) + (con, bndrs, mkApps (Var join_bndr) final_args)) \end{code} |