X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreUtils.lhs;h=e358be4439f67374964f37dc3aab1f4ab16ecfca;hb=76c0086f090327eecaf510de8bc4efc4dee996dc;hp=9ef454907bfb5e622f856750ffc46e1168778a20;hpb=d1675fe00e1972a0acf130b0e484ac83e908ff0a;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index 9ef4549..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, @@ -31,7 +31,7 @@ module CoreUtils ( hashExpr, -- Equality - cheapEqExpr, eqExpr, applyTypeToArgs, applyTypeToArg + cheapEqExpr, tcEqExpr, tcEqExprX, applyTypeToArgs, applyTypeToArg ) where #include "HsVersions.h" @@ -40,15 +40,19 @@ module CoreUtils ( import GLAEXTS -- For `xori` import CoreSyn +import CoreFVs ( exprFreeVars ) import PprCore ( pprCoreExpr ) -import Var ( Var, isId, isTyVar ) +import Var ( Var ) +import VarSet ( unionVarSet ) import VarEnv import Name ( hashName ) +import Packages ( HomeModules ) +#if mingw32_TARGET_OS import Packages ( isDllName ) -import CmdLineOpts ( DynFlags ) +#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, @@ -59,21 +63,19 @@ import Id ( Id, idType, globalIdDetails, idNewStrictness, import IdInfo ( GlobalIdDetails(..), megaSeqIdInfo ) import NewDemand ( appIsBottom ) import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe, - splitFunTy, + splitFunTy, tcEqTypeX, applyTys, isUnLiftedType, seqType, mkTyVarTy, splitForAllTy_maybe, isForAllTy, splitRecNewType_maybe, - splitTyConApp_maybe, eqType, funResultTy, applyTy, - funResultTy, applyTy + splitTyConApp_maybe, coreEqType, funResultTy, applyTy ) import TyCon ( tyConArity ) --- gaw 2004 import TysWiredIn ( boolTy, trueDataCon, falseDataCon ) import CostCentre ( CostCentre ) import BasicTypes ( Arity ) import Unique ( Unique ) import Outputable import TysPrim ( alphaTy ) -- Debugging only -import Util ( equalLength, lengthAtLeast ) +import Util ( equalLength, lengthAtLeast, foldl2 ) \end{code} @@ -89,9 +91,8 @@ exprType :: CoreExpr -> Type exprType (Var var) = idType var exprType (Lit lit) = literalType lit exprType (Let _ body) = exprType body --- gaw 2004 exprType (Case _ _ ty alts) = ty -exprType (Note (Coerce ty _) e) = ty -- **! should take usage from e +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) exprType e@(App _ _) @@ -206,12 +207,12 @@ mkCoerce to_ty expr = mkCoerce2 to_ty (exprType expr) expr mkCoerce2 :: Type -> Type -> CoreExpr -> CoreExpr mkCoerce2 to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr) - = ASSERT( from_ty `eqType` to_ty2 ) + = ASSERT( from_ty `coreEqType` to_ty2 ) mkCoerce2 to_ty from_ty2 expr mkCoerce2 to_ty from_ty expr - | to_ty `eqType` from_ty = expr - | otherwise = ASSERT( from_ty `eqType` exprType expr ) + | to_ty `coreEqType` from_ty = expr + | otherwise = ASSERT( from_ty `coreEqType` exprType expr ) Note (Coerce to_ty from_ty) expr \end{code} @@ -246,7 +247,6 @@ bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr -- deals with them perfectly well. bindNonRec bndr rhs body --- gaw 2004 | needsCaseBinding (idType bndr) rhs = Case rhs bndr (exprType body) [(DEFAULT,[],body)] | otherwise = Let (NonRec bndr rhs) body @@ -267,11 +267,10 @@ mkAltExpr (LitAlt lit) [] [] mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr mkIfThenElse guard then_expr else_expr --- 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) ] + [ (DataAlt falseDataCon, [], else_expr), -- Increasing order of tag! + (DataAlt trueDataCon, [], then_expr) ] \end{code} @@ -294,14 +293,19 @@ findAlt con alts = case alts of (deflt@(DEFAULT,_,_):alts) -> go alts deflt other -> go alts panic_deflt - where panic_deflt = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts)) - go [] deflt = deflt - go (alt@(con1,_,_) : alts) deflt | con == con1 = alt - | otherwise = ASSERT( not (con1 == DEFAULT) ) - go alts deflt + go [] deflt = deflt + go (alt@(con1,_,_) : alts) deflt + = case con `cmpAltCon` con1 of + LT -> deflt -- Missed it already; the alts are in increasing order + EQ -> alt + GT -> ASSERT( not (con1 == DEFAULT) ) go alts deflt + +isDefaultAlt :: CoreAlt -> Bool +isDefaultAlt (DEFAULT, _, _) = True +isDefaultAlt other = False \end{code} @@ -413,7 +417,6 @@ 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 @@ -449,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 @@ -545,18 +551,18 @@ exprIsBottom e = go 0 e -- n is the number of args 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 + go n (Type _) = False 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 @@ -580,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 @@ -590,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 @@ -645,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 @@ -750,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. -} @@ -817,7 +844,6 @@ arityType (App f a) = case arityType f of -- ===> -- 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 @@ -943,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} @@ -1004,7 +1036,7 @@ cheapEqExpr :: Expr b -> Expr b -> Bool cheapEqExpr (Var v1) (Var v2) = v1==v2 cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2 -cheapEqExpr (Type t1) (Type t2) = t1 `eqType` t2 +cheapEqExpr (Type t1) (Type t2) = t1 `coreEqType` t2 cheapEqExpr (App f1 a1) (App f2 a2) = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2 @@ -1022,57 +1054,49 @@ exprIsBig other = True \begin{code} -eqExpr :: CoreExpr -> CoreExpr -> Bool - -- Works ok at more general type, but only needed at CoreExpr - -- Used in rule matching, so when we find a type we use - -- eqTcType, which doesn't look through newtypes - -- [And it doesn't risk falling into a black hole either.] -eqExpr e1 e2 - = eq emptyVarEnv e1 e2 +tcEqExpr :: CoreExpr -> CoreExpr -> Bool +-- Used in rule matching, so does *not* look through +-- newtypes, predicate types; hence tcEqExpr + +tcEqExpr e1 e2 = tcEqExprX rn_env e1 e2 where - -- The "env" maps variables in e1 to variables in ty2 - -- So when comparing lambdas etc, - -- we in effect substitute v2 for v1 in e1 before continuing - eq env (Var v1) (Var v2) = case lookupVarEnv env v1 of - Just v1' -> v1' == v2 - Nothing -> v1 == v2 - - eq env (Lit lit1) (Lit lit2) = lit1 == lit2 - eq env (App f1 a1) (App f2 a2) = eq env f1 f2 && eq env a1 a2 - eq env (Lam v1 e1) (Lam v2 e2) = eq (extendVarEnv env v1 v2) e1 e2 - eq env (Let (NonRec v1 r1) e1) - (Let (NonRec v2 r2) e2) = eq env r1 r2 && eq (extendVarEnv env v1 v2) e1 e2 - eq env (Let (Rec ps1) e1) - (Let (Rec ps2) e2) = equalLength ps1 ps2 && - and (zipWith eq_rhs ps1 ps2) && - eq env' e1 e2 + rn_env = mkRnEnv2 (mkInScopeSet (exprFreeVars e1 `unionVarSet` exprFreeVars e2)) + +tcEqExprX :: RnEnv2 -> CoreExpr -> CoreExpr -> Bool +tcEqExprX env (Var v1) (Var v2) = rnOccL env v1 == rnOccR env v2 +tcEqExprX env (Lit lit1) (Lit lit2) = lit1 == lit2 +tcEqExprX env (App f1 a1) (App f2 a2) = tcEqExprX env f1 f2 && tcEqExprX env a1 a2 +tcEqExprX env (Lam v1 e1) (Lam v2 e2) = tcEqExprX (rnBndr2 env v1 v2) e1 e2 +tcEqExprX env (Let (NonRec v1 r1) e1) + (Let (NonRec v2 r2) e2) = tcEqExprX env r1 r2 + && tcEqExprX (rnBndr2 env v1 v2) e1 e2 +tcEqExprX env (Let (Rec ps1) e1) + (Let (Rec ps2) e2) = equalLength ps1 ps2 + && and (zipWith eq_rhs ps1 ps2) + && tcEqExprX env' e1 e2 where - env' = extendVarEnvList env [(v1,v2) | ((v1,_),(v2,_)) <- zip ps1 ps2] - eq_rhs (_,r1) (_,r2) = eq env' r1 r2 - eq env (Case e1 v1 t1 a1) - (Case e2 v2 t2 a2) = eq env e1 e2 && - t1 `eqType` t2 && - equalLength a1 a2 && - and (zipWith (eq_alt env') a1 a2) + env' = foldl2 rn_bndr2 env ps2 ps2 + rn_bndr2 env (b1,_) (b2,_) = rnBndr2 env b1 b2 + eq_rhs (_,r1) (_,r2) = tcEqExprX env' r1 r2 +tcEqExprX env (Case e1 v1 t1 a1) + (Case e2 v2 t2 a2) = tcEqExprX env e1 e2 + && tcEqTypeX env t1 t2 + && equalLength a1 a2 + && and (zipWith (eq_alt env') a1 a2) where - env' = extendVarEnv env v1 v2 + env' = rnBndr2 env v1 v2 - eq env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && eq env e1 e2 - eq env (Type t1) (Type t2) = t1 `eqType` t2 - eq env e1 e2 = False +tcEqExprX env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && tcEqExprX env e1 e2 +tcEqExprX env (Type t1) (Type t2) = tcEqTypeX env t1 t2 +tcEqExprX env e1 e2 = False - eq_list env [] [] = True - eq_list env (e1:es1) (e2:es2) = eq env e1 e2 && eq_list env es1 es2 - eq_list env es1 es2 = False - - eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 && - eq (extendVarEnvList env (vs1 `zip` vs2)) r1 r2 - - eq_note env (SCC cc1) (SCC cc2) = cc1 == cc2 - eq_note env (Coerce t1 f1) (Coerce t2 f2) = t1 `eqType` t2 && f1 `eqType` f2 - eq_note env InlineCall InlineCall = True - eq_note env (CoreNote s1) (CoreNote s2) = s1 == s2 - eq_note env other1 other2 = False +eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 && tcEqExprX (rnBndrs2 env vs1 vs2) r1 r2 + +eq_note env (SCC cc1) (SCC cc2) = cc1 == cc2 +eq_note env (Coerce t1 f1) (Coerce t2 f2) = tcEqTypeX env t1 t2 && tcEqTypeX env f1 f2 +eq_note env InlineCall InlineCall = True +eq_note env (CoreNote s1) (CoreNote s2) = s1 == s2 +eq_note env other1 other2 = False \end{code} @@ -1094,7 +1118,6 @@ 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 @@ -1138,7 +1161,6 @@ 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 --- 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 @@ -1172,7 +1194,7 @@ 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 +rhsIsStatic :: HomeModules -> 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. @@ -1188,6 +1210,8 @@ rhsIsStatic :: DynFlags -> CoreExpr -> Bool -- BUT watch out for -- (i) Any cross-DLL references kill static-ness completely -- because they must be 'executed' not statically allocated +-- ("DLL" here really only refers to Windows DLLs, on other platforms, +-- this is not necessary) -- -- (ii) We treat partial applications as redexes, because in fact we -- make a thunk for them that runs and builds a PAP @@ -1220,7 +1244,7 @@ rhsIsStatic :: DynFlags -> 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 @@ -1231,7 +1255,7 @@ rhsIsStatic :: DynFlags -> CoreExpr -> Bool -- 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 +rhsIsStatic hmods rhs = is_static False rhs where is_static :: Bool -- True <=> in a constructor argument; must be atomic -> CoreExpr -> Bool @@ -1257,7 +1281,9 @@ rhsIsStatic dflags rhs = is_static False rhs is_static in_arg other_expr = go other_expr 0 where go (Var f) n_val_args - | not (isDllName dflags (idName f)) +#if mingw32_TARGET_OS + | not (isDllName hmods (idName f)) +#endif = saturated_data_con f n_val_args || (in_arg && n_val_args == 0) -- A naked un-applied variable is *not* deemed a static RHS