X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2FcoreSyn%2FCoreUtils.lhs;h=e358be4439f67374964f37dc3aab1f4ab16ecfca;hb=2d4b82a0a94edeaedd9d0c4b3f023ac8d1d59766;hp=d4948aa706808004585012ac62642e5c28d9a046;hpb=b9a1ac0970ebff0832746d1b689855bfa42db241;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index d4948aa..e358be4 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -11,12 +11,12 @@ module CoreUtils ( mkIfThenElse, mkAltExpr, mkPiType, mkPiTypes, -- Taking expressions apart - findDefault, findAlt, + findDefault, findAlt, isDefaultAlt, -- Properties of expressions exprType, coreAltType, exprIsDupable, exprIsTrivial, exprIsCheap, - exprIsValue,exprOkForSpeculation, exprIsBig, + exprIsHNF,exprOkForSpeculation, exprIsBig, exprIsConApp_maybe, exprIsBottom, rhsIsStatic, @@ -46,10 +46,13 @@ import Var ( Var ) import VarSet ( unionVarSet ) import VarEnv import Name ( hashName ) -import Packages ( isDllName, HomeModules ) +import Packages ( HomeModules ) +#if mingw32_TARGET_OS +import Packages ( isDllName ) +#endif import Literal ( hashLiteral, literalType, litIsDupable, litIsTrivial, isZeroLit, Literal( MachLabel ) ) -import DataCon ( DataCon, dataConRepArity, dataConArgTys, +import DataCon ( DataCon, dataConRepArity, dataConInstArgTys, isVanillaDataCon, dataConTyCon ) import PrimOp ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap ) import Id ( Id, idType, globalIdDetails, idNewStrictness, @@ -66,7 +69,6 @@ import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe, splitTyConApp_maybe, coreEqType, funResultTy, applyTy ) import TyCon ( tyConArity ) --- gaw 2004 import TysWiredIn ( boolTy, trueDataCon, falseDataCon ) import CostCentre ( CostCentre ) import BasicTypes ( Arity ) @@ -300,6 +302,10 @@ findAlt con alts LT -> deflt -- Missed it already; the alts are in increasing order EQ -> alt GT -> ASSERT( not (con1 == DEFAULT) ) go alts deflt + +isDefaultAlt :: CoreAlt -> Bool +isDefaultAlt (DEFAULT, _, _) = True +isDefaultAlt other = False \end{code} @@ -446,17 +452,20 @@ 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 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 - -- might be applied to something, but I'm not going - -- to bother to check the number of args - other -> n_val_args < idArity id + | otherwise + = case globalIdDetails id of + DataConWorkId _ -> True + RecordSelId {} -> n_val_args == 1 -- I'm experimenting with making record selection + ClassOpId _ -> n_val_args == 1 -- look cheap, so we will substitute it inside a + -- lambda. Particularly for dictionary field selection. + -- BUT: Take care with (sel d x)! The (sel d) might be cheap, but + -- there's no guarantee that (sel d x) will be too. Hence (n_val_args == 1) + + PrimOpId op -> primOpIsCheap op -- In principle we should worry about primops + -- that return a type variable, since the result + -- might be applied to something, but I'm not going + -- to bother to check the number of args + other -> n_val_args < idArity id \end{code} exprOkForSpeculation returns True of an expression that it is @@ -553,7 +562,7 @@ idAppIsBottom :: Id -> Int -> Bool idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args \end{code} -@exprIsValue@ returns true for expressions that are certainly *already* +@exprIsHNF@ returns true for expressions that are certainly *already* evaluated to *head* normal form. This is used to decide whether it's ok to change @@ -577,8 +586,8 @@ 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 (Var v) -- NB: There are no value args at this point +exprIsHNF :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP +exprIsHNF (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 @@ -587,14 +596,14 @@ exprIsValue (Var v) -- NB: There are no value args at this point -- 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; +exprIsHNF (Lit l) = True +exprIsHNF (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 +exprIsHNF (Lam b e) = isRuntimeVar b || exprIsHNF e +exprIsHNF (Note _ e) = exprIsHNF e +exprIsHNF (App e (Type _)) = exprIsHNF e +exprIsHNF (App e a) = app_is_value e [a] +exprIsHNF other = False -- There is at least one value argument app_is_value (Var fun) args @@ -642,7 +651,7 @@ exprIsConApp_maybe (Note (Coerce to_ty from_ty) expr) let arity = tyConArity tc val_args = drop arity args - to_arg_tys = dataConArgTys dc tc_arg_tys + to_arg_tys = dataConInstArgTys dc tc_arg_tys mk_coerce ty arg = mkCoerce ty arg new_val_args = zipWith mk_coerce to_arg_tys val_args in @@ -747,6 +756,27 @@ consider 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. + + +4. Newtypes + +Non-recursive newtypes are transparent, and should not get in the way. +We do (currently) eta-expand recursive newtypes too. So if we have, say + + newtype T = MkT ([T] -> Int) + +Suppose we have + e = coerce T f +where f has arity 1. Then: etaExpandArity e = 1; +that is, etaExpandArity looks through the coerce. + +When we eta-expand e to arity 1: eta_expand 1 e T +we want to get: coerce T (\x::[T] -> (coerce ([T]->Int) e) x) + +HOWEVER, note that if you use coerce bogusly you can ge + coerce Int negate +And since negate has arity 2, you might try to eta expand. But you can't +decopose Int to a function type. Hence the final case in eta_expand. -} @@ -939,7 +969,13 @@ eta_expand n us expr ty 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 + Nothing -> + + -- We have an expression of arity > 0, but its type isn't a function + -- This *can* legitmately happen: e.g. coerce Int (\x. x) + -- Essentially the programmer is playing fast and loose with types + -- (Happy does this a lot). So we simply decline to eta-expand. + expr }}} \end{code} @@ -1208,7 +1244,7 @@ rhsIsStatic :: HomeModules -> CoreExpr -> Bool -- t = /\a. (:) (case w a of ...) (Nil a) FALSE (redex) -- -- --- This is a bit like CoreUtils.exprIsValue, with the following differences: +-- This is a bit like CoreUtils.exprIsHNF, 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