From 7b01315da1b2fab02d3778bedec3ae8c57a1bc42 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Mon, 5 Feb 2007 17:31:50 +0000 Subject: [PATCH] Establish the CoreSyn let/app invariant This patch clears up a long-standing wart. For some time it's been the case that the RHS of a non-recursive let can be unlifed iff the RHS is ok-for-speculation This patch extends the invariant to the argument of an App, and establishes it by the smart constructors mkDsApp, mkDsApps in the desugarer. Once established, it should be maintained by the optimiser. This tides up some awkward cases, notably in exprIsHNF, and I think it fixes a outright strictness bug in Simplify.prepareRhs. --- compiler/coreSyn/CoreSyn.lhs | 99 +++++++++++++++++++++++----------------- compiler/coreSyn/CoreUtils.lhs | 26 ++++------- compiler/deSugar/DsExpr.lhs | 8 ++-- compiler/deSugar/DsUtils.lhs | 37 +++++++++++++-- 4 files changed, 104 insertions(+), 66 deletions(-) diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs index e580bed..8c799b5 100644 --- a/compiler/coreSyn/CoreSyn.lhs +++ b/compiler/coreSyn/CoreSyn.lhs @@ -79,37 +79,17 @@ infixl 8 `App` -- App brackets to the left data Expr b -- "b" for the type of binders, = Var Id | Lit Literal - | App (Expr b) (Arg b) + | App (Expr b) (Arg b) -- See Note [CoreSyn let/app invariant] | Lam b (Expr b) - | Let (Bind b) (Expr b) + | Let (Bind b) (Expr b) -- See [CoreSyn let/app invariant], + -- and [CoreSyn letrec invariant] | Case (Expr b) b Type [Alt b] -- Binder gets bound to value of scrutinee - -- Invariant: The list of alternatives is ALWAYS EXHAUSTIVE, - -- meaning that it covers all cases that can occur - -- See the example below - -- - -- Invariant: The DEFAULT case must be *first*, if it occurs at all - -- Invariant: The remaining cases are in order of increasing - -- tag (for DataAlts) - -- lit (for LitAlts) - -- This makes finding the relevant constructor easy, - -- and makes comparison easier too + -- See Note [CoreSyn case invariants] | Cast (Expr b) Coercion | Note Note (Expr b) | Type Type -- This should only show up at the top -- level of an Arg --- An "exhausive" case does not necessarily mention all constructors: --- data Foo = Red | Green | Blue --- --- ...case x of --- Red -> True --- other -> f (case x of --- Green -> ... --- Blue -> ... ) --- The inner case does not need a Red alternative, because x can't be Red at --- that program point. - - type Arg b = Expr b -- Can be a Type type Alt b = (AltCon, [b], Expr b) -- (DEFAULT, [], rhs) is the default alternative @@ -123,7 +103,61 @@ data AltCon = DataAlt DataCon -- Invariant: the DataCon is always from data Bind b = NonRec b (Expr b) | Rec [(b, (Expr b))] +\end{code} + +-------------------------- CoreSyn INVARIANTS --------------------------- + +Note [CoreSyn top-level invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* The RHSs of all top-level lets must be of LIFTED type. + +Note [CoreSyn letrec invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* The RHS of a letrec must be of LIFTED type. + +Note [CoreSyn let/app invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* The RHS of a non-recursive let, *and* the argument of an App, + may be of UNLIFTED type, but only if the expression + is ok-for-speculation. This means that the let can be floated around + without difficulty. e.g. + y::Int# = x +# 1# ok + y::Int# = fac 4# not ok [use case instead] +This is intially enforced by DsUtils.mkDsLet and mkDsApp + +Note [CoreSyn case invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Invariant: The DEFAULT case must be *first*, if it occurs at all + +Invariant: The remaining cases are in order of increasing + tag (for DataAlts) + lit (for LitAlts) + This makes finding the relevant constructor easy, + and makes comparison easier too + +Invariant: The list of alternatives is ALWAYS EXHAUSTIVE, + meaning that it covers all cases that can occur + An "exhausive" case does not necessarily mention all constructors: + data Foo = Red | Green | Blue + + ...case x of + Red -> True + other -> f (case x of + Green -> ... + Blue -> ... ) + The inner case does not need a Red alternative, because x can't be Red at + that program point. + + +Note [CoreSyn let goal] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* The simplifier tries to ensure that if the RHS of a let is a constructor + application, its arguments are trivial, so that the constructor can be + inlined vigorously. + + +\begin{code} data Note = SCC CostCentre @@ -143,23 +177,6 @@ data Note -- should inline f even inside lambdas. In effect, we should trust the programmer. \end{code} -INVARIANTS: - -* The RHS of a letrec, and the RHSs of all top-level lets, - must be of LIFTED type. - -* The RHS of a let, may be of UNLIFTED type, but only if the expression - is ok-for-speculation. This means that the let can be floated around - without difficulty. e.g. - y::Int# = x +# 1# ok - y::Int# = fac 4# not ok [use case instead] - -* The argument of an App can be of any type. - -* The simplifier tries to ensure that if the RHS of a let is a constructor - application, its arguments are trivial, so that the constructor can be - inlined vigorously. - %************************************************************************ %* * diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index 362fb52..92f8979 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -606,8 +606,8 @@ Because `seq` on such things completes immediately For unlifted argument types, we have to be careful: C (f x :: Int#) -Suppose (f x) diverges; then C (f x) is not a value. True, but -this form is illegal (see the invariants in CoreSyn). Args of unboxed +Suppose (f x) diverges; then C (f x) is not a value. However this can't +happen: see CoreSyn Note [CoreSyn let/app invariant]. Args of unboxed type must be ok-for-speculation (or trivial). \begin{code} @@ -633,22 +633,12 @@ exprIsHNF other = False -- There is at least one value argument app_is_value (Var fun) args - | isDataConWorkId fun -- Constructor apps are values - || idArity fun > valArgCount args -- Under-applied function - = check_args (idType fun) args -app_is_value (App f a) as = app_is_value f (a:as) -app_is_value other as = False - - -- 'check_args' checks that unlifted-type args - -- are in fact guaranteed non-divergent -check_args fun_ty [] = True -check_args fun_ty (Type _ : args) = case splitForAllTy_maybe fun_ty of - Just (_, ty) -> check_args ty args -check_args fun_ty (arg : args) - | isUnLiftedType arg_ty = exprOkForSpeculation arg - | otherwise = check_args res_ty args - where - (arg_ty, res_ty) = splitFunTy fun_ty + = idArity fun > valArgCount args -- Under-applied function + || isDataConWorkId fun -- or data constructor +app_is_value (Note n f) as = app_is_value f as +app_is_value (Cast f _) as = app_is_value f as +app_is_value (App f a) as = app_is_value f (a:as) +app_is_value other as = False \end{code} \begin{code} diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index eb93353..982e315 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -227,7 +227,7 @@ dsExpr expr@(HsLam a_Match) dsExpr expr@(HsApp fun arg) = dsLExpr fun `thenDs` \ core_fun -> dsLExpr arg `thenDs` \ core_arg -> - returnDs (core_fun `App` core_arg) + returnDs (core_fun `mkDsApp` core_arg) \end{code} Operator sections. At first it looks as if we can convert @@ -257,12 +257,12 @@ dsExpr (OpApp e1 op _ e2) -- for the type of y, we need the type of op's 2nd argument dsLExpr e1 `thenDs` \ x_core -> dsLExpr e2 `thenDs` \ y_core -> - returnDs (mkApps core_op [x_core, y_core]) + returnDs (mkDsApps core_op [x_core, y_core]) dsExpr (SectionL expr op) -- Desugar (e !) to ((!) e) = dsLExpr op `thenDs` \ core_op -> dsLExpr expr `thenDs` \ x_core -> - returnDs (App core_op x_core) + returnDs (mkDsApp core_op x_core) -- dsLExpr (SectionR op expr) -- \ x -> op x expr dsExpr (SectionR op expr) @@ -277,7 +277,7 @@ dsExpr (SectionR op expr) newSysLocalDs y_ty `thenDs` \ y_id -> returnDs (bindNonRec y_id y_core $ - Lam x_id (mkApps core_op [Var x_id, Var y_id])) + Lam x_id (mkDsApps core_op [Var x_id, Var y_id])) dsExpr (HsSCC cc expr) = dsLExpr expr `thenDs` \ core_expr -> diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs index 209a094..71a8320 100644 --- a/compiler/deSugar/DsUtils.lhs +++ b/compiler/deSugar/DsUtils.lhs @@ -12,7 +12,7 @@ module DsUtils ( EquationInfo(..), firstPat, shiftEqns, - mkDsLet, mkDsLets, + mkDsLet, mkDsLets, mkDsApp, mkDsApps, MatchResult(..), CanItFail(..), cantFailMatchResult, alwaysFailMatchResult, @@ -75,6 +75,8 @@ import DynFlags #ifdef DEBUG import Util #endif + +infixl 4 `mkDsApp`, `mkDsApps` \end{code} @@ -122,13 +124,43 @@ back again. \begin{code} mkDsLet :: CoreBind -> CoreExpr -> CoreExpr mkDsLet (NonRec bndr rhs) body - | isUnLiftedType (idType bndr) + | isUnLiftedType (idType bndr) && not (exprOkForSpeculation rhs) = Case rhs bndr (exprType body) [(DEFAULT,[],body)] mkDsLet bind body = Let bind body mkDsLets :: [CoreBind] -> CoreExpr -> CoreExpr mkDsLets binds body = foldr mkDsLet body binds + +----------- +mkDsApp :: CoreExpr -> CoreExpr -> CoreExpr +-- Check the invariant that the arg of an App is ok-for-speculation if unlifted +-- See CoreSyn Note [CoreSyn let/app invariant] +mkDsApp fun (Type ty) = App fun (Type ty) +mkDsApp fun arg = mk_val_app fun arg arg_ty res_ty + where + (arg_ty, res_ty) = splitFunTy (exprType fun) + +----------- +mkDsApps :: CoreExpr -> [CoreExpr] -> CoreExpr +-- Slightly more efficient version of (foldl mkDsApp) +mkDsApps fun args + = go fun (exprType fun) args + where + go fun fun_ty [] = fun + go fun fun_ty (Type ty : args) = go (App fun (Type ty)) (applyTy fun_ty ty) args + go fun fun_ty (arg : args) = go (mk_val_app fun arg arg_ty res_ty) res_ty args + where + (arg_ty, res_ty) = splitFunTy fun_ty +----------- +mk_val_app fun arg arg_ty res_ty + | isUnLiftedType arg_ty && not (exprOkForSpeculation arg) + = Case arg arg_id res_ty [(DEFAULT,[],App fun (Var arg_id))] + | otherwise -- The common case + = App fun arg + where + arg_id = mkWildId arg_ty -- Lots of shadowing, but it doesn't matter, + -- because 'fun ' should not have a free wild-id \end{code} @@ -807,7 +839,6 @@ mkCoreSel vars the_var scrut_var scrut [(DataAlt (tupleCon Boxed (length vars)), vars, Var the_var)] \end{code} - %************************************************************************ %* * \subsection[mkFailurePair]{Code for pattern-matching and other failures} -- 1.7.10.4