X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreUtils.lhs;h=ec808d484b80880a8af8d86ea20db19a6e84e52b;hp=8b0eda2b27f22bf7a342e82441d05c550111f884;hb=675bfa1175449297ecc235dcb31081a7ae726f4d;hpb=dcd9c637398c22ebf791e92ce490359ee8cf3e0b diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index 8b0eda2..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, @@ -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 @@ -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} %************************************************************************ @@ -1271,6 +1303,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 @@ -1403,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 @@ -1466,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 @@ -1517,11 +1553,8 @@ 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 @@ -1549,7 +1582,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)