X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreUtils.lhs;h=ec808d484b80880a8af8d86ea20db19a6e84e52b;hb=6084fb5517da34f65034370a3695e2af3b85ce2b;hp=05d429ea05a6f8593fe69d41f009e3b3b3bd6b3c;hpb=a4835b8b82170a11fde4a5d05b3f4ecea7376d97;p=ghc-hetmet.git diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index 05d429e..ec808d4 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, @@ -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 @@ -993,8 +997,8 @@ arityType :: DynFlags -> CoreExpr -> ArityType arityType dflags (Note _ e) = arityType dflags e -- Not needed any more: etaExpand is cleverer --- | ok_note n = arityType dflags e --- | otherwise = ATop +-- removed: | ok_note n = arityType dflags e +-- removed: | otherwise = ATop arityType dflags (Cast e _) = arityType dflags e @@ -1114,7 +1118,6 @@ etaExpand n us expr ty | manifestArity expr >= n = expr -- The no-op case | otherwise = eta_expand n us expr ty - where -- manifestArity sees how many leading value lambdas there are manifestArity :: CoreExpr -> Arity @@ -1175,7 +1178,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 +1186,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 +1207,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 +1236,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} %************************************************************************ @@ -1406,7 +1438,7 @@ hashExpr :: CoreExpr -> Int hashExpr e = fromIntegral (hash_expr (1,emptyVarEnv) e .&. 0x7fffffff) -- UniqFM doesn't like negative Ints -type HashEnv = (Int, VarEnv Int) -- Hash code for bound variables +type HashEnv = (Int, VarEnv Int) -- ^ Hash code for bound variables hash_expr :: HashEnv -> CoreExpr -> Word32 -- Word32, because we're expecting overflows here, and overflowing @@ -1469,8 +1501,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 @@ -1520,9 +1553,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