X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreUtils.lhs;h=19a44dc8273be40d477a49228fe3ad06aab6493a;hp=6aa65838a4b490b48ece40b7882868795505f3d3;hb=6fcf90065dc4e75b7dc6bbf238a9891a71ae5a86;hpb=182ce7e265699c9fd326f59d29767923100a2d16 diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index 6aa6583..19a44dc 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -6,7 +6,7 @@ \begin{code} module CoreUtils ( -- Construction - mkInlineMe, mkSCC, mkCoerce, mkCoerce2, + mkInlineMe, mkSCC, mkCoerce, bindNonRec, needsCaseBinding, mkIfThenElse, mkAltExpr, mkPiType, mkPiTypes, @@ -42,23 +42,23 @@ import GLAEXTS -- For `xori` import CoreSyn import CoreFVs ( exprFreeVars ) import PprCore ( pprCoreExpr ) -import Var ( Var ) +import Var ( Var, TyVar, isCoVar, tyVarKind ) import VarSet ( unionVarSet ) import VarEnv import Name ( hashName ) -import Packages ( HomeModules ) #if mingw32_TARGET_OS import Packages ( isDllName ) #endif import Literal ( hashLiteral, literalType, litIsDupable, litIsTrivial, isZeroLit, Literal( MachLabel ) ) -import DataCon ( DataCon, dataConRepArity, dataConInstArgTys, - isVanillaDataCon, dataConTyCon ) +import DataCon ( DataCon, dataConRepArity, + isVanillaDataCon, dataConTyCon, dataConRepArgTys, + dataConUnivTyVars, dataConExTyVars ) import PrimOp ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap ) import Id ( Id, idType, globalIdDetails, idNewStrictness, mkWildId, idArity, idName, idUnfolding, idInfo, isOneShotBndr, isStateHackType, isDataConWorkId_maybe, mkSysLocal, - isDataConWorkId, isBottomingId + isDataConWorkId, isBottomingId, isDictId ) import IdInfo ( GlobalIdDetails(..), megaSeqIdInfo ) import NewDemand ( appIsBottom ) @@ -66,14 +66,21 @@ import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe, splitFunTy, tcEqTypeX, applyTys, isUnLiftedType, seqType, mkTyVarTy, splitForAllTy_maybe, isForAllTy, splitRecNewType_maybe, - splitTyConApp_maybe, coreEqType, funResultTy, applyTy + splitTyConApp_maybe, coreEqType, funResultTy, applyTy, + substTyWith ) +import Coercion ( Coercion, mkTransCoercion, coercionKind, + splitNewTypeRepCo_maybe, mkSymCoercion, mkLeftCoercion, + mkRightCoercion, decomposeCo, coercionKindTyConApp, + splitCoercionKind ) import TyCon ( tyConArity ) import TysWiredIn ( boolTy, trueDataCon, falseDataCon ) import CostCentre ( CostCentre ) import BasicTypes ( Arity ) +import PackageConfig ( PackageId ) import Unique ( Unique ) import Outputable +import DynFlags ( DynFlags, DynFlag(Opt_DictsCheap), dopt ) import TysPrim ( alphaTy ) -- Debugging only import Util ( equalLength, lengthAtLeast, foldl2 ) \end{code} @@ -92,7 +99,8 @@ exprType (Var var) = idType var exprType (Lit lit) = literalType lit exprType (Let _ body) = exprType body exprType (Case _ _ ty alts) = ty -exprType (Note (Coerce ty _) e) = ty -- **! should take usage from e +exprType (Cast e co) + = let (_, ty) = coercionKind co in ty exprType (Note other_note e) = exprType e exprType (Lam binder expr) = mkPiType binder (exprType expr) exprType e@(App _ _) @@ -144,7 +152,7 @@ applyTypeToArgs e op_ty (Type ty : args) applyTypeToArgs e op_ty (other_arg : args) = case (splitFunTy_maybe op_ty) of Just (_, res_ty) -> applyTypeToArgs e res_ty args - Nothing -> pprPanic "applyTypeToArgs" (pprCoreExpr e) + Nothing -> pprPanic "applyTypeToArgs" (pprCoreExpr e $$ ppr op_ty) \end{code} @@ -160,7 +168,6 @@ mkNote removes redundant coercions, and SCCs where possible \begin{code} #ifdef UNUSED mkNote :: Note -> CoreExpr -> CoreExpr -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 @@ -196,18 +203,20 @@ mkInlineMe e = Note InlineMe e \begin{code} -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 `coreEqType` to_ty2 ) - mkCoerce2 to_ty from_ty2 expr - -mkCoerce2 to_ty from_ty expr - | to_ty `coreEqType` from_ty = expr - | otherwise = ASSERT( from_ty `coreEqType` exprType expr ) - Note (Coerce to_ty from_ty) expr +mkCoerce :: Coercion -> CoreExpr -> CoreExpr +mkCoerce co (Cast expr co2) + = ASSERT(let { (from_ty, to_ty) = coercionKind co; + (from_ty2, to_ty2) = coercionKind co2} in + from_ty `coreEqType` to_ty2 ) + mkCoerce (mkTransCoercion co2 co) expr + +mkCoerce co expr + = let (from_ty, to_ty) = coercionKind co in +-- if to_ty `coreEqType` from_ty +-- then expr +-- else + ASSERT2(from_ty `coreEqType` (exprType expr), text "Trying to coerce" <+> text "(" <> ppr expr $$ text "::" <+> ppr (exprType expr) <> text ")" $$ ppr co $$ ppr (coercionKindTyConApp co)) + (Cast expr co) \end{code} \begin{code} @@ -218,6 +227,7 @@ 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 (Cast e co) = Cast (mkSCC cc e) co -- Move _scc_ inside cast mkSCC cc expr = Note (SCC cc) expr \end{code} @@ -255,7 +265,7 @@ mkAltExpr :: AltCon -> [CoreBndr] -> [Type] -> CoreExpr -- This guy constructs the value that the scrutinee must have -- when you are in one particular branch of a case mkAltExpr (DataAlt con) args inst_tys - = mkConApp con (map Type inst_tys ++ map varToCoreExpr args) + = mkConApp con (map Type inst_tys ++ varsToCoreExprs args) mkAltExpr (LitAlt lit) [] [] = Lit lit @@ -352,6 +362,7 @@ 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 (Cast e co) = exprIsTrivial e exprIsTrivial (Lam b body) = not (isRuntimeVar b) && exprIsTrivial body exprIsTrivial other = False \end{code} @@ -374,6 +385,7 @@ exprIsDupable (Var v) = True exprIsDupable (Lit lit) = litIsDupable lit exprIsDupable (Note InlineMe e) = True exprIsDupable (Note _ e) = exprIsDupable e +exprIsDupable (Cast e co) = exprIsDupable e exprIsDupable expr = go expr 0 where @@ -417,14 +429,15 @@ 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 InlineMe e) = True -exprIsCheap (Note _ e) = exprIsCheap e -exprIsCheap (Lam x e) = isRuntimeVar x || exprIsCheap e -exprIsCheap (Case e _ _ alts) = exprIsCheap e && - and [exprIsCheap rhs | (_,_,rhs) <- alts] +exprIsCheap (Lit lit) = True +exprIsCheap (Type _) = True +exprIsCheap (Var _) = True +exprIsCheap (Note InlineMe e) = True +exprIsCheap (Note _ e) = exprIsCheap e +exprIsCheap (Cast e co) = exprIsCheap e +exprIsCheap (Lam x e) = isRuntimeVar x || exprIsCheap e +exprIsCheap (Case e _ _ alts) = exprIsCheap e && + and [exprIsCheap rhs | (_,_,rhs) <- alts] -- Experimentally, treat (case x of ...) as cheap -- (and case __coerce x etc.) -- This improves arities of overloaded functions where @@ -432,46 +445,54 @@ exprIsCheap (Case e _ _ alts) = exprIsCheap e && exprIsCheap (Let (NonRec x _) e) | isUnLiftedType (idType x) = exprIsCheap e | otherwise = False - -- strict lets always have cheap right hand sides, and - -- do no allocation. + -- strict lets always have cheap right hand sides, + -- and do no allocation. -exprIsCheap other_expr - = go other_expr 0 True +exprIsCheap other_expr -- Applications and variables + = go other_expr [] where - go (Var f) n_args args_cheap - = (idAppIsCheap f n_args && args_cheap) - -- A constructor, cheap primop, or partial application - - || idAppIsBottom f n_args + -- Accumulate value arguments, then decide + go (App f a) val_args | isRuntimeArg a = go f (a:val_args) + | otherwise = go f val_args + + go (Var f) [] = True -- Just a type application of a variable + -- (f t1 t2 t3) counts as WHNF + go (Var f) args + = case globalIdDetails f of + RecordSelId {} -> go_sel args + ClassOpId _ -> go_sel args + PrimOpId op -> go_primop op args + + DataConWorkId _ -> go_pap args + other | length args < idArity f -> go_pap args + + other -> isBottomingId f -- Application of a function which -- always gives bottom; we treat this as cheap -- because it certainly doesn't need to be shared! - go (App f a) n_args 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 - -idAppIsCheap :: Id -> Int -> Bool -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 {} -> 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 + go other args = False + + -------------- + go_pap args = all exprIsTrivial args + -- For constructor applications and primops, check that all + -- the args are trivial. We don't want to treat as cheap, say, + -- (1:2:3:4:5:[]) + -- We'll put up with one constructor application, but not dozens + + -------------- + go_primop op args = primOpIsCheap op && all exprIsCheap args + -- 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 + + -------------- + go_sel [arg] = exprIsCheap arg -- I'm experimenting with making record selection + go_sel other = False -- 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) \end{code} exprOkForSpeculation returns True of an expression that it is @@ -488,6 +509,8 @@ It returns True iff without raising an exception, without causing a side effect (e.g. writing a mutable variable) +NB: if exprIsHNF e, then exprOkForSpecuation e + E.G. let x = case y# +# 1# of { r# -> I# r# } in E @@ -502,10 +525,11 @@ 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 (Lit _) = True +exprOkForSpeculation (Type _) = True +exprOkForSpeculation (Var v) = isUnLiftedType (idType v) +exprOkForSpeculation (Note _ e) = exprOkForSpeculation e +exprOkForSpeculation (Cast e co) = exprOkForSpeculation e exprOkForSpeculation other_expr = case collectArgs other_expr of (Var f, args) -> spec_ok (globalIdDetails f) args @@ -556,6 +580,7 @@ exprIsBottom e = go 0 e where -- n is the number of args go n (Note _ e) = go n e + go n (Cast e co) = 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 @@ -607,13 +632,14 @@ exprIsHNF (Type ty) = True -- Types are honorary Values; -- we don't mind copying them exprIsHNF (Lam b e) = isRuntimeVar b || exprIsHNF e exprIsHNF (Note _ e) = exprIsHNF e +exprIsHNF (Cast e co) = 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 - | isDataConWorkId fun -- Constructor apps are values + | 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) @@ -632,8 +658,27 @@ check_args fun_ty (arg : args) \end{code} \begin{code} +-- deep applies a TyConApp coercion as a substitution to a reflexive coercion +-- deepCast t [a1,...,an] co corresponds to deep(t, [a1,...,an], co) from +-- FC paper +deepCast :: Type -> [TyVar] -> Coercion -> Coercion +deepCast ty tyVars co + = ASSERT( let {(lty, rty) = coercionKind co; + Just (tc1, lArgs) = splitTyConApp_maybe lty; + Just (tc2, rArgs) = splitTyConApp_maybe rty} + in + tc1 == tc2 && length lArgs == length rArgs && + length lArgs == length tyVars ) + substTyWith tyVars coArgs ty + where + -- coArgs = [right (left (left co)), right (left co), right co] + coArgs = decomposeCo (length tyVars) co + exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr]) -exprIsConApp_maybe (Note (Coerce to_ty from_ty) expr) +-- Returns (Just (dc, [x1..xn])) if the argument expression is +-- a constructor application of the form (dc x1 .. xn) + +exprIsConApp_maybe (Cast expr co) = -- Maybe this is over the top, but here we try to turn -- coerce (S,T) ( x, y ) -- effectively into @@ -646,25 +691,59 @@ exprIsConApp_maybe (Note (Coerce to_ty from_ty) expr) case exprIsConApp_maybe expr of { Nothing -> Nothing ; Just (dc, args) -> + + let (from_ty, to_ty) = coercionKind co in case splitTyConApp_maybe to_ty of { Nothing -> Nothing ; Just (tc, tc_arg_tys) | tc /= dataConTyCon dc -> Nothing - | not (isVanillaDataCon dc) -> Nothing + -- | not (isVanillaDataCon dc) -> Nothing | otherwise -> - -- Type constructor must match - -- We knock out existentials to keep matters simple(r) + -- Type constructor must match datacon + + case splitTyConApp_maybe from_ty of { + Nothing -> Nothing ; + Just (tc', tc_arg_tys') | tc /= tc' -> Nothing + -- Both sides of coercion must have the same type constructor + | otherwise -> + let - arity = tyConArity tc - val_args = drop arity args - 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 + -- here we do the PushC reduction rule as described in the FC paper + arity = tyConArity tc + n_ex_tvs = length dc_ex_tyvars + + (univ_args, rest) = splitAt arity args + (ex_args, val_args) = splitAt n_ex_tvs rest + + arg_tys = dataConRepArgTys dc + dc_tyvars = dataConUnivTyVars dc + dc_ex_tyvars = dataConExTyVars dc + + deep arg_ty = deepCast arg_ty dc_tyvars co + + -- first we appropriately cast the value arguments + arg_cos = map deep arg_tys + new_val_args = zipWith mkCoerce (map deep arg_tys) val_args + + -- then we cast the existential coercion arguments + orig_tvs = dc_tyvars ++ dc_ex_tyvars + gammas = decomposeCo arity co + new_tys = gammas ++ (map (\ (Type t) -> t) ex_args) + theta = substTyWith orig_tvs new_tys + cast_ty tv (Type ty) + | isCoVar tv + , (ty1, ty2) <- splitCoercionKind (tyVarKind tv) + = Type $ mkTransCoercion (mkSymCoercion (theta ty1)) + (mkTransCoercion ty (theta ty2)) + | otherwise + = Type ty + new_ex_args = zipWith cast_ty dc_ex_tyvars ex_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) - }} + ASSERT( equalLength val_args arg_tys ) + Just (dc, map Type tc_arg_tys ++ new_ex_args ++ new_val_args) + }}} exprIsConApp_maybe (Note _ expr) = exprIsConApp_maybe expr @@ -706,7 +785,7 @@ exprIsConApp_maybe expr = analyse (collectArgs expr) %************************************************************************ \begin{code} -exprEtaExpandArity :: CoreExpr -> Arity +exprEtaExpandArity :: DynFlags -> CoreExpr -> Arity {- The Arity returned is the number of value args the thing can be applied to without doing much work @@ -786,7 +865,7 @@ decopose Int to a function type. Hence the final case in eta_expand. -} -exprEtaExpandArity e = arityDepth (arityType e) +exprEtaExpandArity dflags e = arityDepth (arityType dflags e) -- A limited sort of function type data ArityType = AFun Bool ArityType -- True <=> one-shot @@ -802,17 +881,19 @@ 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 +arityType :: DynFlags -> 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 -arityType (Note n e) = arityType e +arityType dflags (Note n e) = arityType dflags e -- Not needed any more: etaExpand is cleverer --- | ok_note n = arityType e +-- | ok_note n = arityType dflags e -- | otherwise = ATop -arityType (Var v) +arityType dflags (Cast e co) = arityType dflags e + +arityType dflags (Var v) = mk (idArity v) (arg_tys (idType v)) where mk :: Arity -> [Type] -> ArityType @@ -835,14 +916,15 @@ arityType (Var v) | otherwise = [] -- Lambdas; increase arity -arityType (Lam x e) | isId x = AFun (isOneShotBndr x) (arityType e) - | otherwise = arityType e +arityType dflags (Lam x e) + | isId x = AFun (isOneShotBndr x) (arityType dflags e) + | otherwise = arityType dflags e -- Applications; decrease arity -arityType (App f (Type _)) = arityType f -arityType (App f a) = case arityType f of - AFun one_shot xs | exprIsCheap a -> xs - other -> ATop +arityType dflags (App f (Type _)) = arityType dflags f +arityType dflags (App f a) = case arityType dflags 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 @@ -851,17 +933,40 @@ arityType (App f a) = case arityType f of -- ===> -- f x y = case x of { (a,b) -> e } -- The difference is observable using 'seq' -arityType (Case scrut _ _ alts) = case foldr1 andArityType [arityType rhs | (_,_,rhs) <- alts] of - xs | exprIsCheap scrut -> xs - xs@(AFun one_shot _) | one_shot -> AFun True ATop - other -> ATop - -arityType (Let b e) = case arityType e of - xs | all exprIsCheap (rhssOfBind b) -> xs - xs@(AFun one_shot _) | one_shot -> AFun True ATop - other -> ATop - -arityType other = ATop +arityType dflags (Case scrut _ _ alts) + = case foldr1 andArityType [arityType dflags rhs | (_,_,rhs) <- alts] of + xs | exprIsCheap scrut -> xs + xs@(AFun one_shot _) | one_shot -> AFun True ATop + other -> ATop + +arityType dflags (Let b e) + = case arityType dflags e of + xs | cheap_bind b -> xs + xs@(AFun one_shot _) | one_shot -> AFun True ATop + other -> ATop + where + cheap_bind (NonRec b e) = is_cheap (b,e) + cheap_bind (Rec prs) = all is_cheap prs + is_cheap (b,e) = (dopt Opt_DictsCheap dflags && isDictId b) + || exprIsCheap e + -- If the experimental -fdicts-cheap flag is on, we eta-expand through + -- dictionary bindings. This improves arities. Thereby, it also + -- means that full laziness is less prone to floating out the + -- application of a function to its dictionary arguments, which + -- can thereby lose opportunities for fusion. Example: + -- foo :: Ord a => a -> ... + -- foo = /\a \(d:Ord a). let d' = ...d... in \(x:a). .... + -- -- So foo has arity 1 + -- + -- f = \x. foo dInt $ bar x + -- + -- The (foo DInt) is floated out, and makes ineffective a RULE + -- foo (bar x) = ... + -- + -- One could go further and make exprIsCheap reply True to any + -- dictionary-typed expression, but that's more work. + +arityType dflags other = ATop {- NOT NEEDED ANY MORE: etaExpand is cleverer ok_note InlineMe = False @@ -898,7 +1003,8 @@ etaExpand :: Arity -- Result should have this number of value args etaExpand n us expr ty | manifestArity expr >= n = expr -- The no-op case - | otherwise = eta_expand n us expr ty + | otherwise + = eta_expand n us expr ty where -- manifestArity sees how many leading value lambdas there are @@ -906,6 +1012,7 @@ manifestArity :: CoreExpr -> Arity manifestArity (Lam v e) | isId v = 1 + manifestArity e | otherwise = manifestArity e manifestArity (Note _ e) = manifestArity e +manifestArity (Cast e _) = manifestArity e manifestArity e = 0 -- etaExpand deals with for-alls. For example: @@ -952,7 +1059,8 @@ eta_expand n us (Lam v body) ty -- and round we go eta_expand n us expr ty - = case splitForAllTy_maybe ty of { + = ASSERT2 (exprType expr `coreEqType` ty, ppr (exprType expr) $$ ppr ty) + case splitForAllTy_maybe ty of { Just (tv,ty') -> Lam tv (eta_expand n us (App expr (Type (mkTyVarTy tv))) ty') ; Nothing -> @@ -971,11 +1079,10 @@ eta_expand n us expr ty -- 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') ; + case splitNewTypeRepCo_maybe ty of { + Just(ty1,co) -> + mkCoerce co (eta_expand n us (mkCoerce (mkSymCoercion co) expr) ty1) ; Nothing -> -- We have an expression of arity > 0, but its type isn't a function @@ -1018,6 +1125,7 @@ exprArity e = go e go (Lam x e) | isId x = go e + 1 | otherwise = go e go (Note n e) = go e + go (Cast e _) = go e go (App e (Type t)) = go e go (App f a) | exprIsCheap a = (go f - 1) `max` 0 -- NB: exprIsCheap a! @@ -1094,13 +1202,13 @@ tcEqExprX env (Case e1 v1 t1 a1) env' = rnBndr2 env v1 v2 tcEqExprX env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && tcEqExprX env e1 e2 +tcEqExprX env (Cast e1 co1) (Cast e2 co2) = tcEqTypeX env co1 co2 && tcEqExprX env e1 e2 tcEqExprX env (Type t1) (Type t2) = tcEqTypeX env t1 t2 tcEqExprX env e1 e2 = 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 (CoreNote s1) (CoreNote s2) = s1 == s2 eq_note env other1 other2 = False \end{code} @@ -1125,11 +1233,11 @@ 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 t as) = seqType t `seq` exprSize e + varSize b + 1 + foldr ((+) . altSize) 0 as +exprSize (Cast e co) = (seqType co `seq` 1) + exprSize e 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 InlineMe = 1 noteSize (CoreNote s) = s `seq` 1 -- hdaume: core annotations @@ -1158,12 +1266,21 @@ altSize (c,bs,e) = c `seq` varsSize bs + exprSize e \begin{code} hashExpr :: CoreExpr -> Int +-- Two expressions that hash to the same Int may be equal (but may not be) +-- Two expressions that hash to the different Ints are definitely unequal +-- +-- But "unequal" here means "not identical"; two alpha-equivalent +-- expressions may hash to the different Ints +-- +-- The emphasis is on a crude, fast hash, rather than on high precision + hashExpr e | hash < 0 = 77 -- Just in case we hit -maxInt | otherwise = hash where hash = abs (hash_expr e) -- Negative numbers kill UniqFM hash_expr (Note _ e) = hash_expr e +hash_expr (Cast e co) = 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 @@ -1199,7 +1316,7 @@ If this happens we simply make the RHS into an updatable thunk, and 'exectute' it rather than allocating it statically. \begin{code} -rhsIsStatic :: HomeModules -> CoreExpr -> Bool +rhsIsStatic :: PackageId -> 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. @@ -1260,7 +1377,7 @@ rhsIsStatic :: HomeModules -> CoreExpr -> Bool -- When opt_RuntimeTypes is on, we keep type lambdas and treat -- them as making the RHS re-entrant (non-updatable). -rhsIsStatic hmods rhs = is_static False rhs +rhsIsStatic this_pkg rhs = is_static False rhs where is_static :: Bool -- True <=> in a constructor argument; must be atomic -> CoreExpr -> Bool @@ -1269,6 +1386,7 @@ rhsIsStatic hmods rhs = is_static False rhs is_static in_arg (Note (SCC _) e) = False is_static in_arg (Note _ e) = is_static in_arg e + is_static in_arg (Cast e co) = is_static in_arg e is_static in_arg (Lit lit) = case lit of @@ -1287,7 +1405,7 @@ rhsIsStatic hmods rhs = is_static False rhs where go (Var f) n_val_args #if mingw32_TARGET_OS - | not (isDllName hmods (idName f)) + | not (isDllName this_pkg (idName f)) #endif = saturated_data_con f n_val_args || (in_arg && n_val_args == 0) @@ -1311,6 +1429,7 @@ rhsIsStatic hmods rhs = is_static False rhs go (Note (SCC _) f) n_val_args = False go (Note _ f) n_val_args = go f n_val_args + go (Cast e co) n_val_args = go e n_val_args go other n_val_args = False