X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FCorePrep.lhs;h=757d7da3a565ec0411ae85e05808706364972998;hb=aafdba3bce91afb003f5f50e001e141744837bae;hp=e5165f0ebe98ed34e3aa052a04f5b7d167d58c65;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs index e5165f0..757d7da 100644 --- a/compiler/coreSyn/CorePrep.lhs +++ b/compiler/coreSyn/CorePrep.lhs @@ -1,42 +1,45 @@ % -% (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} +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module CorePrep ( corePrepPgm, corePrepExpr ) where #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 \end{code} @@ -48,7 +51,8 @@ The goal of this pass is to prepare for code generation. 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 @@ -338,6 +342,7 @@ exprIsTrivial (Lit lit) = True 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 @@ -383,10 +388,20 @@ corePrepExprFloat env (Note n@(SCC _) expr) 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' -> @@ -406,10 +421,7 @@ corePrepExprFloat env (Case scrut bndr ty alts) 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) @@ -475,11 +487,11 @@ corePrepExprFloat env expr@(App _ _) -- 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 @@ -498,7 +510,6 @@ corePrepExprFloat env expr@(App _ _) 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 @@ -676,6 +687,9 @@ etaExpandRhs bndr rhs -- --------------------------------------------------------------------------- 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 @@ -690,6 +704,10 @@ deLamFloat (Note n 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 @@ -704,7 +722,8 @@ deLamFloat expr -- 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 && @@ -781,38 +800,18 @@ onceDem = RhsDemand False True -- used at most once -- --------------------------------------------------------------------------- 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