Commit 7b01315d authored by simonpj@microsoft.com's avatar simonpj@microsoft.com
Browse files

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.
parent 77241a03
......@@ -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.
%************************************************************************
%* *
......
......@@ -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}
......
......@@ -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 ->
......
......@@ -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}
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment