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
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
-- 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.
-
%************************************************************************
%* *
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}
-- 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}
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
-- 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)
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 ->
EquationInfo(..),
firstPat, shiftEqns,
- mkDsLet, mkDsLets,
+ mkDsLet, mkDsLets, mkDsApp, mkDsApps,
MatchResult(..), CanItFail(..),
cantFailMatchResult, alwaysFailMatchResult,
#ifdef DEBUG
import Util
#endif
+
+infixl 4 `mkDsApp`, `mkDsApps`
\end{code}
\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}
[(DataAlt (tupleCon Boxed (length vars)), vars, Var the_var)]
\end{code}
-
%************************************************************************
%* *
\subsection[mkFailurePair]{Code for pattern-matching and other failures}
projects / ghc-hetmet.git / commitdiff