X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreUtils.lhs;h=5c26e0da780bba25a19ae73eb0c67395d0df04f6;hb=1cfc9faaa059b9b090971399e4eb8ae9d364335c;hp=b8ccb05c73671689fb002dfccc37b204713c210d;hpb=4a851c8281491a26ce130e6ce4496042e3feb42b;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index b8ccb05..5c26e0d 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -17,9 +17,8 @@ module CoreUtils ( exprType, coreAltsType, exprIsBottom, exprIsDupable, exprIsTrivial, exprIsCheap, exprIsValue,exprOkForSpeculation, exprIsBig, - exprIsConApp_maybe, exprIsAtom, - idAppIsBottom, idAppIsCheap, - + exprIsConApp_maybe, + rhsIsStatic, -- Arity and eta expansion manifestArity, exprArity, @@ -38,24 +37,27 @@ module CoreUtils ( #include "HsVersions.h" -import GlaExts -- For `xori` +import GLAEXTS -- For `xori` import CoreSyn import PprCore ( pprCoreExpr ) import Var ( Var, isId, isTyVar ) import VarEnv -import Name ( hashName ) -import Literal ( hashLiteral, literalType, litIsDupable, isZeroLit ) -import DataCon ( DataCon, dataConRepArity, dataConArgTys, isExistentialDataCon, dataConTyCon ) +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, - isDataConId_maybe, mkSysLocal, isDataConId, isBottomingId + mkWildId, idArity, idName, idUnfolding, idInfo, + isOneShotLambda, 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, applyTys, isUnLiftedType, seqType, mkTyVarTy, splitForAllTy_maybe, isForAllTy, splitNewType_maybe, splitTyConApp_maybe, eqType, funResultTy, applyTy, @@ -69,6 +71,7 @@ import Unique ( Unique ) import Outputable import TysPrim ( alphaTy ) -- Debugging only import Util ( equalLength, lengthAtLeast ) +import TysPrim ( statePrimTyCon ) \end{code} @@ -325,21 +328,11 @@ saturating them. \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 (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} @@ -445,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 @@ -495,7 +488,7 @@ exprOkForSpeculation other_expr other -> False where - spec_ok (DataConId _) args + 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 @@ -575,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} @@ -655,7 +657,7 @@ exprIsConApp_maybe (Note _ expr) exprIsConApp_maybe expr = analyse (collectArgs expr) where analyse (Var fun, args) - | Just con <- isDataConId_maybe fun, + | Just con <- isDataConWorkId_maybe fun, args `lengthAtLeast` dataConRepArity con -- Might be > because the arity excludes type args = Just (con,args) @@ -680,38 +682,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.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) @@ -752,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 @@ -776,6 +801,28 @@ 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 @@ -1014,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} @@ -1044,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 @@ -1095,3 +1144,127 @@ 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} +rhsIsStatic :: 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 rhs = is_static False rhs + +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) = 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). + +is_static in_arg other_expr = go other_expr 0 + where + go (Var f) n_val_args + | not (isDllName (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}