X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreUtils.lhs;h=28fb33508e9edf1eedfb260db807fd7570213aad;hb=6941708cc1d90f56fb99a9145502189d083371bb;hp=f873c74d567c40e1189cc8eaace9f1412f03f96e;hpb=e0d750bedbd33f7a133c8c82c35fd8db537ab649;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index f873c74..28fb335 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -6,9 +6,9 @@ \begin{code} module CoreUtils ( -- Construction - mkNote, mkInlineMe, mkSCC, mkCoerce, + mkNote, mkInlineMe, mkSCC, mkCoerce, mkCoerce2, bindNonRec, needsCaseBinding, - mkIfThenElse, mkAltExpr, mkPiType, + mkIfThenElse, mkAltExpr, mkPiType, mkPiTypes, -- Taking expressions apart findDefault, findAlt, hasDefault, @@ -17,13 +17,12 @@ module CoreUtils ( exprType, coreAltsType, exprIsBottom, exprIsDupable, exprIsTrivial, exprIsCheap, exprIsValue,exprOkForSpeculation, exprIsBig, - exprIsConApp_maybe, exprIsAtom, - idAppIsBottom, idAppIsCheap, - exprArity, + exprIsConApp_maybe, + hasNoRedexes, - -- Expr transformation - etaReduce, etaExpand, - exprArity, exprEtaExpandArity, + -- Arity and eta expansion + manifestArity, exprArity, + exprEtaExpandArity, etaExpand, -- Size coreBindsSize, @@ -32,36 +31,37 @@ 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, dataConArgTys, isExistentialDataCon, dataConTyCon ) -import PrimOp ( primOpOkForSpeculation, primOpIsCheap ) -import Id ( Id, idType, globalIdDetails, idNewStrictness, idLBVarInfo, - mkWildId, idArity, idName, idUnfolding, idInfo, isOneShotLambda, - isDataConId_maybe, mkSysLocal, hasNoBinding, isDataConId, isBottomingId +import Name ( hashName, isDllName ) +import Literal ( hashLiteral, literalType, litIsDupable, + litIsTrivial, isZeroLit, isLitLitLit ) +import DataCon ( DataCon, dataConRepArity, dataConArgTys, + isExistentialDataCon, dataConTyCon, dataConName ) +import PrimOp ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap ) +import Id ( Id, idType, globalIdDetails, idNewStrictness, + mkWildId, idArity, idName, idUnfolding, idInfo, + isOneShotLambda, isDataConWorkId_maybe, mkSysLocal, + isDataConWorkId, isBottomingId ) -import IdInfo ( LBVarInfo(..), - GlobalIdDetails(..), - megaSeqIdInfo ) +import IdInfo ( GlobalIdDetails(..), megaSeqIdInfo ) import NewDemand ( appIsBottom ) -import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe, splitFunTy, - applyTys, isUnLiftedType, seqType, mkUTy, mkTyVarTy, +import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe, + splitFunTy, + applyTys, isUnLiftedType, seqType, mkTyVarTy, splitForAllTy_maybe, isForAllTy, splitNewType_maybe, - splitTyConApp_maybe, eqType + splitTyConApp_maybe, eqType, funResultTy, applyTy, + funResultTy, applyTy ) import TyCon ( tyConArity ) import TysWiredIn ( boolTy, trueDataCon, falseDataCon ) @@ -70,6 +70,8 @@ import BasicTypes ( Arity ) import Unique ( Unique ) import Outputable import TysPrim ( alphaTy ) -- Debugging only +import Util ( equalLength, lengthAtLeast ) +import TysPrim ( statePrimTyCon ) \end{code} @@ -105,26 +107,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 @@ -144,7 +155,7 @@ mkNote removes redundant coercions, and SCCs where possible \begin{code} 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 @@ -185,13 +196,15 @@ mkInlineMe e = Note InlineMe e \begin{code} -mkCoerce :: Type -> Type -> CoreExpr -> CoreExpr +mkCoerce :: Type -> CoreExpr -> CoreExpr +mkCoerce to_ty expr = mkCoerce2 to_ty (exprType expr) expr -mkCoerce to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr) +mkCoerce2 :: Type -> Type -> CoreExpr -> CoreExpr +mkCoerce2 to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr) = ASSERT( from_ty `eqType` to_ty2 ) - mkCoerce to_ty from_ty2 expr + mkCoerce2 to_ty from_ty2 expr -mkCoerce to_ty from_ty 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 @@ -301,36 +314,25 @@ 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. + \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) = not (isRuntimeArg arg) && exprIsTrivial e -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 +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 _ e) = exprIsTrivial e +exprIsTrivial (Lam b body) = not (isRuntimeVar b) && exprIsTrivial body +exprIsTrivial other = False \end{code} @@ -436,10 +438,10 @@ idAppIsCheap id n_val_args -- a variable (f t1 t2 t3) -- counts as WHNF | otherwise = case globalIdDetails 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 + 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 @@ -477,28 +479,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 globalIdDetails 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 - | not (isRuntimeArg 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} @@ -544,33 +568,42 @@ 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) = isRuntimeVar b || exprIsValue e -exprIsValue (Note _ e) = exprIsValue e -exprIsValue (Var v) = idArity v > 0 || isEvaldUnfolding (idUnfolding v) - -- The idArity case catches data cons and primops that - -- don't have unfoldings +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 other_expr - | (Var fun, args) <- collectArgs other_expr, - isDataConId fun || valArgCount args < idArity fun - = check (idType fun) args - | otherwise - = False + +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 - -- 'check' checks that unlifted-type args are in - -- fact guaranteed non-divergent - check fun_ty [] = True - check fun_ty (Type _ : args) = case splitForAllTy_maybe fun_ty of - Just (_, ty) -> check ty args - check fun_ty (arg : args) - | isUnLiftedType arg_ty = exprOkForSpeculation arg - | otherwise = check res_ty args - where - (arg_ty, res_ty) = splitFunTy fun_ty + (arg_ty, res_ty) = splitFunTy fun_ty \end{code} \begin{code} @@ -600,11 +633,11 @@ exprIsConApp_maybe (Note (Coerce to_ty from_ty) expr) arity = tyConArity tc val_args = drop arity args to_arg_tys = dataConArgTys dc tc_arg_tys - mk_coerce ty arg = mkCoerce ty (exprType arg) arg + 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( length val_args == length to_arg_tys ) + ASSERT( equalLength val_args to_arg_tys ) Just (dc, map Type tc_arg_tys ++ new_val_args) }} @@ -624,8 +657,8 @@ exprIsConApp_maybe (Note _ expr) 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) @@ -647,89 +680,67 @@ exprIsConApp_maybe expr = analyse (collectArgs expr) %* * %************************************************************************ -@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 - --- 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 - - -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' = arityDepth (arityType other) +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.isOneShotLambda. + +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 @@ -750,9 +761,10 @@ arityType :: CoreExpr -> ArityType -- means expression can be rewritten \x_b1 -> ... \x_bn -> body -- where bi is True <=> the lambda is one-shot -arityType (Note n e) - | ok_note n = arityType e - | otherwise = ATop +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) @@ -766,14 +778,13 @@ arityType (Var v) -- use the idinfo here -- Lambdas; increase arity -arityType (Lam x e) | isId x = AFun (isOneShotLambda x) (arityType e) +arityType (Lam x e) | isId x = AFun (isOneShotLambda x || isStateHack x) (arityType e) | otherwise = arityType e -- Applications; decrease arity arityType (App f (Type _)) = arityType f arityType (App f a) = case arityType f of - AFun one_shot xs | one_shot -> xs - | exprIsCheap a -> xs + AFun one_shot xs | exprIsCheap a -> xs other -> ATop -- Case/Let; keep arity if either the expression is cheap @@ -790,6 +801,29 @@ 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 -- Notice that we do not look through __inline_me__ @@ -801,22 +835,39 @@ ok_note other = True -- giving just -- f = \x -> e -- A Bad Idea - +-} \end{code} \begin{code} -etaExpand :: Int -- Add this number of value args +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' -- +-- 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 + | 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 @@ -826,35 +877,63 @@ etaExpand :: Int -- Add this number of value args -- It deals with coerces too, though they are now rare -- so perhaps the extra code isn't worth it -etaExpand n us expr ty +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. + -- 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 + arg1 = mkSysLocal FSLIT("eta") uniq arg_ty (uniq:us2) = us ; Nothing -> + -- Given this: + -- newtype T = MkT (Int -> Int) + -- Consider eta-expanding this + -- eta_expand 1 e T + -- We want to get + -- coerce T (\x::Int -> (coerce (Int->Int) e) x) + case splitNewType_maybe ty of { - Just ty' -> mkCoerce ty ty' (etaExpand n us (mkCoerce ty' ty expr) ty') ; + Just ty' -> mkCoerce2 ty ty' (eta_expand n us (mkCoerce2 ty' ty expr) ty') ; Nothing -> pprTrace "Bad eta expand" (ppr expr $$ ppr ty) expr }}} \end{code} @@ -884,7 +963,7 @@ But note that (\x y z -> f x y z) should have arity 3, regardless of f's arity. \begin{code} -exprArity :: CoreExpr -> Int +exprArity :: CoreExpr -> Arity exprArity e = go e where go (Var v) = idArity v @@ -901,7 +980,6 @@ exprArity e = go e go _ = 0 \end{code} - %************************************************************************ %* * \subsection{Equality} @@ -956,7 +1034,7 @@ 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 @@ -964,7 +1042,7 @@ eqExpr e1 e2 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 && + equalLength a1 a2 && and (zipWith (eq_alt env') a1 a2) where env' = extendVarEnv env v1 v2 @@ -983,6 +1061,7 @@ eqExpr e1 e2 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 (CoreNote s1) (CoreNote s2) = s1 == s2 eq_note env other1 other2 = False \end{code} @@ -1000,7 +1079,7 @@ 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 (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 @@ -1013,6 +1092,7 @@ 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 @@ -1064,3 +1144,99 @@ 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 + a) the constructor, or any of the arguments, come from another DLL + b) any of the arguments are LitLits +(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} +hasNoRedexes :: CoreExpr -> Bool +-- This function is called only on *top-level* right-hand sides +-- Returns True if +-- the expression contains any redex that +-- is not under a (value) lambda +-- and +-- it contains no cross-DLL references +-- +-- The real reason: either +-- a) the rhs *is* a redex, in which case it's a CAF +-- (remember the arg is always a top-level rhs) +-- or b) the nested redex will ultimately be floated by CorePrep +-- and will be a CAF, so this rhs *refers* to a CAF +-- +-- 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. In case (ii), the ANF-ising of CorePrep means that +-- (b) cannot be the case, so it must be (a)! +-- +-- NB: 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 non-redexes +-- are saturated applications of constructors +-- +-- +-- 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). +-- +hasNoRedexes (Lam b e) = isRuntimeVar b || hasNoRedexes e +hasNoRedexes (Note (SCC _) e) = False +hasNoRedexes (Note _ e) = hasNoRedexes e +hasNoRedexes (Lit lit) = not (isLitLitLit lit) + -- lit-lit arguments cannot be used in static constructors either. + -- (litlits are deprecated, so I'm not going to bother cleaning up this infelicity --SDM). +hasNoRedexes other_expr = go other_expr 0 + where + go (Var f) n_val_args + | not (isDllName (idName f)) + = n_val_args == 0 || saturated_data_con f n_val_args + + go (App f a) n_val_args + | isTypeArg a = go f n_val_args + | hasNoRedexes a = go f (n_val_args + 1) + -- NB. args 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} + +