findDefault, findAlt, isDefaultAlt, mergeAlts, trimConArgs,
-- Properties of expressions
- exprType, coreAltType,
+ exprType, coreAltType, coreAltsType,
exprIsDupable, exprIsTrivial, exprIsCheap,
exprIsHNF,exprOkForSpeculation, exprIsBig,
exprIsConApp_maybe, exprIsBottom,
exprEtaExpandArity, etaExpand,
-- Size
- coreBindsSize,
+ coreBindsSize, exprSize,
-- Hashing
hashExpr,
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
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
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
| 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
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 ->
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 ->
-- 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}
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}
%************************************************************************
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
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
-- 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
-- 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
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)
projects / ghc-hetmet.git / blobdiff