X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreUtils.lhs;h=b07d91777740949680ff170ba3cb3ab9d7fccaef;hb=90334ab3c0c841d466671a416763989d169d4877;hp=9de9bf1d0b883dbdcdafa32549828266af478164;hpb=3355c9d53b220ccb110e5a3c81a1a8b2c9c41555;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index 9de9bf1..b07d917 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -6,20 +6,19 @@ \begin{code} module CoreUtils ( -- Construction - mkNote, mkInlineMe, mkSCC, mkCoerce, mkCoerce2, + mkInlineMe, mkSCC, mkCoerce, mkCoerce2, bindNonRec, needsCaseBinding, mkIfThenElse, mkAltExpr, mkPiType, mkPiTypes, -- Taking expressions apart - findDefault, findAlt, hasDefault, + findDefault, findAlt, -- Properties of expressions - exprType, coreAltsType, - exprIsBottom, exprIsDupable, exprIsTrivial, exprIsCheap, + exprType, coreAltType, + exprIsDupable, exprIsTrivial, exprIsCheap, exprIsValue,exprOkForSpeculation, exprIsBig, - exprIsConApp_maybe, exprIsAtom, - idAppIsBottom, idAppIsCheap, - + exprIsConApp_maybe, exprIsBottom, + rhsIsStatic, -- Arity and eta expansion manifestArity, exprArity, @@ -32,7 +31,7 @@ module CoreUtils ( hashExpr, -- Equality - cheapEqExpr, eqExpr, applyTypeToArgs, applyTypeToArg + cheapEqExpr, tcEqExpr, tcEqExprX, applyTypeToArgs, applyTypeToArg ) where #include "HsVersions.h" @@ -41,35 +40,41 @@ module CoreUtils ( import GLAEXTS -- For `xori` import CoreSyn +import CoreFVs ( exprFreeVars ) import PprCore ( pprCoreExpr ) -import Var ( Var, isId, isTyVar ) +import Var ( Var ) +import VarSet ( unionVarSet ) import VarEnv import Name ( hashName ) -import Literal ( hashLiteral, literalType, litIsDupable, isZeroLit ) -import DataCon ( DataCon, dataConRepArity, dataConArgTys, isExistentialDataCon, dataConTyCon ) +import Packages ( isDllName ) +import CmdLineOpts ( DynFlags ) +import Literal ( hashLiteral, literalType, litIsDupable, + litIsTrivial, isZeroLit, Literal( MachLabel ) ) +import DataCon ( DataCon, dataConRepArity, dataConArgTys, + isVanillaDataCon, dataConTyCon ) import PrimOp ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap ) import Id ( Id, idType, globalIdDetails, idNewStrictness, - mkWildId, idArity, idName, idUnfolding, idInfo, isOneShotLambda, - isDataConWorkId_maybe, mkSysLocal, isDataConWorkId, isBottomingId + mkWildId, idArity, idName, idUnfolding, idInfo, + isOneShotBndr, isStateHackType, isDataConWorkId_maybe, mkSysLocal, + isDataConWorkId, isBottomingId ) -import IdInfo ( GlobalIdDetails(..), - megaSeqIdInfo ) +import IdInfo ( GlobalIdDetails(..), megaSeqIdInfo ) import NewDemand ( appIsBottom ) -import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe, splitFunTy, +import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe, + splitFunTy, tcEqTypeX, applyTys, isUnLiftedType, seqType, mkTyVarTy, - splitForAllTy_maybe, isForAllTy, splitNewType_maybe, - splitTyConApp_maybe, eqType, funResultTy, applyTy, - funResultTy, applyTy + splitForAllTy_maybe, isForAllTy, splitRecNewType_maybe, + splitTyConApp_maybe, coreEqType, funResultTy, applyTy ) import TyCon ( tyConArity ) +-- gaw 2004 import TysWiredIn ( boolTy, trueDataCon, falseDataCon ) import CostCentre ( CostCentre ) import BasicTypes ( Arity ) import Unique ( Unique ) import Outputable import TysPrim ( alphaTy ) -- Debugging only -import Util ( equalLength, lengthAtLeast ) -import TysPrim ( statePrimTyCon ) +import Util ( equalLength, lengthAtLeast, foldl2 ) \end{code} @@ -85,7 +90,7 @@ exprType :: CoreExpr -> Type exprType (Var var) = idType var exprType (Lit lit) = literalType lit exprType (Let _ body) = exprType body -exprType (Case _ _ alts) = coreAltsType alts +exprType (Case _ _ ty alts) = ty exprType (Note (Coerce ty _) e) = ty -- **! should take usage from e exprType (Note other_note e) = exprType e exprType (Lam binder expr) = mkPiType binder (exprType expr) @@ -95,8 +100,8 @@ exprType e@(App _ _) exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy -coreAltsType :: [CoreAlt] -> Type -coreAltsType ((_,_,rhs) : _) = exprType rhs +coreAltType :: CoreAlt -> Type +coreAltType (_,_,rhs) = exprType rhs \end{code} @mkPiType@ makes a (->) type or a forall type, depending on whether @@ -152,11 +157,13 @@ applyTypeToArgs e op_ty (other_arg : args) mkNote removes redundant coercions, and SCCs where possible \begin{code} +#ifdef UNUSED mkNote :: Note -> CoreExpr -> CoreExpr mkNote (Coerce to_ty from_ty) expr = mkCoerce2 to_ty from_ty expr mkNote (SCC cc) expr = mkSCC cc expr mkNote InlineMe expr = mkInlineMe expr mkNote note expr = Note note expr +#endif -- Slide InlineCall in around the function -- No longer necessary I think (SLPJ Apr 99) @@ -199,12 +206,12 @@ mkCoerce to_ty expr = mkCoerce2 to_ty (exprType expr) expr mkCoerce2 :: Type -> Type -> CoreExpr -> CoreExpr mkCoerce2 to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr) - = ASSERT( from_ty `eqType` to_ty2 ) + = ASSERT( from_ty `coreEqType` to_ty2 ) mkCoerce2 to_ty from_ty2 expr mkCoerce2 to_ty from_ty expr - | to_ty `eqType` from_ty = expr - | otherwise = ASSERT( from_ty `eqType` exprType expr ) + | to_ty `coreEqType` from_ty = expr + | otherwise = ASSERT( from_ty `coreEqType` exprType expr ) Note (Coerce to_ty from_ty) expr \end{code} @@ -237,8 +244,9 @@ bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr -- It's used by the desugarer to avoid building bindings -- that give Core Lint a heart attack. Actually the simplifier -- deals with them perfectly well. + bindNonRec bndr rhs body - | needsCaseBinding (idType bndr) rhs = Case rhs bndr [(DEFAULT,[],body)] + | needsCaseBinding (idType bndr) rhs = Case rhs bndr (exprType body) [(DEFAULT,[],body)] | otherwise = Let (NonRec bndr rhs) body needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs) @@ -258,9 +266,10 @@ mkAltExpr (LitAlt lit) [] [] mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr mkIfThenElse guard then_expr else_expr - = Case guard (mkWildId boolTy) - [ (DataAlt trueDataCon, [], then_expr), - (DataAlt falseDataCon, [], else_expr) ] +-- Not going to be refining, so okay to take the type of the "then" clause + = Case guard (mkWildId boolTy) (exprType then_expr) + [ (DataAlt falseDataCon, [], else_expr), -- Increasing order of tag! + (DataAlt trueDataCon, [], then_expr) ] \end{code} @@ -274,10 +283,6 @@ The default alternative must be first, if it exists at all. This makes it easy to find, though it makes matching marginally harder. \begin{code} -hasDefault :: [CoreAlt] -> Bool -hasDefault ((DEFAULT,_,_) : alts) = True -hasDefault _ = False - findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr) findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs) findDefault alts = (alts, Nothing) @@ -287,14 +292,15 @@ findAlt con alts = case alts of (deflt@(DEFAULT,_,_):alts) -> go alts deflt other -> go alts panic_deflt - where panic_deflt = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts)) - go [] deflt = deflt - go (alt@(con1,_,_) : alts) deflt | con == con1 = alt - | otherwise = ASSERT( not (con1 == DEFAULT) ) - go alts deflt + go [] deflt = deflt + go (alt@(con1,_,_) : alts) deflt + = case con `cmpAltCon` con1 of + LT -> deflt -- Missed it already; the alts are in increasing order + EQ -> alt + GT -> ASSERT( not (con1 == DEFAULT) ) go alts deflt \end{code} @@ -323,24 +329,20 @@ completely un-applied primops and foreign-call Ids are sufficiently rare that I plan to allow them to be duplicated and put up with saturating them. +SCC notes. We do not treat (_scc_ "foo" x) as trivial, because + a) it really generates code, (and a heap object when it's + a function arg) to capture the cost centre + b) see the note [SCC-and-exprIsTrivial] in Simplify.simplLazyBind + \begin{code} exprIsTrivial (Var v) = True -- See notes above exprIsTrivial (Type _) = True -exprIsTrivial (Lit lit) = True +exprIsTrivial (Lit lit) = litIsTrivial lit exprIsTrivial (App e arg) = not (isRuntimeArg arg) && exprIsTrivial e -exprIsTrivial (Note _ e) = exprIsTrivial e +exprIsTrivial (Note (SCC _) e) = False -- See notes above +exprIsTrivial (Note _ e) = exprIsTrivial e exprIsTrivial (Lam b body) = not (isRuntimeVar b) && exprIsTrivial body exprIsTrivial other = False - -exprIsAtom :: CoreExpr -> Bool --- Used to decide whether to let-binding an STG argument --- when compiling to ILX => type applications are not allowed -exprIsAtom (Var v) = True -- primOpIsDupable? -exprIsAtom (Lit lit) = True -exprIsAtom (Type ty) = True -exprIsAtom (Note (SCC _) e) = False -exprIsAtom (Note _ e) = exprIsAtom e -exprIsAtom other = False \end{code} @@ -404,13 +406,13 @@ because sharing will make sure it is only evaluated once. \begin{code} exprIsCheap :: CoreExpr -> Bool -exprIsCheap (Lit lit) = True -exprIsCheap (Type _) = True -exprIsCheap (Var _) = True -exprIsCheap (Note InlineMe e) = True -exprIsCheap (Note _ e) = exprIsCheap e -exprIsCheap (Lam x e) = isRuntimeVar x || exprIsCheap e -exprIsCheap (Case e _ alts) = exprIsCheap e && +exprIsCheap (Lit lit) = True +exprIsCheap (Type _) = True +exprIsCheap (Var _) = True +exprIsCheap (Note InlineMe e) = True +exprIsCheap (Note _ e) = exprIsCheap e +exprIsCheap (Lam x e) = isRuntimeVar x || exprIsCheap e +exprIsCheap (Case e _ _ alts) = exprIsCheap e && and [exprIsCheap rhs | (_,_,rhs) <- alts] -- Experimentally, treat (case x of ...) as cheap -- (and case __coerce x etc.) @@ -447,7 +449,7 @@ idAppIsCheap id n_val_args -- counts as WHNF | otherwise = case globalIdDetails id of DataConWorkId _ -> True - RecordSelId _ -> True -- I'm experimenting with making record selection + RecordSelId _ _ -> True -- I'm experimenting with making record selection ClassOpId _ -> True -- look cheap, so we will substitute it inside a -- lambda. Particularly for dictionary field selection @@ -539,13 +541,14 @@ exprIsBottom :: CoreExpr -> Bool -- True => definitely bottom exprIsBottom e = go 0 e where -- n is the number of args - go n (Note _ e) = go n e - go n (Let _ e) = go n e - go n (Case e _ _) = go 0 e -- Just check the scrut - go n (App e _) = go (n+1) e - go n (Var v) = idAppIsBottom v n - go n (Lit _) = False - go n (Lam _ _) = False + go n (Note _ e) = go n e + go n (Let _ e) = go n e + go n (Case e _ _ _) = go 0 e -- Just check the scrut + go n (App e _) = go (n+1) e + go n (Var v) = idAppIsBottom v n + go n (Lit _) = False + go n (Lam _ _) = False + go n (Type _) = False idAppIsBottom :: Id -> Int -> Bool idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args @@ -632,9 +635,9 @@ exprIsConApp_maybe (Note (Coerce to_ty from_ty) expr) case splitTyConApp_maybe to_ty of { Nothing -> Nothing ; - Just (tc, tc_arg_tys) | tc /= dataConTyCon dc -> Nothing - | isExistentialDataCon dc -> Nothing - | otherwise -> + Just (tc, tc_arg_tys) | tc /= dataConTyCon dc -> Nothing + | not (isVanillaDataCon dc) -> Nothing + | otherwise -> -- Type constructor must match -- We knock out existentials to keep matters simple(r) let @@ -690,38 +693,62 @@ exprIsConApp_maybe expr = analyse (collectArgs expr) \begin{code} exprEtaExpandArity :: CoreExpr -> Arity --- The Int is number of value args the thing can be --- applied to without doing much work --- --- This is used when eta expanding --- e ==> \xy -> e x y --- --- It returns 1 (or more) to: --- case x of p -> \s -> ... --- because for I/O ish things we really want to get that \s to the top. --- We are prepared to evaluate x each time round the loop in order to get that - --- It's all a bit more subtle than it looks. Consider one-shot lambdas --- let x = expensive in \y z -> E --- We want this to have arity 2 if the \y-abstraction is a 1-shot lambda --- Hence the ArityType returned by arityType - --- NB: this is particularly important/useful for IO state --- transformers, where we often get --- let x = E in \ s -> ... --- and the \s is a real-world state token abstraction. Such --- abstractions are almost invariably 1-shot, so we want to --- pull the \s out, past the let x=E. --- The hack is in Id.isOneShotLambda --- --- Consider also --- f = \x -> error "foo" --- Here, arity 1 is fine. But if it is --- f = \x -> case e of --- True -> error "foo" --- False -> \y -> x+y --- then we want to get arity 2. --- Hence the ABot/ATop in ArityType +{- The Arity returned is the number of value args the + thing can be applied to without doing much work + +exprEtaExpandArity is used when eta expanding + e ==> \xy -> e x y + +It returns 1 (or more) to: + case x of p -> \s -> ... +because for I/O ish things we really want to get that \s to the top. +We are prepared to evaluate x each time round the loop in order to get that + +It's all a bit more subtle than it looks: + +1. One-shot lambdas + +Consider one-shot lambdas + let x = expensive in \y z -> E +We want this to have arity 2 if the \y-abstraction is a 1-shot lambda +Hence the ArityType returned by arityType + +2. The state-transformer hack + +The one-shot lambda special cause is particularly important/useful for +IO state transformers, where we often get + let x = E in \ s -> ... + +and the \s is a real-world state token abstraction. Such abstractions +are almost invariably 1-shot, so we want to pull the \s out, past the +let x=E, even if E is expensive. So we treat state-token lambdas as +one-shot even if they aren't really. The hack is in Id.isOneShotBndr. + +3. Dealing with bottom + +Consider also + f = \x -> error "foo" +Here, arity 1 is fine. But if it is + f = \x -> case x of + True -> error "foo" + False -> \y -> x+y +then we want to get arity 2. Tecnically, this isn't quite right, because + (f True) `seq` 1 +should diverge, but it'll converge if we eta-expand f. Nevertheless, we +do so; it improves some programs significantly, and increasing convergence +isn't a bad thing. Hence the ABot/ATop in ArityType. + +Actually, the situation is worse. Consider + f = \x -> case x of + True -> \y -> x+y + False -> \y -> x-y +Can we eta-expand here? At first the answer looks like "yes of course", but +consider + (f bot) `seq` 1 +This should diverge! But if we eta-expand, it won't. Again, we ignore this +"problem", because being scrupulous would lose an important transformation for +many programs. +-} exprEtaExpandArity e = arityDepth (arityType e) @@ -751,18 +778,28 @@ arityType (Note n e) = arityType e -- | otherwise = ATop arityType (Var v) - = mk (idArity v) + = mk (idArity v) (arg_tys (idType v)) where - mk :: Arity -> ArityType - mk 0 | isBottomingId v = ABot - | otherwise = ATop - mk n = AFun False (mk (n-1)) - - -- When the type of the Id encodes one-shot-ness, - -- use the idinfo here + mk :: Arity -> [Type] -> ArityType + -- The argument types are only to steer the "state hack" + -- Consider case x of + -- True -> foo + -- False -> \(s:RealWorld) -> e + -- where foo has arity 1. Then we want the state hack to + -- apply to foo too, so we can eta expand the case. + mk 0 tys | isBottomingId v = ABot + | otherwise = ATop + mk n (ty:tys) = AFun (isStateHackType ty) (mk (n-1) tys) + mk n [] = AFun False (mk (n-1) []) + + arg_tys :: Type -> [Type] -- Ignore for-alls + arg_tys ty + | Just (_, ty') <- splitForAllTy_maybe ty = arg_tys ty' + | Just (arg,res) <- splitFunTy_maybe ty = arg : arg_tys res + | otherwise = [] -- Lambdas; increase arity -arityType (Lam x e) | isId x = AFun (isOneShotLambda x || isStateHack x) (arityType e) +arityType (Lam x e) | isId x = AFun (isOneShotBndr x) (arityType e) | otherwise = arityType e -- Applications; decrease arity @@ -773,7 +810,12 @@ arityType (App f a) = case arityType f of -- Case/Let; keep arity if either the expression is cheap -- or it's a 1-shot lambda -arityType (Case scrut _ alts) = case foldr1 andArityType [arityType rhs | (_,_,rhs) <- alts] of + -- The former is not really right for Haskell + -- f x = case x of { (a,b) -> \y. e } + -- ===> + -- f x y = case x of { (a,b) -> e } + -- The difference is observable using 'seq' +arityType (Case scrut _ _ alts) = case foldr1 andArityType [arityType rhs | (_,_,rhs) <- alts] of xs@(AFun one_shot _) | one_shot -> xs xs | exprIsCheap scrut -> xs | otherwise -> ATop @@ -785,28 +827,6 @@ arityType (Let b e) = case arityType e of arityType other = ATop -isStateHack id = case splitTyConApp_maybe (idType id) of - Just (tycon,_) | tycon == statePrimTyCon -> True - other -> False - - -- The last clause is a gross hack. It claims that - -- every function over realWorldStatePrimTy is a one-shot - -- function. This is pretty true in practice, and makes a big - -- difference. For example, consider - -- a `thenST` \ r -> ...E... - -- The early full laziness pass, if it doesn't know that r is one-shot - -- will pull out E (let's say it doesn't mention r) to give - -- let lvl = E in a `thenST` \ r -> ...lvl... - -- When `thenST` gets inlined, we end up with - -- let lvl = E in \s -> case a s of (r, s') -> ...lvl... - -- and we don't re-inline E. - -- - -- It would be better to spot that r was one-shot to start with, but - -- I don't want to rely on that. - -- - -- Another good example is in fill_in in PrelPack.lhs. We should be able to - -- spot that fill_in has arity 2 (and when Keith is done, we will) but we can't yet. - {- NOT NEEDED ANY MORE: etaExpand is cleverer ok_note InlineMe = False ok_note other = True @@ -910,15 +930,17 @@ eta_expand n us expr ty ; Nothing -> -- Given this: - -- newtype T = MkT (Int -> Int) + -- newtype T = MkT ([T] -> Int) -- Consider eta-expanding this -- eta_expand 1 e T -- We want to get - -- coerce T (\x::Int -> (coerce (Int->Int) e) x) + -- coerce T (\x::[T] -> (coerce ([T]->Int) e) x) + -- Only try this for recursive newtypes; the non-recursive kind + -- are transparent anyway - case splitNewType_maybe ty of { + case splitRecNewType_maybe ty of { Just ty' -> mkCoerce2 ty ty' (eta_expand n us (mkCoerce2 ty' ty expr) ty') ; - Nothing -> pprTrace "Bad eta expand" (ppr expr $$ ppr ty) expr + Nothing -> pprTrace "Bad eta expand" (ppr n $$ ppr expr $$ ppr ty) expr }}} \end{code} @@ -979,7 +1001,7 @@ cheapEqExpr :: Expr b -> Expr b -> Bool cheapEqExpr (Var v1) (Var v2) = v1==v2 cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2 -cheapEqExpr (Type t1) (Type t2) = t1 `eqType` t2 +cheapEqExpr (Type t1) (Type t2) = t1 `coreEqType` t2 cheapEqExpr (App f1 a1) (App f2 a2) = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2 @@ -997,55 +1019,49 @@ exprIsBig other = True \begin{code} -eqExpr :: CoreExpr -> CoreExpr -> Bool - -- Works ok at more general type, but only needed at CoreExpr - -- Used in rule matching, so when we find a type we use - -- eqTcType, which doesn't look through newtypes - -- [And it doesn't risk falling into a black hole either.] -eqExpr e1 e2 - = eq emptyVarEnv e1 e2 +tcEqExpr :: CoreExpr -> CoreExpr -> Bool +-- Used in rule matching, so does *not* look through +-- newtypes, predicate types; hence tcEqExpr + +tcEqExpr e1 e2 = tcEqExprX rn_env e1 e2 where - -- The "env" maps variables in e1 to variables in ty2 - -- So when comparing lambdas etc, - -- we in effect substitute v2 for v1 in e1 before continuing - eq env (Var v1) (Var v2) = case lookupVarEnv env v1 of - Just v1' -> v1' == v2 - Nothing -> v1 == v2 - - eq env (Lit lit1) (Lit lit2) = lit1 == lit2 - eq env (App f1 a1) (App f2 a2) = eq env f1 f2 && eq env a1 a2 - eq env (Lam v1 e1) (Lam v2 e2) = eq (extendVarEnv env v1 v2) e1 e2 - eq env (Let (NonRec v1 r1) e1) - (Let (NonRec v2 r2) e2) = eq env r1 r2 && eq (extendVarEnv env v1 v2) e1 e2 - eq env (Let (Rec ps1) e1) - (Let (Rec ps2) e2) = equalLength ps1 ps2 && - and (zipWith eq_rhs ps1 ps2) && - eq env' e1 e2 + rn_env = mkRnEnv2 (mkInScopeSet (exprFreeVars e1 `unionVarSet` exprFreeVars e2)) + +tcEqExprX :: RnEnv2 -> CoreExpr -> CoreExpr -> Bool +tcEqExprX env (Var v1) (Var v2) = rnOccL env v1 == rnOccR env v2 +tcEqExprX env (Lit lit1) (Lit lit2) = lit1 == lit2 +tcEqExprX env (App f1 a1) (App f2 a2) = tcEqExprX env f1 f2 && tcEqExprX env a1 a2 +tcEqExprX env (Lam v1 e1) (Lam v2 e2) = tcEqExprX (rnBndr2 env v1 v2) e1 e2 +tcEqExprX env (Let (NonRec v1 r1) e1) + (Let (NonRec v2 r2) e2) = tcEqExprX env r1 r2 + && tcEqExprX (rnBndr2 env v1 v2) e1 e2 +tcEqExprX env (Let (Rec ps1) e1) + (Let (Rec ps2) e2) = equalLength ps1 ps2 + && and (zipWith eq_rhs ps1 ps2) + && tcEqExprX env' e1 e2 where - env' = extendVarEnvList env [(v1,v2) | ((v1,_),(v2,_)) <- zip ps1 ps2] - eq_rhs (_,r1) (_,r2) = eq env' r1 r2 - eq env (Case e1 v1 a1) - (Case e2 v2 a2) = eq env e1 e2 && - equalLength a1 a2 && - and (zipWith (eq_alt env') a1 a2) + env' = foldl2 rn_bndr2 env ps2 ps2 + rn_bndr2 env (b1,_) (b2,_) = rnBndr2 env b1 b2 + eq_rhs (_,r1) (_,r2) = tcEqExprX env' r1 r2 +tcEqExprX env (Case e1 v1 t1 a1) + (Case e2 v2 t2 a2) = tcEqExprX env e1 e2 + && tcEqTypeX env t1 t2 + && equalLength a1 a2 + && and (zipWith (eq_alt env') a1 a2) where - env' = extendVarEnv env v1 v2 + env' = rnBndr2 env v1 v2 - eq env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && eq env e1 e2 - eq env (Type t1) (Type t2) = t1 `eqType` t2 - eq env e1 e2 = False +tcEqExprX env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && tcEqExprX env e1 e2 +tcEqExprX env (Type t1) (Type t2) = tcEqTypeX env t1 t2 +tcEqExprX env e1 e2 = False - eq_list env [] [] = True - eq_list env (e1:es1) (e2:es2) = eq env e1 e2 && eq_list env es1 es2 - eq_list env es1 es2 = False - - eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 && - eq (extendVarEnvList env (vs1 `zip` vs2)) r1 r2 - - eq_note env (SCC cc1) (SCC cc2) = cc1 == cc2 - eq_note env (Coerce t1 f1) (Coerce t2 f2) = t1 `eqType` t2 && f1 `eqType` f2 - eq_note env InlineCall InlineCall = True - eq_note env other1 other2 = False +eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 && tcEqExprX (rnBndrs2 env vs1 vs2) r1 r2 + +eq_note env (SCC cc1) (SCC cc2) = cc1 == cc2 +eq_note env (Coerce t1 f1) (Coerce t2 f2) = tcEqTypeX env t1 t2 && tcEqTypeX env f1 f2 +eq_note env InlineCall InlineCall = True +eq_note env (CoreNote s1) (CoreNote s2) = s1 == s2 +eq_note env other1 other2 = False \end{code} @@ -1062,19 +1078,20 @@ coreBindsSize bs = foldr ((+) . bindSize) 0 bs exprSize :: CoreExpr -> Int -- A measure of the size of the expressions -- It also forces the expression pretty drastically as a side effect -exprSize (Var v) = v `seq` 1 -exprSize (Lit lit) = lit `seq` 1 -exprSize (App f a) = exprSize f + exprSize a -exprSize (Lam b e) = varSize b + exprSize e -exprSize (Let b e) = bindSize b + exprSize e -exprSize (Case e b as) = exprSize e + varSize b + foldr ((+) . altSize) 0 as -exprSize (Note n e) = noteSize n + exprSize e -exprSize (Type t) = seqType t `seq` 1 +exprSize (Var v) = v `seq` 1 +exprSize (Lit lit) = lit `seq` 1 +exprSize (App f a) = exprSize f + exprSize a +exprSize (Lam b e) = varSize b + exprSize e +exprSize (Let b e) = bindSize b + exprSize e +exprSize (Case e b t as) = seqType t `seq` exprSize e + varSize b + 1 + foldr ((+) . altSize) 0 as +exprSize (Note n e) = noteSize n + exprSize e +exprSize (Type t) = seqType t `seq` 1 noteSize (SCC cc) = cc `seq` 1 noteSize (Coerce t1 t2) = seqType t1 `seq` seqType t2 `seq` 1 noteSize InlineCall = 1 noteSize InlineMe = 1 +noteSize (CoreNote s) = s `seq` 1 -- hdaume: core annotations varSize :: Var -> Int varSize b | isTyVar b = 1 @@ -1109,7 +1126,7 @@ hashExpr e | hash < 0 = 77 -- Just in case we hit -maxInt hash_expr (Note _ e) = hash_expr e hash_expr (Let (NonRec b r) e) = hashId b hash_expr (Let (Rec ((b,r):_)) e) = hashId b -hash_expr (Case _ b _) = hashId b +hash_expr (Case _ b _ _) = hashId b hash_expr (App f e) = hash_expr f * fast_hash_expr e hash_expr (Var v) = hashId v hash_expr (Lit lit) = hashLiteral lit @@ -1126,3 +1143,135 @@ fast_hash_expr other = 1 hashId :: Id -> Int hashId id = hashName (idName id) \end{code} + +%************************************************************************ +%* * +\subsection{Determining non-updatable right-hand-sides} +%* * +%************************************************************************ + +Top-level constructor applications can usually be allocated +statically, but they can't if the constructor, or any of the +arguments, come from another DLL (because we can't refer to static +labels in other DLLs). + +If this happens we simply make the RHS into an updatable thunk, +and 'exectute' it rather than allocating it statically. + +\begin{code} +rhsIsStatic :: DynFlags -> CoreExpr -> Bool +-- This function is called only on *top-level* right-hand sides +-- Returns True if the RHS can be allocated statically, with +-- no thunks involved at all. +-- +-- It's called (i) in TidyPgm.hasCafRefs to decide if the rhs is, or +-- refers to, CAFs; and (ii) in CoreToStg to decide whether to put an +-- update flag on it. +-- +-- The basic idea is that rhsIsStatic returns True only if the RHS is +-- (a) a value lambda +-- (b) a saturated constructor application with static args +-- +-- BUT watch out for +-- (i) Any cross-DLL references kill static-ness completely +-- because they must be 'executed' not statically allocated +-- +-- (ii) We treat partial applications as redexes, because in fact we +-- make a thunk for them that runs and builds a PAP +-- at run-time. The only appliations that are treated as +-- static are *saturated* applications of constructors. + +-- We used to try to be clever with nested structures like this: +-- ys = (:) w ((:) w []) +-- on the grounds that CorePrep will flatten ANF-ise it later. +-- But supporting this special case made the function much more +-- complicated, because the special case only applies if there are no +-- enclosing type lambdas: +-- ys = /\ a -> Foo (Baz ([] a)) +-- Here the nested (Baz []) won't float out to top level in CorePrep. +-- +-- But in fact, even without -O, nested structures at top level are +-- flattened by the simplifier, so we don't need to be super-clever here. +-- +-- Examples +-- +-- f = \x::Int. x+7 TRUE +-- p = (True,False) TRUE +-- +-- d = (fst p, False) FALSE because there's a redex inside +-- (this particular one doesn't happen but...) +-- +-- h = D# (1.0## /## 2.0##) FALSE (redex again) +-- n = /\a. Nil a TRUE +-- +-- t = /\a. (:) (case w a of ...) (Nil a) FALSE (redex) +-- +-- +-- This is a bit like CoreUtils.exprIsValue, with the following differences: +-- a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC) +-- +-- b) (C x xs), where C is a contructors is updatable if the application is +-- dynamic +-- +-- c) don't look through unfolding of f in (f x). +-- +-- When opt_RuntimeTypes is on, we keep type lambdas and treat +-- them as making the RHS re-entrant (non-updatable). + +rhsIsStatic dflags rhs = is_static False rhs + where + is_static :: Bool -- True <=> in a constructor argument; must be atomic + -> CoreExpr -> Bool + + is_static False (Lam b e) = isRuntimeVar b || is_static False e + + is_static in_arg (Note (SCC _) e) = False + is_static in_arg (Note _ e) = is_static in_arg e + + is_static in_arg (Lit lit) + = case lit of + MachLabel _ _ -> False + other -> True + -- A MachLabel (foreign import "&foo") in an argument + -- prevents a constructor application from being static. The + -- reason is that it might give rise to unresolvable symbols + -- in the object file: under Linux, references to "weak" + -- symbols from the data segment give rise to "unresolvable + -- relocation" errors at link time This might be due to a bug + -- in the linker, but we'll work around it here anyway. + -- SDM 24/2/2004 + + is_static in_arg other_expr = go other_expr 0 + where + go (Var f) n_val_args + | not (isDllName dflags (idName f)) + = saturated_data_con f n_val_args + || (in_arg && n_val_args == 0) + -- A naked un-applied variable is *not* deemed a static RHS + -- E.g. f = g + -- Reason: better to update so that the indirection gets shorted + -- out, and the true value will be seen + -- NB: if you change this, you'll break the invariant that THUNK_STATICs + -- are always updatable. If you do so, make sure that non-updatable + -- ones have enough space for their static link field! + + go (App f a) n_val_args + | isTypeArg a = go f n_val_args + | not in_arg && is_static True a = go f (n_val_args + 1) + -- The (not in_arg) checks that we aren't in a constructor argument; + -- if we are, we don't allow (value) applications of any sort + -- + -- NB. In case you wonder, args are sometimes not atomic. eg. + -- x = D# (1.0## /## 2.0##) + -- can't float because /## can fail. + + go (Note (SCC _) f) n_val_args = False + go (Note _ f) n_val_args = go f n_val_args + + go other n_val_args = False + + saturated_data_con f n_val_args + = case isDataConWorkId_maybe f of + Just dc -> n_val_args == dataConRepArity dc + Nothing -> False +\end{code}