X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreUtils.lhs;h=e41623c24af93ce21a237eb8f1f9c1563f958e35;hb=6ee9554a738c442719ded861504acb729fd3d431;hp=a00a5296e58c7d4f874a42742fc615fdd2a29a47;hpb=d04e338c3b78fb76341e374bf776b14cbca78bd1;p=ghc-hetmet.git diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index a00a529..e41623c 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -23,7 +23,7 @@ module CoreUtils ( findDefault, findAlt, isDefaultAlt, mergeAlts, trimConArgs, -- Properties of expressions - exprType, coreAltType, + exprType, coreAltType, coreAltsType, exprIsDupable, exprIsTrivial, exprIsCheap, exprIsHNF,exprOkForSpeculation, exprIsBig, exprIsConApp_maybe, exprIsBottom, @@ -34,7 +34,7 @@ module CoreUtils ( exprEtaExpandArity, etaExpand, -- Size - coreBindsSize, + coreBindsSize, exprSize, -- Hashing hashExpr, @@ -109,6 +109,10 @@ exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy coreAltType :: CoreAlt -> Type coreAltType (_,_,rhs) = exprType rhs + +coreAltsType :: [CoreAlt] -> Type +coreAltsType (alt:_) = coreAltType alt +coreAltsType [] = panic "corAltsType" \end{code} @mkPiType@ makes a (->) type or a forall type, depending on whether @@ -674,9 +678,9 @@ app_is_value _ _ = False 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"))) +dataConRepInstPat = dataConInstPat dataConRepArgTys (repeat ((fsLit "ipv"))) dataConRepFSInstPat = dataConInstPat dataConRepArgTys -dataConOrigInstPat = dataConInstPat dc_arg_tys (repeat (FSLIT("ipv"))) +dataConOrigInstPat = dataConInstPat dc_arg_tys (repeat ((fsLit "ipv"))) where dc_arg_tys dc = map mkPredTy (dataConEqTheta dc) ++ map mkPredTy (dataConDictTheta dc) ++ dataConOrigArgTys dc -- Remember to include the existential dictionaries @@ -1175,7 +1179,7 @@ eta_expand n us expr ty Lam lam_tv (eta_expand n us2 (App expr (Type (mkTyVarTy lam_tv))) (substTyWith [tv] [mkTyVarTy lam_tv] ty')) where - lam_tv = setVarName tv (mkSysTvName uniq FSLIT("etaT")) + lam_tv = setVarName tv (mkSysTvName uniq (fsLit "etaT")) -- Using tv as a base retains its tyvar/covar-ness (uniq:us2) = us ; Nothing -> @@ -1183,7 +1187,7 @@ eta_expand n us expr ty case splitFunTy_maybe ty of { Just (arg_ty, res_ty) -> Lam arg1 (eta_expand (n-1) us2 (App expr (Var arg1)) res_ty) where - arg1 = mkSysLocal FSLIT("eta") uniq arg_ty + arg1 = mkSysLocal (fsLit "eta") uniq arg_ty (uniq:us2) = us ; Nothing -> @@ -1204,6 +1208,7 @@ eta_expand n us expr ty -- 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} @@ -1232,23 +1237,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 _ e) = go e - go (Cast e _) = go e - 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 + 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} %************************************************************************ @@ -1271,6 +1304,9 @@ 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 @@ -1466,8 +1502,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 @@ -1517,9 +1554,6 @@ 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 where