%
-% (c) The University of Glasgow, 1994-2000
+% (c) The University of Glasgow, 1994-2006
%
-\section{Core pass to saturate constructors and PrimOps}
+
+Core pass to saturate constructors and PrimOps
\begin{code}
module CorePrep (
#include "HsVersions.h"
-import CoreUtils( exprType, exprIsHNF, etaExpand, exprArity, exprOkForSpeculation )
-import CoreFVs ( exprFreeVars )
-import CoreLint ( endPass )
+import CoreUtils hiding (exprIsTrivial)
+import CoreFVs
+import CoreLint
import CoreSyn
-import Type ( Type, applyTy, splitFunTy_maybe,
- isUnLiftedType, isUnboxedTupleType, seqType )
-import TyCon ( TyCon, tyConDataCons )
-import NewDemand ( Demand, isStrictDmd, lazyDmd, StrictSig(..), DmdType(..) )
-import Var ( Var, Id, setVarUnique )
+import Type
+import Coercion
+import TyCon
+import NewDemand
+import Var
import VarSet
import VarEnv
-import Id ( mkSysLocal, idType, idNewDemandInfo, idArity, setIdUnfolding, setIdType,
- isFCallId, isGlobalId,
- isLocalId, hasNoBinding, idNewStrictness,
- isPrimOpId_maybe
- )
-import DataCon ( isVanillaDataCon, dataConWorkId )
-import PrimOp ( PrimOp( DataToTagOp ) )
-import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel,
- RecFlag(..), isNonRec
- )
+import Id
+import IdInfo
+import DataCon
+import PrimOp
+import BasicTypes
import UniqSupply
import Maybes
import OrdList
import ErrUtils
import DynFlags
-import Util ( listLengthCmp )
+import Util
import Outputable
+import TysWiredIn
+import MkId
+import TysPrim
\end{code}
-- ---------------------------------------------------------------------------
1. Saturate constructor and primop applications.
-2. Convert to A-normal form:
+2. Convert to A-normal form; that is, function arguments
+ are always variables.
* Use case for strict arguments:
f E ==> case E of x -> f x
exprIsTrivial (App e arg) = isTypeArg arg && exprIsTrivial e
exprIsTrivial (Note (SCC _) e) = False
exprIsTrivial (Note _ e) = exprIsTrivial e
+exprIsTrivial (Cast e co) = exprIsTrivial e
exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body
exprIsTrivial other = False
deLamFloat expr1 `thenUs` \ (floats, expr2) ->
returnUs (floats, Note n expr2)
+corePrepExprFloat env (Case (Var id) bndr ty [(DEFAULT,[],expr)])
+ | Just (TickBox {}) <- isTickBoxOp_maybe id
+ = corePrepAnExpr env expr `thenUs` \ expr1 ->
+ deLamFloat expr1 `thenUs` \ (floats, expr2) ->
+ return (floats, Case (Var id) bndr ty [(DEFAULT,[],expr2)])
+
corePrepExprFloat env (Note other_note expr)
= corePrepExprFloat env expr `thenUs` \ (floats, expr') ->
returnUs (floats, Note other_note expr')
+corePrepExprFloat env (Cast expr co)
+ = corePrepExprFloat env expr `thenUs` \ (floats, expr') ->
+ returnUs (floats, Cast expr' co)
+
corePrepExprFloat env expr@(Lam _ _)
= cloneBndrs env bndrs `thenUs` \ (env', bndrs') ->
corePrepAnExpr env' body `thenUs` \ body' ->
returnUs (floats1 `appendFloats` floats2 , Case scrut2 bndr2 ty alts')
where
sat_alt env (con, bs, rhs)
- = let
- env1 = setGadt env con
- in
- cloneBndrs env1 bs `thenUs` \ (env2, bs') ->
+ = cloneBndrs env bs `thenUs` \ (env2, bs') ->
corePrepAnExpr env2 rhs `thenUs` \ rhs1 ->
deLam rhs1 `thenUs` \ rhs2 ->
returnUs (con, bs', rhs2)
-- Here, we can't evaluate the arg strictly, because this
-- partial application might be seq'd
-
- collect_args (Note (Coerce ty1 ty2) fun) depth
- = collect_args fun depth `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
- returnUs (Note (Coerce ty1 ty2) fun', hd, ty1, floats, ss)
-
+ collect_args (Cast fun co) depth
+ = let (_ty1,ty2) = coercionKind co in
+ collect_args fun depth `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
+ returnUs (Cast fun' co, hd, ty2, floats, ss)
+
collect_args (Note note fun) depth
| ignore_note note -- Drop these notes altogether
-- They aren't used by the code generator
ty = exprType fun
ignore_note (CoreNote _) = True
- ignore_note InlineCall = True
ignore_note InlineMe = True
ignore_note _other = False
-- We don't ignore SCCs, since they require some code generation
-- ---------------------------------------------------------------------------
deLam :: CoreExpr -> UniqSM CoreExpr
+-- Takes an expression that may be a lambda,
+-- and returns one that definitely isn't:
+-- (\x.e) ==> let f = \x.e in f
deLam expr =
deLamFloat expr `thenUs` \ (floats, expr) ->
mkBinds floats expr
deLamFloat expr `thenUs` \ (floats, expr') ->
returnUs (floats, Note n expr')
+deLamFloat (Cast e co)
+ = deLamFloat e `thenUs` \ (floats, e') ->
+ returnUs (floats, Cast e' co)
+
deLamFloat expr
| null bndrs = returnUs (emptyFloats, expr)
| otherwise
-- Why try eta reduction? Hasn't the simplifier already done eta?
-- But the simplifier only eta reduces if that leaves something
-- trivial (like f, or f Int). But for deLam it would be enough to
--- get to a partial application, like (map f).
+-- get to a partial application:
+-- \xs. map f xs ==> map f
tryEta bndrs expr@(App _ _)
| ok_to_eta_reduce f &&
-- ---------------------------------------------------------------------------
data CorePrepEnv = CPE (IdEnv Id) -- Clone local Ids
- Bool -- True <=> inside a GADT case; see Note [GADT]
-
--- Note [GADT]
---
--- Be careful with cloning inside GADTs. For example,
--- /\a. \f::a. \x::T a. case x of { T -> f True; ... }
--- The case on x may refine the type of f to be a function type.
--- Without this type refinement, exprType (f True) may simply fail,
--- which is bad.
---
--- Solution: remember when we are inside a potentially-type-refining case,
--- and in that situation use the type from the old occurrence
--- when looking up occurrences
emptyCorePrepEnv :: CorePrepEnv
-emptyCorePrepEnv = CPE emptyVarEnv False
+emptyCorePrepEnv = CPE emptyVarEnv
extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv
-extendCorePrepEnv (CPE env gadt) id id' = CPE (extendVarEnv env id id') gadt
+extendCorePrepEnv (CPE env) id id' = CPE (extendVarEnv env id id')
lookupCorePrepEnv :: CorePrepEnv -> Id -> Id
--- See Note [GADT] above
-lookupCorePrepEnv (CPE env gadt) id
+lookupCorePrepEnv (CPE env) id
= case lookupVarEnv env id of
- Nothing -> id
- Just id' | gadt -> setIdType id' (idType id)
- | otherwise -> id'
-
-setGadt :: CorePrepEnv -> AltCon -> CorePrepEnv
-setGadt env@(CPE id_env _) (DataAlt data_con) | not (isVanillaDataCon data_con) = CPE id_env True
-setGadt env other = env
-
+ Nothing -> id
+ Just id' -> id'
------------------------------------------------------------------------------
-- Cloning binders