X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreUtils.lhs;h=2599f4abef847c2af0980ed9bf1e3c668a5dfc47;hp=362fb5272b48625497db90b500f9bd896051544f;hb=8d6bc9bf51829ea04da5f599b84114ef220f0a19;hpb=df95de0ba37cd137429e28821283372f63544784 diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index 362fb52..2599f4a 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -6,14 +6,21 @@ Utility functions on @Core@ syntax \begin{code} +{-# OPTIONS -fno-warn-incomplete-patterns #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module CoreUtils ( -- Construction - mkInlineMe, mkSCC, mkCoerce, + mkInlineMe, mkSCC, mkCoerce, mkCoerceI, bindNonRec, needsCaseBinding, mkIfThenElse, mkAltExpr, mkPiType, mkPiTypes, -- Taking expressions apart - findDefault, findAlt, isDefaultAlt, mergeAlts, + findDefault, findAlt, isDefaultAlt, mergeAlts, trimConArgs, -- Properties of expressions exprType, coreAltType, @@ -27,7 +34,7 @@ module CoreUtils ( exprEtaExpandArity, etaExpand, -- Size - coreBindsSize, + coreBindsSize, exprSize, -- Hashing hashExpr, @@ -48,6 +55,7 @@ import SrcLoc import VarSet import VarEnv import Name +import Module #if mingw32_TARGET_OS import Packages #endif @@ -63,7 +71,6 @@ import TyCon import TysWiredIn import CostCentre import BasicTypes -import PackageConfig import Unique import Outputable import DynFlags @@ -87,14 +94,13 @@ import GHC.Exts -- For `xori` \begin{code} exprType :: CoreExpr -> Type -exprType (Var var) = idType var -exprType (Lit lit) = literalType lit -exprType (Let _ body) = exprType body -exprType (Case _ _ ty alts) = ty -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 (Var var) = idType var +exprType (Lit lit) = literalType lit +exprType (Let _ body) = exprType body +exprType (Case _ _ ty _) = ty +exprType (Cast _ co) = snd (coercionKind co) +exprType (Note _ e) = exprType e +exprType (Lam binder expr) = mkPiType binder (exprType expr) exprType e@(App _ _) = case collectArgs e of (fun, args) -> applyTypeToArgs e (exprType fun) args @@ -124,13 +130,13 @@ mkPiType v ty \begin{code} applyTypeToArg :: Type -> CoreExpr -> Type applyTypeToArg fun_ty (Type arg_ty) = applyTy fun_ty arg_ty -applyTypeToArg fun_ty other_arg = funResultTy fun_ty +applyTypeToArg fun_ty _ = 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 _ op_ty [] = op_ty applyTypeToArgs e op_ty (Type ty : args) = -- Accumulate type arguments so we can instantiate all at once @@ -141,7 +147,7 @@ applyTypeToArgs e op_ty (Type ty : args) where op_ty' = applyTys op_ty (reverse rev_tys) -applyTypeToArgs e op_ty (other_arg : args) +applyTypeToArgs e op_ty (_ : args) = case (splitFunTy_maybe op_ty) of Just (_, res_ty) -> applyTypeToArgs e res_ty args Nothing -> pprPanic "applyTypeToArgs" (pprCoreExpr e $$ ppr op_ty) @@ -188,6 +194,7 @@ its rhs is trivial) and *then* we could get rid of the inline_me. But it hardly seems worth it, so I don't bother. \begin{code} +mkInlineMe :: CoreExpr -> CoreExpr mkInlineMe (Var v) = Var v mkInlineMe e = Note InlineMe e \end{code} @@ -195,6 +202,10 @@ mkInlineMe e = Note InlineMe e \begin{code} +mkCoerceI :: CoercionI -> CoreExpr -> CoreExpr +mkCoerceI IdCo e = e +mkCoerceI (ACo co) e = mkCoerce co e + mkCoerce :: Coercion -> CoreExpr -> CoreExpr mkCoerce co (Cast expr co2) = ASSERT(let { (from_ty, _to_ty) = coercionKind co; @@ -203,7 +214,7 @@ mkCoerce co (Cast expr co2) mkCoerce (mkTransCoercion co2 co) expr mkCoerce co expr - = let (from_ty, to_ty) = coercionKind co in + = let (from_ty, _to_ty) = coercionKind co in -- if to_ty `coreEqType` from_ty -- then expr -- else @@ -215,7 +226,7 @@ mkCoerce co expr mkSCC :: CostCentre -> Expr b -> Expr b -- Note: Nested SCC's *are* preserved for the benefit of -- cost centre stack profiling -mkSCC cc (Lit lit) = Lit lit +mkSCC _ (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 @@ -246,6 +257,7 @@ bindNonRec bndr rhs body | needsCaseBinding (idType bndr) rhs = Case rhs bndr (exprType body) [(DEFAULT,[],body)] | otherwise = Let (NonRec bndr rhs) body +needsCaseBinding :: Type -> CoreExpr -> Bool needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs) -- Make a case expression instead of a let -- These can arise either from the desugarer, @@ -260,6 +272,8 @@ mkAltExpr (DataAlt con) args inst_tys = mkConApp con (map Type inst_tys ++ varsToCoreExprs args) mkAltExpr (LitAlt lit) [] [] = Lit lit +mkAltExpr (LitAlt _) _ _ = panic "mkAltExpr LitAlt" +mkAltExpr DEFAULT _ _ = panic "mkAltExpr DEFAULT" mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr mkIfThenElse guard then_expr else_expr @@ -288,7 +302,7 @@ findAlt :: AltCon -> [CoreAlt] -> CoreAlt findAlt con alts = case alts of (deflt@(DEFAULT,_,_):alts) -> go alts deflt - other -> go alts panic_deflt + _ -> go alts panic_deflt where panic_deflt = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts)) @@ -301,7 +315,7 @@ findAlt con alts isDefaultAlt :: CoreAlt -> Bool isDefaultAlt (DEFAULT, _, _) = True -isDefaultAlt other = False +isDefaultAlt _ = False --------------------------------- mergeAlts :: [CoreAlt] -> [CoreAlt] -> [CoreAlt] @@ -314,6 +328,18 @@ mergeAlts (a1:as1) (a2:as2) LT -> a1 : mergeAlts as1 (a2:as2) EQ -> a1 : mergeAlts as1 as2 -- Discard a2 GT -> a2 : mergeAlts (a1:as1) as2 + + +--------------------------------- +trimConArgs :: AltCon -> [CoreArg] -> [CoreArg] +-- Given case (C a b x y) of +-- C b x y -> ... +-- we want to drop the leading type argument of the scrutinee +-- leaving the arguments to match agains the pattern + +trimConArgs DEFAULT args = ASSERT( null args ) [] +trimConArgs (LitAlt _) args = ASSERT( null args ) [] +trimConArgs (DataAlt dc) args = dropList (dataConUnivTyVars dc) args \end{code} @@ -348,15 +374,16 @@ SCC notes. We do not treat (_scc_ "foo" x) as trivial, because b) see the note [SCC-and-exprIsTrivial] in Simplify.simplLazyBind \begin{code} -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 (SCC _) e) = False -- See notes above +exprIsTrivial :: CoreExpr -> Bool +exprIsTrivial (Var _) = True -- See notes above +exprIsTrivial (Type _) = True +exprIsTrivial (Lit lit) = litIsTrivial lit +exprIsTrivial (App e arg) = not (isRuntimeArg arg) && exprIsTrivial e +exprIsTrivial (Note (SCC _) _) = 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 +exprIsTrivial (Cast e _) = exprIsTrivial e +exprIsTrivial (Lam b body) = not (isRuntimeVar b) && exprIsTrivial body +exprIsTrivial _ = False \end{code} @@ -372,20 +399,21 @@ exprIsTrivial other = False \begin{code} -exprIsDupable (Type _) = True -exprIsDupable (Var v) = True -exprIsDupable (Lit lit) = litIsDupable lit -exprIsDupable (Note InlineMe e) = True +exprIsDupable :: CoreExpr -> Bool +exprIsDupable (Type _) = True +exprIsDupable (Var _) = True +exprIsDupable (Lit lit) = litIsDupable lit +exprIsDupable (Note InlineMe _) = True exprIsDupable (Note _ e) = exprIsDupable e -exprIsDupable (Cast e co) = exprIsDupable e -exprIsDupable expr +exprIsDupable (Cast e _) = exprIsDupable e +exprIsDupable expr = go expr 0 where - go (Var v) n_args = True + go (Var _) _ = True go (App f a) n_args = n_args < dupAppSize && exprIsDupable a && go f (n_args+1) - go other n_args = False + go _ _ = False dupAppSize :: Int dupAppSize = 4 -- Size of application we are prepared to duplicate @@ -421,12 +449,12 @@ because sharing will make sure it is only evaluated once. \begin{code} exprIsCheap :: CoreExpr -> Bool -exprIsCheap (Lit lit) = True +exprIsCheap (Lit _) = True exprIsCheap (Type _) = True exprIsCheap (Var _) = True -exprIsCheap (Note InlineMe e) = True +exprIsCheap (Note InlineMe _) = True exprIsCheap (Note _ e) = exprIsCheap e -exprIsCheap (Cast e co) = exprIsCheap e +exprIsCheap (Cast e _) = exprIsCheap e exprIsCheap (Lam x e) = isRuntimeVar x || exprIsCheap e exprIsCheap (Case e _ _ alts) = exprIsCheap e && and [exprIsCheap rhs | (_,_,rhs) <- alts] @@ -447,7 +475,7 @@ exprIsCheap other_expr -- Applications and variables 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 + go (Var _) [] = True -- Just a type application of a variable -- (f t1 t2 t3) counts as WHNF go (Var f) args = case globalIdDetails f of @@ -456,14 +484,14 @@ exprIsCheap other_expr -- Applications and variables PrimOpId op -> go_primop op args DataConWorkId _ -> go_pap args - other | length args < idArity f -> go_pap args + _ | length args < idArity f -> go_pap args - other -> isBottomingId f + _ -> 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 other args = False + go _ _ = False -------------- go_pap args = all exprIsTrivial args @@ -481,7 +509,7 @@ exprIsCheap other_expr -- Applications and variables -------------- 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 + go_sel _ = 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) @@ -523,14 +551,14 @@ exprOkForSpeculation (Type _) = True exprOkForSpeculation (Var v) = isUnLiftedType (idType v) && not (isTickBoxOp v) exprOkForSpeculation (Note _ e) = exprOkForSpeculation e -exprOkForSpeculation (Cast e co) = exprOkForSpeculation e +exprOkForSpeculation (Cast e _) = exprOkForSpeculation e exprOkForSpeculation other_expr = case collectArgs other_expr of (Var f, args) -> spec_ok (globalIdDetails f) args - other -> False + _ -> False where - spec_ok (DataConWorkId _) args + spec_ok (DataConWorkId _) _ = True -- The strictness of the constructor has already -- been expressed by its "wrapper", so we don't need -- to take the arguments into account @@ -548,7 +576,7 @@ exprOkForSpeculation other_expr -- A bit conservative: we don't really need -- to care about lazy arguments, but this is easy - spec_ok other args = False + spec_ok _ _ = False isDivOp :: PrimOp -> Bool -- True of dyadic operators that can fail @@ -564,24 +592,24 @@ isDivOp IntegerQuotRemOp = True isDivOp IntegerDivModOp = True isDivOp FloatDivOp = True isDivOp DoubleDivOp = True -isDivOp other = False +isDivOp _ = False \end{code} \begin{code} exprIsBottom :: CoreExpr -> Bool -- True => definitely bottom 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 - go n (Var v) = idAppIsBottom v n - go n (Lit _) = False - go n (Lam _ _) = False - go n (Type _) = False + where + -- n is the number of args + go n (Note _ e) = go n e + go n (Cast e _) = go n e + go n (Let _ e) = go n e + go _ (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 _ (Lit _) = False + go _ (Lam _ _) = False + go _ (Type _) = False idAppIsBottom :: Id -> Int -> Bool idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args @@ -606,8 +634,8 @@ Because `seq` on such things completes immediately For unlifted argument types, we have to be careful: C (f x :: Int#) -Suppose (f x) diverges; then C (f x) is not a value. True, but -this form is illegal (see the invariants in CoreSyn). Args of unboxed +Suppose (f x) diverges; then C (f x) is not a value. However this can't +happen: see CoreSyn Note [CoreSyn let/app invariant]. Args of unboxed type must be ok-for-speculation (or trivial). \begin{code} @@ -621,43 +649,36 @@ exprIsHNF (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... -exprIsHNF (Lit l) = True -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 (Lit _) = True +exprIsHNF (Type _) = 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 _) = exprIsHNF e exprIsHNF (App e (Type _)) = exprIsHNF e exprIsHNF (App e a) = app_is_value e [a] -exprIsHNF other = False +exprIsHNF _ = False -- There is at least one value argument +app_is_value :: CoreExpr -> [CoreArg] -> Bool 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 - (arg_ty, res_ty) = splitFunTy fun_ty + = idArity fun > valArgCount args -- Under-applied function + || isDataConWorkId fun -- or data constructor +app_is_value (Note _ f) as = app_is_value f as +app_is_value (Cast f _) as = app_is_value f as +app_is_value (App f a) as = app_is_value f (a:as) +app_is_value _ _ = False \end{code} \begin{code} +dataConRepInstPat, dataConOrigInstPat :: [Unique] -> DataCon -> [Type] -> ([TyVar], [CoVar], [Id]) +dataConRepFSInstPat :: [FastString] -> [Unique] -> DataCon -> [Type] -> ([TyVar], [CoVar], [Id]) -- These InstPat functions go here to avoid circularity between DataCon and Id dataConRepInstPat = dataConInstPat dataConRepArgTys (repeat (FSLIT("ipv"))) dataConRepFSInstPat = dataConInstPat dataConRepArgTys dataConOrigInstPat = dataConInstPat dc_arg_tys (repeat (FSLIT("ipv"))) where - dc_arg_tys dc = map mkPredTy (dataConTheta dc) ++ dataConOrigArgTys dc + dc_arg_tys dc = map mkPredTy (dataConEqTheta dc) ++ map mkPredTy (dataConDictTheta dc) ++ dataConOrigArgTys dc -- Remember to include the existential dictionaries dataConInstPat :: (DataCon -> [Type]) -- function used to find arg tys @@ -673,9 +694,13 @@ dataConInstPat :: (DataCon -> [Type]) -- function used to find arg tys -- -- co_tvs are intended to be used as binders for coercion args and the kinds -- of these vars have been instantiated by the inst_tys and the ex_tys +-- The co_tvs include both GADT equalities (dcEqSpec) and +-- programmer-specified equalities (dcEqTheta) -- --- arg_ids are indended to be used as binders for value arguments, including --- dicts, and their types have been instantiated with inst_tys and ex_tys +-- arg_ids are indended to be used as binders for value arguments, +-- and their types have been instantiated with inst_tys and ex_tys +-- The arg_ids include both dicts (dcDictTheta) and +-- programmer-specified arguments (after rep-ing) (deRepArgTys) -- -- Example. -- The following constructor T1 @@ -695,16 +720,17 @@ dataConInstPat :: (DataCon -> [Type]) -- function used to find arg tys -- where the double-primed variables are created with the FastStrings and -- Uniques given as fss and us dataConInstPat arg_fun fss uniqs con inst_tys - = (ex_bndrs, co_bndrs, id_bndrs) + = (ex_bndrs, co_bndrs, arg_ids) where univ_tvs = dataConUnivTyVars con ex_tvs = dataConExTyVars con arg_tys = arg_fun con eq_spec = dataConEqSpec con - eq_preds = eqSpecPreds eq_spec + eq_theta = dataConEqTheta con + eq_preds = eqSpecPreds eq_spec ++ eq_theta n_ex = length ex_tvs - n_co = length eq_spec + n_co = length eq_preds -- split the Uniques and FastStrings (ex_uniqs, uniqs') = splitAt n_ex uniqs @@ -731,14 +757,14 @@ dataConInstPat arg_fun fss uniqs con inst_tys co_kind = substTy subst (mkPredTy eq_pred) -- make value vars, instantiating types - mk_id_var uniq fs ty = mkUserLocal (mkVarOccFS fs) uniq (substTy subst ty) noSrcLoc - id_bndrs = zipWith3 mk_id_var id_uniqs id_fss arg_tys + mk_id_var uniq fs ty = mkUserLocal (mkVarOccFS fs) uniq (substTy subst ty) noSrcSpan + arg_ids = zipWith3 mk_id_var id_uniqs id_fss arg_tys exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr]) -- Returns (Just (dc, [x1..xn])) if the argument expression is -- a constructor application of the form (dc x1 .. xn) exprIsConApp_maybe (Cast expr co) - = -- Here we do the PushC reduction rule as described in the FC paper + = -- Here we do the KPush reduction rule as described in the FC paper case exprIsConApp_maybe expr of { Nothing -> Nothing ; Just (dc, dc_args) -> @@ -768,17 +794,20 @@ exprIsConApp_maybe (Cast expr co) let tc_arity = tyConArity from_tc - (univ_args, rest1) = splitAt tc_arity dc_args - (ex_args, rest2) = splitAt n_ex_tvs rest1 - (co_args, val_args) = splitAt n_cos rest2 + (univ_args, rest1) = splitAt tc_arity dc_args + (ex_args, rest2) = splitAt n_ex_tvs rest1 + (co_args_spec, rest3) = splitAt n_cos_spec rest2 + (co_args_theta, val_args) = splitAt n_cos_theta rest3 arg_tys = dataConRepArgTys dc dc_univ_tyvars = dataConUnivTyVars dc dc_ex_tyvars = dataConExTyVars dc dc_eq_spec = dataConEqSpec dc + dc_eq_theta = dataConEqTheta dc dc_tyvars = dc_univ_tyvars ++ dc_ex_tyvars n_ex_tvs = length dc_ex_tyvars - n_cos = length dc_eq_spec + n_cos_spec = length dc_eq_spec + n_cos_theta = length dc_eq_theta -- Make the "theta" from Fig 3 of the paper gammas = decomposeCo tc_arity co @@ -786,10 +815,15 @@ exprIsConApp_maybe (Cast expr co) theta = zipOpenTvSubst dc_tyvars new_tys -- First we cast the existential coercion arguments - cast_co (tv,ty) (Type co) = Type $ mkSymCoercion (substTyVar theta tv) - `mkTransCoercion` co - `mkTransCoercion` (substTy theta ty) - new_co_args = zipWith cast_co dc_eq_spec co_args + cast_co_spec (tv, ty) co + = cast_co_theta (mkEqPred (mkTyVarTy tv, ty)) co + cast_co_theta eqPred (Type co) + | (ty1, ty2) <- getEqPredTys eqPred + = Type $ mkSymCoercion (substTy theta ty1) + `mkTransCoercion` co + `mkTransCoercion` (substTy theta ty2) + new_co_args = zipWith cast_co_spec dc_eq_spec co_args_spec ++ + zipWith cast_co_theta dc_eq_theta co_args_theta -- ...and now value arguments new_val_args = zipWith cast_arg arg_tys val_args @@ -843,7 +877,7 @@ exprIsConApp_maybe expr = analyse (collectArgs expr) isCheapUnfolding unf = exprIsConApp_maybe (unfoldingTemplate unf) - analyse other = Nothing + analyse _ = Nothing \end{code} @@ -944,26 +978,27 @@ data ArityType = AFun Bool ArityType -- True <=> one-shot arityDepth :: ArityType -> Arity arityDepth (AFun _ ty) = 1 + arityDepth ty -arityDepth ty = 0 +arityDepth _ = 0 -andArityType ABot at2 = at2 -andArityType ATop at2 = ATop +andArityType :: ArityType -> ArityType -> ArityType +andArityType ABot at2 = at2 +andArityType ATop _ = ATop andArityType (AFun t1 at1) (AFun t2 at2) = AFun (t1 && t2) (andArityType at1 at2) -andArityType at1 at2 = andArityType at2 at1 +andArityType at1 at2 = andArityType at2 at1 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 dflags (Note n e) = arityType dflags e +arityType dflags (Note _ e) = arityType dflags e -- Not needed any more: etaExpand is cleverer -- | ok_note n = arityType dflags e -- | otherwise = ATop -arityType dflags (Cast e co) = arityType dflags e +arityType dflags (Cast e _) = arityType dflags e -arityType dflags (Var v) +arityType _ (Var v) = mk (idArity v) (arg_tys (idType v)) where mk :: Arity -> [Type] -> ArityType @@ -973,9 +1008,9 @@ arityType dflags (Var v) -- False -> \(s:RealWorld) -> e -- where foo has arity 1. Then we want the state hack to -- apply to foo too, so we can eta expand the case. - mk 0 tys | isBottomingId v = ABot - | (ty:tys) <- tys, isStateHackType ty = AFun True ATop - | otherwise = ATop + mk 0 tys | isBottomingId v = ABot + | (ty:_) <- tys, isStateHackType ty = AFun True ATop + | otherwise = ATop mk n (ty:tys) = AFun (isStateHackType ty) (mk (n-1) tys) mk n [] = AFun False (mk (n-1) []) @@ -992,9 +1027,13 @@ arityType dflags (Lam x e) -- Applications; decrease arity 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 +arityType dflags (App f a) + = case arityType dflags f of + ABot -> ABot -- If function diverges, ignore argument + ATop -> ATop -- No no info about function + AFun _ xs + | exprIsCheap a -> xs + | otherwise -> ATop -- Case/Let; keep arity if either the expression is cheap -- or it's a 1-shot lambda @@ -1005,15 +1044,15 @@ arityType dflags (App f a) = case arityType dflags f of -- The difference is observable using 'seq' 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 + xs | exprIsCheap scrut -> xs + AFun one_shot _ | one_shot -> AFun True ATop + _ -> 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 + xs | cheap_bind b -> xs + AFun one_shot _ | one_shot -> AFun True ATop + _ -> ATop where cheap_bind (NonRec b e) = is_cheap (b,e) cheap_bind (Rec prs) = all is_cheap prs @@ -1036,7 +1075,7 @@ arityType dflags (Let b e) -- One could go further and make exprIsCheap reply True to any -- dictionary-typed expression, but that's more work. -arityType dflags other = ATop +arityType _ _ = ATop {- NOT NEEDED ANY MORE: etaExpand is cleverer ok_note InlineMe = False @@ -1083,7 +1122,7 @@ 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 +manifestArity _ = 0 -- etaExpand deals with for-alls. For example: -- etaExpand 1 E @@ -1093,8 +1132,9 @@ manifestArity e = 0 -- -- It deals with coerces too, though they are now rare -- so perhaps the extra code isn't worth it +eta_expand :: Int -> [Unique] -> CoreExpr -> Type -> CoreExpr -eta_expand n us expr ty +eta_expand n _ 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 @@ -1156,14 +1196,15 @@ eta_expand n us expr ty -- coerce T (\x::[T] -> (coerce ([T]->Int) e) x) case splitNewTypeRepCo_maybe ty of { - Just(ty1,co) -> - mkCoerce (mkSymCoercion co) (eta_expand n us (mkCoerce co expr) ty1) ; + Just(ty1,co) -> mkCoerce (mkSymCoercion co) + (eta_expand n us (mkCoerce co expr) ty1) ; 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. + -- Otherwise we'd end up with an explicit lambda having a non-function type expr }}} \end{code} @@ -1192,23 +1233,51 @@ And in any case it seems more robust to have exprArity be a bit more intelligent But note that (\x y z -> f x y z) should have arity 3, regardless of f's arity. +Note [exprArity invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +exprArity has the following invariant: + (exprArity e) = n, then manifestArity (etaExpand e n) = n + +That is, if exprArity says "the arity is n" then etaExpand really can get +"n" manifest lambdas to the top. + +Why is this important? Because + - In TidyPgm we use exprArity to fix the *final arity* of + each top-level Id, and in + - In CorePrep we use etaExpand on each rhs, so that the visible lambdas + actually match that arity, which in turn means + that the StgRhs has the right number of lambdas + +An alternative would be to do the eta-expansion in TidyPgm, at least +for top-level bindings, in which case we would not need the trim_arity +in exprArity. That is a less local change, so I'm going to leave it for today! + + \begin{code} exprArity :: CoreExpr -> Arity exprArity e = go e - where - go (Var v) = idArity v - 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! - -- f (fac x) does not have arity 2, - -- even if f has arity 3! - -- NB: `max 0`! (\x y -> f x) has arity 2, even if f is - -- unknown, hence arity 0 - go _ = 0 + where + go (Var v) = idArity v + go (Lam x e) | isId x = go e + 1 + | otherwise = go e + go (Note _ e) = go e + go (Cast e co) = trim_arity (go e) 0 (snd (coercionKind co)) + go (App e (Type _)) = go e + go (App f a) | exprIsCheap a = (go f - 1) `max` 0 + -- NB: exprIsCheap a! + -- f (fac x) does not have arity 2, + -- even if f has arity 3! + -- NB: `max 0`! (\x y -> f x) has arity 2, even if f is + -- unknown, hence arity 0 + go _ = 0 + + -- Note [exprArity invariant] + trim_arity n a ty + | n==a = a + | Just (_, ty') <- splitForAllTy_maybe ty = trim_arity n a ty' + | Just (_, ty') <- splitFunTy_maybe ty = trim_arity n (a+1) ty' + | Just (ty',_) <- splitNewTypeRepCo_maybe ty = trim_arity n a ty' + | otherwise = a \end{code} %************************************************************************ @@ -1231,16 +1300,19 @@ cheapEqExpr (Type t1) (Type t2) = t1 `coreEqType` t2 cheapEqExpr (App f1 a1) (App f2 a2) = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2 +cheapEqExpr (Cast e1 t1) (Cast e2 t2) + = e1 `cheapEqExpr` e2 && t1 `coreEqCoercion` t2 + cheapEqExpr _ _ = False exprIsBig :: Expr b -> Bool -- Returns True of expressions that are too big to be compared by cheapEqExpr exprIsBig (Lit _) = False -exprIsBig (Var v) = False -exprIsBig (Type t) = False +exprIsBig (Var _) = False +exprIsBig (Type _) = False exprIsBig (App f a) = exprIsBig f || exprIsBig a exprIsBig (Cast e _) = exprIsBig e -- Hopefully coercions are not too big! -exprIsBig other = True +exprIsBig _ = True \end{code} @@ -1255,7 +1327,7 @@ tcEqExpr e1 e2 = tcEqExprX rn_env e1 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 _ (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) @@ -1277,16 +1349,18 @@ tcEqExprX env (Case e1 v1 t1 a1) where env' = rnBndr2 env v1 v2 -tcEqExprX env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && tcEqExprX env e1 e2 +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 - +tcEqExprX env (Type t1) (Type t2) = tcEqTypeX env t1 t2 +tcEqExprX _ _ _ = False + +eq_alt :: RnEnv2 -> CoreAlt -> CoreAlt -> Bool 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 (CoreNote s1) (CoreNote s2) = s1 == s2 -eq_note env other1 other2 = False +eq_note :: RnEnv2 -> Note -> Note -> Bool +eq_note _ (SCC cc1) (SCC cc2) = cc1 == cc2 +eq_note _ (CoreNote s1) (CoreNote s2) = s1 == s2 +eq_note _ _ _ = False \end{code} @@ -1313,6 +1387,7 @@ 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 :: Note -> Int noteSize (SCC cc) = cc `seq` 1 noteSize InlineMe = 1 noteSize (CoreNote s) = s `seq` 1 -- hdaume: core annotations @@ -1323,13 +1398,17 @@ varSize b | isTyVar b = 1 megaSeqIdInfo (idInfo b) `seq` 1 -varsSize = foldr ((+) . varSize) 0 +varsSize :: [Var] -> Int +varsSize = sum . map varSize +bindSize :: CoreBind -> Int bindSize (NonRec b e) = varSize b + exprSize e bindSize (Rec prs) = foldr ((+) . pairSize) 0 prs +pairSize :: (Var, CoreExpr) -> Int pairSize (b,e) = varSize b + exprSize e +altSize :: CoreAlt -> Int altSize (c,bs,e) = c `seq` varsSize bs + exprSize e \end{code} @@ -1362,32 +1441,33 @@ hash_expr :: HashEnv -> CoreExpr -> Word32 -- Word32, because we're expecting overflows here, and overflowing -- signed types just isn't cool. In C it's even undefined. hash_expr env (Note _ e) = hash_expr env e -hash_expr env (Cast e co) = hash_expr env e +hash_expr env (Cast e _) = hash_expr env e hash_expr env (Var v) = hashVar env v -hash_expr env (Lit lit) = fromIntegral (hashLiteral lit) +hash_expr _ (Lit lit) = fromIntegral (hashLiteral lit) hash_expr env (App f e) = hash_expr env f * fast_hash_expr env e hash_expr env (Let (NonRec b r) e) = hash_expr (extend_env env b) e * fast_hash_expr env r -hash_expr env (Let (Rec ((b,r):_)) e) = hash_expr (extend_env env b) e +hash_expr env (Let (Rec ((b,_):_)) e) = hash_expr (extend_env env b) e hash_expr env (Case e _ _ _) = hash_expr env e hash_expr env (Lam b e) = hash_expr (extend_env env b) e -hash_expr env (Type t) = WARN(True, text "hash_expr: type") 1 +hash_expr _ (Type _) = WARN(True, text "hash_expr: type") 1 -- Shouldn't happen. Better to use WARN than trace, because trace -- prevents the CPR optimisation kicking in for hash_expr. +fast_hash_expr :: HashEnv -> CoreExpr -> Word32 fast_hash_expr env (Var v) = hashVar env v fast_hash_expr env (Type t) = fast_hash_type env t -fast_hash_expr env (Lit lit) = fromIntegral (hashLiteral lit) -fast_hash_expr env (Cast e co) = fast_hash_expr env e -fast_hash_expr env (Note n e) = fast_hash_expr env e -fast_hash_expr env (App f a) = fast_hash_expr env a -- A bit idiosyncratic ('a' not 'f')! -fast_hash_expr env other = 1 +fast_hash_expr _ (Lit lit) = fromIntegral (hashLiteral lit) +fast_hash_expr env (Cast e _) = fast_hash_expr env e +fast_hash_expr env (Note _ e) = fast_hash_expr env e +fast_hash_expr env (App _ a) = fast_hash_expr env a -- A bit idiosyncratic ('a' not 'f')! +fast_hash_expr _ _ = 1 fast_hash_type :: HashEnv -> Type -> Word32 fast_hash_type env ty - | Just tv <- getTyVar_maybe ty = hashVar env tv - | Just (tc,_) <- splitTyConApp_maybe ty - = fromIntegral (hashName (tyConName tc)) - | otherwise = 1 + | Just tv <- getTyVar_maybe ty = hashVar env tv + | Just (tc,tys) <- splitTyConApp_maybe ty = let hash_tc = fromIntegral (hashName (tyConName tc)) + in foldr (\t n -> fast_hash_type env t + n) hash_tc tys + | otherwise = 1 extend_env :: HashEnv -> Var -> (Int, VarEnv Int) extend_env (n,env) b = (n+1, extendVarEnv env b n) @@ -1418,8 +1498,9 @@ rhsIsStatic :: PackageId -> CoreExpr -> Bool -- 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. +-- refers to, CAFs; (ii) in CoreToStg to decide whether to put an +-- update flag on it and (iii) in DsExpr to decide how to expand +-- list literals -- -- The basic idea is that rhsIsStatic returns True only if the RHS is -- (a) a value lambda @@ -1469,25 +1550,22 @@ rhsIsStatic :: PackageId -> CoreExpr -> Bool -- 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 this_pkg 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 is_static False (Lam b e) = isRuntimeVar b || is_static False e - is_static in_arg (Note (SCC _) e) = False + is_static _ (Note (SCC _) _) = 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 (Cast e _) = is_static in_arg e - is_static in_arg (Lit lit) + is_static _ (Lit lit) = case lit of MachLabel _ _ -> False - other -> True + _ -> True -- A MachLabel (foreign import "&foo") in an argument -- prevents a constructor application from being static. The -- reason is that it might give rise to unresolvable symbols @@ -1501,7 +1579,7 @@ rhsIsStatic this_pkg rhs = is_static False rhs where go (Var f) n_val_args #if mingw32_TARGET_OS - | not (isDllName this_pkg (idName f)) + | not (isDllName _this_pkg (idName f)) #endif = saturated_data_con f n_val_args || (in_arg && n_val_args == 0) @@ -1523,11 +1601,11 @@ rhsIsStatic this_pkg rhs = is_static False rhs -- 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 (Cast e co) n_val_args = go e n_val_args + go (Note (SCC _) _) _ = False + go (Note _ f) n_val_args = go f n_val_args + go (Cast e _) n_val_args = go e n_val_args - go other n_val_args = False + go _ _ = False saturated_data_con f n_val_args = case isDataConWorkId_maybe f of