X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreUtils.lhs;h=270d44de15b673eba64a9c41d9ca41a7160e6a87;hb=ef5b4b146aa172d8ac10f39b5eb3d7a0f948d8f1;hp=1b552af83afd9cb43c0e52ed732248d838d49d4d;hpb=c8276ef7cf2a315fcb8f609cf548a6e90625e578;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index 1b552af..270d44d 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -6,24 +6,23 @@ \begin{code} module CoreUtils ( -- Construction - mkNote, mkInlineMe, mkSCC, mkCoerce, - bindNonRec, mkIfThenElse, mkAltExpr, - mkPiType, + mkInlineMe, mkSCC, mkCoerce, mkCoerce2, + bindNonRec, needsCaseBinding, + mkIfThenElse, mkAltExpr, mkPiType, mkPiTypes, -- Taking expressions apart findDefault, findAlt, -- Properties of expressions - exprType, coreAltsType, - exprIsBottom, exprIsDupable, exprIsTrivial, exprIsCheap, + exprType, coreAltType, + exprIsDupable, exprIsTrivial, exprIsCheap, exprIsValue,exprOkForSpeculation, exprIsBig, - exprIsConApp_maybe, exprIsAtom, - idAppIsBottom, idAppIsCheap, - exprArity, + exprIsConApp_maybe, exprIsBottom, + rhsIsStatic, - -- Expr transformation - etaReduce, etaExpand, - exprArity, exprEtaExpandArity, + -- Arity and eta expansion + manifestArity, exprArity, + exprEtaExpandArity, etaExpand, -- Size coreBindsSize, @@ -32,43 +31,49 @@ module CoreUtils ( hashExpr, -- Equality - cheapEqExpr, eqExpr, applyTypeToArgs + cheapEqExpr, eqExpr, applyTypeToArgs, applyTypeToArg ) where #include "HsVersions.h" -import GlaExts -- For `xori` +import GLAEXTS -- For `xori` import CoreSyn -import CoreFVs ( exprFreeVars ) import PprCore ( pprCoreExpr ) import Var ( Var, isId, isTyVar ) -import VarSet import VarEnv import Name ( hashName ) -import Literal ( hashLiteral, literalType, litIsDupable ) -import DataCon ( DataCon, dataConRepArity ) -import PrimOp ( primOpOkForSpeculation, primOpIsCheap, - primOpIsDupable ) -import Id ( Id, idType, idFlavour, idStrictness, idLBVarInfo, - mkWildId, idArity, idName, idUnfolding, idInfo, isOneShotLambda, - isDataConId_maybe, isPrimOpId_maybe, mkSysLocal, hasNoBinding +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, + isOneShotBndr, isStateHackType, isDataConWorkId_maybe, mkSysLocal, + isDataConWorkId, isBottomingId ) -import IdInfo ( LBVarInfo(..), - IdFlavour(..), - megaSeqIdInfo ) -import Demand ( appIsBottom ) -import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe, - applyTys, isUnLiftedType, seqType, mkUTy, mkTyVarTy, - splitForAllTy_maybe, splitNewType_maybe +import IdInfo ( GlobalIdDetails(..), megaSeqIdInfo ) +import NewDemand ( appIsBottom ) +import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe, + splitFunTy, + applyTys, isUnLiftedType, seqType, mkTyVarTy, + splitForAllTy_maybe, isForAllTy, splitRecNewType_maybe, + splitTyConApp_maybe, eqType, funResultTy, applyTy, + funResultTy, applyTy ) +import TyCon ( tyConArity ) +-- gaw 2004 import TysWiredIn ( boolTy, trueDataCon, falseDataCon ) import CostCentre ( CostCentre ) -import UniqSupply ( UniqSupply, splitUniqSupply, uniqFromSupply ) -import Maybes ( maybeToBool ) +import BasicTypes ( Arity ) +import Unique ( Unique ) import Outputable import TysPrim ( alphaTy ) -- Debugging only +import Util ( equalLength, lengthAtLeast ) \end{code} @@ -84,7 +89,8 @@ exprType :: CoreExpr -> Type exprType (Var var) = idType var exprType (Lit lit) = literalType lit exprType (Let _ body) = exprType body -exprType (Case _ _ alts) = coreAltsType alts +-- gaw 2004 +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) @@ -94,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 @@ -104,26 +110,35 @@ lbvarinfo field to figure out the right annotation for the arrove in case of a term variable. \begin{code} -mkPiType :: Var -> Type -> Type -- The more polymorphic version doesn't work... -mkPiType v ty | isId v = (case idLBVarInfo v of - LBVarInfo u -> mkUTy u - otherwise -> id) $ - mkFunTy (idType v) ty - | isTyVar v = mkForAllTy v ty +mkPiType :: Var -> Type -> Type -- The more polymorphic version +mkPiTypes :: [Var] -> Type -> Type -- doesn't work... + +mkPiTypes vs ty = foldr mkPiType ty vs + +mkPiType v ty + | isId v = mkFunTy (idType v) ty + | otherwise = mkForAllTy v ty \end{code} \begin{code} --- The first argument is just for debugging +applyTypeToArg :: Type -> CoreExpr -> Type +applyTypeToArg fun_ty (Type arg_ty) = applyTy fun_ty arg_ty +applyTypeToArg fun_ty other_arg = funResultTy fun_ty + applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type +-- A more efficient version of applyTypeToArg +-- when we have several args +-- The first argument is just for debugging applyTypeToArgs e op_ty [] = op_ty applyTypeToArgs e op_ty (Type ty : args) = -- Accumulate type arguments so we can instantiate all at once - applyTypeToArgs e (applyTys op_ty tys) rest_args + go [ty] args where - (tys, rest_args) = go [ty] args - go tys (Type ty : args) = go (ty:tys) args - go tys rest_args = (reverse tys, rest_args) + go rev_tys (Type ty : args) = go (ty:rev_tys) args + go rev_tys rest_args = applyTypeToArgs e op_ty' rest_args + where + op_ty' = applyTys op_ty (reverse rev_tys) applyTypeToArgs e op_ty (other_arg : args) = case (splitFunTy_maybe op_ty) of @@ -142,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 = mkCoerce to_ty from_ty expr +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) @@ -184,26 +201,29 @@ mkInlineMe e = Note InlineMe e \begin{code} -mkCoerce :: Type -> Type -> CoreExpr -> CoreExpr - -mkCoerce to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr) - = ASSERT( from_ty == to_ty2 ) - mkCoerce to_ty from_ty2 expr - -mkCoerce to_ty from_ty expr - | to_ty == from_ty = expr - | otherwise = ASSERT( from_ty == exprType expr ) - Note (Coerce to_ty from_ty) expr +mkCoerce :: Type -> CoreExpr -> CoreExpr +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 ) + 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 ) + Note (Coerce to_ty from_ty) expr \end{code} \begin{code} mkSCC :: CostCentre -> Expr b -> Expr b -- Note: Nested SCC's *are* preserved for the benefit of - -- cost centre stack profiling (Durham) - -mkSCC cc (Lit lit) = Lit lit -mkSCC cc (Lam x e) = Lam x (mkSCC cc e) -- Move _scc_ inside lambda -mkSCC cc expr = Note (SCC cc) expr + -- cost centre stack profiling +mkSCC cc (Lit lit) = Lit lit +mkSCC cc (Lam x e) = Lam x (mkSCC cc e) -- Move _scc_ inside lambda +mkSCC cc (Note (SCC cc') e) = Note (SCC cc) (Note (SCC cc') e) +mkSCC cc (Note n e) = Note n (mkSCC cc e) -- Move _scc_ inside notes +mkSCC cc expr = Note (SCC cc) expr \end{code} @@ -224,9 +244,16 @@ 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 - | isUnLiftedType (idType bndr) = Case rhs bndr [(DEFAULT,[],body)] - | otherwise = Let (NonRec bndr rhs) body +-- gaw 2004 + | 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) + -- Make a case expression instead of a let + -- These can arise either from the desugarer, + -- or from beta reductions: (\x.e) (x +# y) \end{code} \begin{code} @@ -240,7 +267,9 @@ mkAltExpr (LitAlt lit) [] [] mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr mkIfThenElse guard then_expr else_expr - = Case guard (mkWildId boolTy) +-- gaw 2004 +-- Not going to be refining, so okay to take the type of the "then" clause + = Case guard (mkWildId boolTy) (exprType then_expr) [ (DataAlt trueDataCon, [], then_expr), (DataAlt falseDataCon, [], else_expr) ] \end{code} @@ -252,25 +281,27 @@ mkIfThenElse guard then_expr else_expr %* * %************************************************************************ +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} findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr) -findDefault [] = ([], Nothing) -findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null alts && null args ) - ([], Just rhs) -findDefault (alt : alts) = case findDefault alts of - (alts', deflt) -> (alt : alts', deflt) +findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs) +findDefault alts = (alts, Nothing) findAlt :: AltCon -> [CoreAlt] -> CoreAlt findAlt con alts - = go alts + = case alts of + (deflt@(DEFAULT,_,_):alts) -> go alts deflt + other -> go alts panic_deflt + where - go [] = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts)) - go (alt : alts) | matches alt = alt - | otherwise = go alts + panic_deflt = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts)) - matches (DEFAULT, _, _) = True - matches (con1, _, _) = con == con1 + go [] deflt = deflt + go (alt@(con1,_,_) : alts) deflt | con == con1 = alt + | otherwise = ASSERT( not (con1 == DEFAULT) ) + go alts deflt \end{code} @@ -288,35 +319,31 @@ findAlt con alts @exprIsBottom@ is true of expressions that are guaranteed to diverge +There used to be a gruesome test for (hasNoBinding v) in the +Var case: + exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0 +The idea here is that a constructor worker, like $wJust, is +really short for (\x -> $wJust x), becuase $wJust has no binding. +So it should be treated like a lambda. Ditto unsaturated primops. +But now constructor workers are not "have-no-binding" Ids. And +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) - | hasNoBinding v = idArity v == 0 - -- WAS: | Just op <- isPrimOpId_maybe v = primOpIsDupable op - -- The idea here is that a constructor worker, like $wJust, is - -- really short for (\x -> $wJust x), becuase $wJust has no binding. - -- So it should be treated like a lambda. - -- Ditto unsaturated primops. - -- This came up when dealing with eta expansion/reduction for - -- x = $wJust - -- Here we want to eta-expand. This looks like an optimisation, - -- but it's important (albeit tiresome) that CoreSat doesn't increase - -- anything's arity - | otherwise = True -exprIsTrivial (Type _) = True -exprIsTrivial (Lit lit) = True -exprIsTrivial (App e arg) = isTypeArg arg && exprIsTrivial e -exprIsTrivial (Note _ e) = exprIsTrivial e -exprIsTrivial (Lam b body) | isTyVar 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 _ e) = exprIsAtom e -exprIsAtom other = False +exprIsTrivial (Var v) = True -- See notes above +exprIsTrivial (Type _) = True +exprIsTrivial (Lit lit) = litIsTrivial lit +exprIsTrivial (App e arg) = not (isRuntimeArg arg) && 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 \end{code} @@ -332,10 +359,11 @@ exprIsAtom other = False \begin{code} -exprIsDupable (Type _) = True -exprIsDupable (Var v) = True -exprIsDupable (Lit lit) = litIsDupable lit -exprIsDupable (Note _ e) = exprIsDupable e +exprIsDupable (Type _) = True +exprIsDupable (Var v) = True +exprIsDupable (Lit lit) = litIsDupable lit +exprIsDupable (Note InlineMe e) = True +exprIsDupable (Note _ e) = exprIsDupable e exprIsDupable expr = go expr 0 where @@ -379,12 +407,14 @@ 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 _ e) = exprIsCheap e -exprIsCheap (Lam x e) = if isId x then True else 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 +-- gaw 2004 +exprIsCheap (Case e _ _ alts) = exprIsCheap e && and [exprIsCheap rhs | (_,_,rhs) <- alts] -- Experimentally, treat (case x of ...) as cheap -- (and case __coerce x etc.) @@ -409,8 +439,8 @@ exprIsCheap other_expr -- because it certainly doesn't need to be shared! go (App f a) n_args args_cheap - | isTypeArg a = go f n_args args_cheap - | otherwise = go f (n_args + 1) (exprIsCheap a && args_cheap) + | not (isRuntimeArg a) = go f n_args args_cheap + | otherwise = go f (n_args + 1) (exprIsCheap a && args_cheap) go other n_args args_cheap = False @@ -419,11 +449,11 @@ idAppIsCheap id n_val_args | n_val_args == 0 = True -- Just a type application of -- a variable (f t1 t2 t3) -- counts as WHNF - | otherwise = case idFlavour id of - DataConId _ -> True - RecordSelId _ -> True -- I'm experimenting with making record selection - -- look cheap, so we will substitute it inside a - -- lambda. Particularly for dictionary field selection + | otherwise = case globalIdDetails id of + DataConWorkId _ -> True + 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 PrimOpId op -> primOpIsCheap op -- In principle we should worry about primops -- that return a type variable, since the result @@ -461,28 +491,50 @@ side effects, and can't diverge or raise an exception. \begin{code} exprOkForSpeculation :: CoreExpr -> Bool exprOkForSpeculation (Lit _) = True +exprOkForSpeculation (Type _) = True exprOkForSpeculation (Var v) = isUnLiftedType (idType v) exprOkForSpeculation (Note _ e) = exprOkForSpeculation e exprOkForSpeculation other_expr - = go other_expr 0 True + = case collectArgs other_expr of + (Var f, args) -> spec_ok (globalIdDetails f) args + other -> False + where - go (Var f) n_args args_ok - = case idFlavour f of - DataConId _ -> True -- The strictness of the constructor has already - -- been expressed by its "wrapper", so we don't need - -- to take the arguments into account - - PrimOpId op -> primOpOkForSpeculation op && args_ok + spec_ok (DataConWorkId _) args + = True -- The strictness of the constructor has already + -- been expressed by its "wrapper", so we don't need + -- to take the arguments into account + + spec_ok (PrimOpId op) args + | isDivOp op, -- Special case for dividing operations that fail + [arg1, Lit lit] <- args -- only if the divisor is zero + = not (isZeroLit lit) && exprOkForSpeculation arg1 + -- Often there is a literal divisor, and this + -- can get rid of a thunk in an inner looop + + | otherwise + = primOpOkForSpeculation op && + all exprOkForSpeculation args -- A bit conservative: we don't really need -- to care about lazy arguments, but this is easy - other -> False - - go (App f a) n_args args_ok - | isTypeArg a = go f n_args args_ok - | otherwise = go f (n_args + 1) (exprOkForSpeculation a && args_ok) - - go other n_args args_ok = False + spec_ok other args = False + +isDivOp :: PrimOp -> Bool +-- True of dyadic operators that can fail +-- only if the second arg is zero +-- This function probably belongs in PrimOp, or even in +-- an automagically generated file.. but it's such a +-- special case I thought I'd leave it here for now. +isDivOp IntQuotOp = True +isDivOp IntRemOp = True +isDivOp WordQuotOp = True +isDivOp WordRemOp = True +isDivOp IntegerQuotRemOp = True +isDivOp IntegerDivModOp = True +isDivOp FloatDivOp = True +isDivOp DoubleDivOp = True +isDivOp other = False \end{code} @@ -491,20 +543,23 @@ 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 +-- gaw 2004 + 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 idAppIsBottom :: Id -> Int -> Bool -idAppIsBottom id n_val_args = appIsBottom (idStrictness id) n_val_args +idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args \end{code} @exprIsValue@ returns true for expressions that are certainly *already* -evaluated to WHNF. This is used to decide wether it's ok to change +evaluated to *head* normal form. This is used to decide whether it's ok +to change + case x of _ -> e ===> e and to decide whether it's safe to discard a `seq` @@ -512,54 +567,111 @@ and to decide whether it's safe to discard a `seq` So, it does *not* treat variables as evaluated, unless they say they are. But it *does* treat partial applications and constructor applications -as values, even if their arguments are non-trivial; +as values, even if their arguments are non-trivial, provided the argument +type is lifted; e.g. (:) (f x) (map f xs) is a value map (...redex...) is a value Because `seq` on such things completes immediately -A worry: constructors with unboxed args: +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. +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 +type must be ok-for-speculation (or trivial). \begin{code} exprIsValue :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP -exprIsValue (Type ty) = True -- Types are honorary Values; we don't mind - -- copying them -exprIsValue (Lit l) = True -exprIsValue (Lam b e) = isId b || exprIsValue e -exprIsValue (Note _ e) = exprIsValue e -exprIsValue other_expr - = go other_expr 0 - where - go (Var f) n_args = idAppIsValue f n_args - - go (App f a) n_args - | isTypeArg a = go f n_args - | otherwise = go f (n_args + 1) - - go (Note _ f) n_args = go f n_args - - go other n_args = False - -idAppIsValue :: Id -> Int -> Bool -idAppIsValue id n_val_args - = case idFlavour id of - DataConId _ -> True - PrimOpId _ -> n_val_args < idArity id - other | n_val_args == 0 -> isEvaldUnfolding (idUnfolding id) - | otherwise -> n_val_args < idArity id +exprIsValue (Var v) -- NB: There are no value args at this point + = isDataConWorkId v -- Catches nullary constructors, + -- so that [] and () are values, for example + || idArity v > 0 -- Catches (e.g.) primops that don't have unfoldings + || isEvaldUnfolding (idUnfolding v) + -- Check the thing's unfolding; it might be bound to a value -- A worry: what if an Id's unfolding is just itself: -- then we could get an infinite loop... + +exprIsValue (Lit l) = True +exprIsValue (Type ty) = True -- Types are honorary Values; + -- we don't mind copying them +exprIsValue (Lam b e) = isRuntimeVar b || exprIsValue e +exprIsValue (Note _ e) = exprIsValue e +exprIsValue (App e (Type _)) = exprIsValue e +exprIsValue (App e a) = app_is_value e [a] +exprIsValue 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 \end{code} \begin{code} exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr]) -exprIsConApp_maybe expr - = analyse (collectArgs expr) +exprIsConApp_maybe (Note (Coerce to_ty from_ty) expr) + = -- Maybe this is over the top, but here we try to turn + -- coerce (S,T) ( x, y ) + -- effectively into + -- ( coerce S x, coerce T y ) + -- This happens in anger in PrelArrExts which has a coerce + -- case coerce memcpy a b of + -- (# r, s #) -> ... + -- where the memcpy is in the IO monad, but the call is in + -- the (ST s) monad + case exprIsConApp_maybe expr of { + Nothing -> Nothing ; + Just (dc, args) -> + + case splitTyConApp_maybe to_ty of { + Nothing -> Nothing ; + 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 + arity = tyConArity tc + val_args = drop arity args + to_arg_tys = dataConArgTys dc tc_arg_tys + mk_coerce ty arg = mkCoerce ty arg + new_val_args = zipWith mk_coerce to_arg_tys val_args + in + ASSERT( all isTypeArg (take arity args) ) + ASSERT( equalLength val_args to_arg_tys ) + Just (dc, map Type tc_arg_tys ++ new_val_args) + }} + +exprIsConApp_maybe (Note _ expr) + = exprIsConApp_maybe expr + -- We ignore InlineMe notes in case we have + -- x = __inline_me__ (a,b) + -- All part of making sure that INLINE pragmas never hurt + -- Marcin tripped on this one when making dictionaries more inlinable + -- + -- In fact, we ignore all notes. For example, + -- case _scc_ "foo" (C a b) of + -- C a b -> e + -- should be optimised away, but it will be only if we look + -- through the SCC note. + +exprIsConApp_maybe expr = analyse (collectArgs expr) where analyse (Var fun, args) - | Just con <- isDataConId_maybe fun, - length args >= dataConRepArity con + | Just con <- isDataConWorkId_maybe fun, + args `lengthAtLeast` dataConRepArity con -- Might be > because the arity excludes type args = Just (con,args) @@ -573,20 +685,6 @@ exprIsConApp_maybe expr analyse other = Nothing \end{code} -The arity of an expression (in the code-generator sense, i.e. the -number of lambdas at the beginning). - -\begin{code} -exprArity :: CoreExpr -> Int -exprArity (Lam x e) - | isTyVar x = exprArity e - | otherwise = 1 + exprArity e -exprArity (Note _ e) - -- Ignore coercions. Top level sccs are removed by the final - -- profiling pass, so we ignore those too. - = exprArity e -exprArity _ = 0 -\end{code} %************************************************************************ @@ -595,181 +693,301 @@ exprArity _ = 0 %* * %************************************************************************ -@etaReduce@ trys an eta reduction at the top level of a Core Expr. - -e.g. \ x y -> f x y ===> f - -But we only do this if it gets rid of a whole lambda, not part. -The idea is that lambdas are often quite helpful: they indicate -head normal forms, so we don't want to chuck them away lightly. - \begin{code} -etaReduce :: CoreExpr -> CoreExpr - -- ToDo: we should really check that we don't turn a non-bottom - -- lambda into a bottom variable. Sigh - -etaReduce expr@(Lam bndr body) - = check (reverse binders) body - where - (binders, body) = collectBinders expr - - check [] body - | not (any (`elemVarSet` body_fvs) binders) - = body -- Success! - where - body_fvs = exprFreeVars body - - check (b : bs) (App fun arg) - | (varToCoreExpr b `cheapEqExpr` arg) - = check bs fun - - check _ _ = expr -- Bale out - -etaReduce expr = expr -- The common case -\end{code} - - -\begin{code} -exprEtaExpandArity :: CoreExpr -> (Int, Bool) --- The Int is number of value args the thing can be --- applied to without doing much work --- The Bool is True iff there are enough explicit value lambdas --- at the top to make this arity apparent --- (but ignore it when arity==0) - --- 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 --- --- Consider 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 extra Bool returned by go1 --- 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 - -exprEtaExpandArity e - = go 0 e - where - go :: Int -> CoreExpr -> (Int,Bool) - go ar (Lam x e) | isId x = go (ar+1) e - | otherwise = go ar e - go ar (Note n e) | ok_note n = go ar e - go ar other = (ar + ar', ar' == 0) - where - ar' = length (go1 other) - - go1 :: CoreExpr -> [Bool] +exprEtaExpandArity :: CoreExpr -> Arity +{- 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) + +-- A limited sort of function type +data ArityType = AFun Bool ArityType -- True <=> one-shot + | ATop -- Know nothing + | ABot -- Diverges + +arityDepth :: ArityType -> Arity +arityDepth (AFun _ ty) = 1 + arityDepth ty +arityDepth ty = 0 + +andArityType ABot at2 = at2 +andArityType ATop at2 = ATop +andArityType (AFun t1 at1) (AFun t2 at2) = AFun (t1 && t2) (andArityType at1 at2) +andArityType at1 at2 = andArityType at2 at1 + +arityType :: CoreExpr -> ArityType -- (go1 e) = [b1,..,bn] -- means expression can be rewritten \x_b1 -> ... \x_bn -> body -- where bi is True <=> the lambda is one-shot - go1 (Note n e) | ok_note n = go1 e - go1 (Var v) = replicate (idArity v) False -- When the type of the Id - -- encodes one-shot-ness, use - -- th iinfo here +arityType (Note n e) = arityType e +-- Not needed any more: etaExpand is cleverer +-- | ok_note n = arityType e +-- | otherwise = ATop + +arityType (Var v) + = mk (idArity v) (arg_tys (idType v)) + where + 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 - go1 (Lam x e) | isId x = isOneShotLambda x : go1 e - | otherwise = go1 e +arityType (Lam x e) | isId x = AFun (isOneShotBndr x) (arityType e) + | otherwise = arityType e -- Applications; decrease arity - go1 (App f (Type _)) = go1 f - go1 (App f a) = case go1 f of - (one_shot : xs) | one_shot || exprIsCheap a -> xs - other -> [] +arityType (App f (Type _)) = arityType f +arityType (App f a) = case arityType f of + AFun one_shot xs | exprIsCheap a -> xs + other -> ATop -- Case/Let; keep arity if either the expression is cheap -- or it's a 1-shot lambda - go1 (Case scrut _ alts) = case foldr1 (zipWith (&&)) [go1 rhs | (_,_,rhs) <- alts] of - xs@(one_shot : _) | one_shot || exprIsCheap scrut -> xs - other -> [] - go1 (Let b e) = case go1 e of - xs@(one_shot : _) | one_shot || all exprIsCheap (rhssOfBind b) -> xs - other -> [] - - go1 other = [] - - ok_note (Coerce _ _) = True - ok_note InlineCall = True - ok_note other = False - -- Notice that we do not look through __inline_me__ - -- This one is a bit more surprising, but consider - -- f = _inline_me (\x -> e) - -- We DO NOT want to eta expand this to - -- f = \x -> (_inline_me (\x -> e)) x - -- because the _inline_me gets dropped now it is applied, - -- giving just - -- f = \x -> e - -- A Bad Idea - -min_zero :: [Int] -> Int -- Find the minimum, but zero is the smallest -min_zero (x:xs) = go x xs - where - go 0 xs = 0 -- Nothing beats zero - go min [] = min - go min (x:xs) | x < min = go x xs - | otherwise = go min xs - + -- 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' +-- gaw 2004 +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 + +arityType (Let b e) = case arityType e of + xs@(AFun one_shot _) | one_shot -> xs + xs | all exprIsCheap (rhssOfBind b) -> xs + | otherwise -> ATop + +arityType other = ATop + +{- NOT NEEDED ANY MORE: etaExpand is cleverer +ok_note InlineMe = False +ok_note other = True + -- Notice that we do not look through __inline_me__ + -- This may seem surprising, but consider + -- f = _inline_me (\x -> e) + -- We DO NOT want to eta expand this to + -- f = \x -> (_inline_me (\x -> e)) x + -- because the _inline_me gets dropped now it is applied, + -- giving just + -- f = \x -> e + -- A Bad Idea +-} \end{code} \begin{code} -etaExpand :: Int -- Add this number of value args - -> UniqSupply +etaExpand :: Arity -- Result should have this number of value args + -> [Unique] -> CoreExpr -> Type -- Expression and its type -> CoreExpr -- (etaExpand n us e ty) returns an expression with -- the same meaning as 'e', but with arity 'n'. - +-- -- Given e' = etaExpand n us e ty -- We should have -- ty = exprType e = exprType e' -- --- etaExpand deals with for-alls and coerces. For example: --- etaExpand 1 E --- where E :: forall a. T --- newtype T = MkT (A -> B) --- --- would return --- (/\b. coerce T (\y::A -> (coerce (A->B) (E b) y) - --- (case x of { I# x -> /\ a -> coerce T E) +-- Note that SCCs are not treated specially. If we have +-- etaExpand 2 (\x -> scc "foo" e) +-- = (\xy -> (scc "foo" e) y) +-- So the costs of evaluating 'e' (not 'e y') are attributed to "foo" etaExpand n us expr ty - | n == 0 -- Saturated, so nothing to do + | manifestArity expr >= n = expr -- The no-op case + | otherwise = eta_expand n us expr ty + where + +-- manifestArity sees how many leading value lambdas there are +manifestArity :: CoreExpr -> Arity +manifestArity (Lam v e) | isId v = 1 + manifestArity e + | otherwise = manifestArity e +manifestArity (Note _ e) = manifestArity e +manifestArity e = 0 + +-- etaExpand deals with for-alls. For example: +-- etaExpand 1 E +-- where E :: forall a. a -> a +-- would return +-- (/\b. \y::a -> E b y) +-- +-- It deals with coerces too, though they are now rare +-- so perhaps the extra code isn't worth it + +eta_expand n us expr ty + | n == 0 && + -- The ILX code generator requires eta expansion for type arguments + -- too, but alas the 'n' doesn't tell us how many of them there + -- may be. So we eagerly eta expand any big lambdas, and just + -- cross our fingers about possible loss of sharing in the ILX case. + -- The Right Thing is probably to make 'arity' include + -- type variables throughout the compiler. (ToDo.) + not (isForAllTy ty) + -- Saturated, so nothing to do = expr - | otherwise -- An unsaturated constructor or primop; eta expand it + -- Short cut for the case where there already + -- is a lambda; no point in gratuitously adding more +eta_expand n us (Lam v body) ty + | isTyVar v + = Lam v (eta_expand n us body (applyTy ty (mkTyVarTy v))) + + | otherwise + = Lam v (eta_expand (n-1) us body (funResultTy ty)) + +-- We used to have a special case that stepped inside Coerces here, +-- thus: eta_expand n us (Note note@(Coerce _ ty) e) _ +-- = Note note (eta_expand n us e ty) +-- BUT this led to an infinite loop +-- Example: newtype T = MkT (Int -> Int) +-- eta_expand 1 (coerce (Int->Int) e) +-- --> coerce (Int->Int) (eta_expand 1 T e) +-- by the bogus eqn +-- --> coerce (Int->Int) (coerce T +-- (\x::Int -> eta_expand 1 (coerce (Int->Int) e))) +-- by the splitNewType_maybe case below +-- and round we go + +eta_expand n us expr ty = case splitForAllTy_maybe ty of { - Just (tv,ty') -> Lam tv (etaExpand n us (App expr (Type (mkTyVarTy tv))) ty') + Just (tv,ty') -> Lam tv (eta_expand n us (App expr (Type (mkTyVarTy tv))) ty') ; Nothing -> case splitFunTy_maybe ty of { - Just (arg_ty, res_ty) -> Lam arg1 (etaExpand (n-1) us2 (App expr (Var arg1)) res_ty) + Just (arg_ty, res_ty) -> Lam arg1 (eta_expand (n-1) us2 (App expr (Var arg1)) res_ty) where - arg1 = mkSysLocal SLIT("eta") uniq arg_ty - (us1, us2) = splitUniqSupply us - uniq = uniqFromSupply us1 + arg1 = mkSysLocal FSLIT("eta") uniq arg_ty + (uniq:us2) = us - ; Nothing -> - - case splitNewType_maybe ty of { - Just ty' -> mkCoerce ty ty' (etaExpand n us (mkCoerce ty' ty expr) ty') ; - - Nothing -> pprTrace "Bad eta expand" (ppr expr $$ ppr ty) expr + ; Nothing -> + + -- Given this: + -- newtype T = MkT ([T] -> Int) + -- Consider eta-expanding this + -- eta_expand 1 e T + -- We want to get + -- coerce T (\x::[T] -> (coerce ([T]->Int) e) x) + -- Only try this for recursive newtypes; the non-recursive kind + -- are transparent anyway + + 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 n $$ ppr expr $$ ppr ty) expr }}} \end{code} +exprArity is a cheap-and-cheerful version of exprEtaExpandArity. +It tells how many things the expression can be applied to before doing +any work. It doesn't look inside cases, lets, etc. The idea is that +exprEtaExpandArity will do the hard work, leaving something that's easy +for exprArity to grapple with. In particular, Simplify uses exprArity to +compute the ArityInfo for the Id. + +Originally I thought that it was enough just to look for top-level lambdas, but +it isn't. I've seen this + + foo = PrelBase.timesInt + +We want foo to get arity 2 even though the eta-expander will leave it +unchanged, in the expectation that it'll be inlined. But occasionally it +isn't, because foo is blacklisted (used in a rule). + +Similarly, see the ok_note check in exprEtaExpandArity. So + f = __inline_me (\x -> e) +won't be eta-expanded. + +And in any case it seems more robust to have exprArity be a bit more intelligent. +But note that (\x y z -> f x y z) +should have arity 3, regardless of f's arity. + +\begin{code} +exprArity :: CoreExpr -> Arity +exprArity e = go e + where + go (Var v) = idArity v + go (Lam x e) | isId x = go e + 1 + | otherwise = go e + go (Note n e) = go e + go (App e (Type t)) = go e + go (App f a) | exprIsCheap a = (go f - 1) `max` 0 + -- NB: exprIsCheap a! + -- f (fac x) does not have arity 2, + -- even if f has arity 3! + -- NB: `max 0`! (\x y -> f x) has arity 2, even if f is + -- unknown, hence arity 0 + go _ = 0 +\end{code} %************************************************************************ %* * @@ -786,7 +1004,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 == t2 +cheapEqExpr (Type t1) (Type t2) = t1 `eqType` t2 cheapEqExpr (App f1 a1) (App f2 a2) = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2 @@ -806,6 +1024,9 @@ 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 where @@ -822,21 +1043,23 @@ eqExpr 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) = length ps1 == length ps2 && + (Let (Rec ps2) e2) = equalLength ps1 ps2 && and (zipWith eq_rhs ps1 ps2) && eq 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 && - length a1 == length a2 && +-- gaw 2004 + eq env (Case e1 v1 t1 a1) + (Case e2 v2 t2 a2) = eq env e1 e2 && + t1 `eqType` t2 && + equalLength a1 a2 && and (zipWith (eq_alt env') a1 a2) where env' = extendVarEnv 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 == t2 + eq env (Type t1) (Type t2) = t1 `eqType` t2 eq env e1 e2 = False eq_list env [] [] = True @@ -847,8 +1070,9 @@ eqExpr e1 e2 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==t2 && f1==f2 + eq_note env (Coerce t1 f1) (Coerce t2 f2) = t1 `eqType` t2 && f1 `eqType` f2 eq_note env InlineCall InlineCall = True + eq_note env (CoreNote s1) (CoreNote s2) = s1 == s2 eq_note env other1 other2 = False \end{code} @@ -866,19 +1090,21 @@ 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) = varSize v -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 +-- gaw 2004 +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 @@ -913,7 +1139,8 @@ 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 +-- gaw 2004 +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 @@ -930,3 +1157,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}