mkIfThenElse, mkAltExpr, mkPiType, mkPiTypes,
-- Taking expressions apart
- findDefault, findAlt,
+ findDefault, findAlt, isDefaultAlt,
-- Properties of expressions
exprType, coreAltType,
exprIsDupable, exprIsTrivial, exprIsCheap,
- exprIsValue,exprOkForSpeculation, exprIsBig,
+ exprIsHNF,exprOkForSpeculation, exprIsBig,
exprIsConApp_maybe, exprIsBottom,
rhsIsStatic,
hashExpr,
-- Equality
- cheapEqExpr, eqExpr, applyTypeToArgs, applyTypeToArg
+ cheapEqExpr, tcEqExpr, tcEqExprX, applyTypeToArgs, applyTypeToArg
) where
#include "HsVersions.h"
import GLAEXTS -- For `xori`
import CoreSyn
+import CoreFVs ( exprFreeVars )
import PprCore ( pprCoreExpr )
-import Var ( Var, isId, isTyVar )
+import Var ( Var )
+import VarSet ( unionVarSet )
import VarEnv
import Name ( hashName )
+import Packages ( HomeModules )
+#if mingw32_TARGET_OS
import Packages ( isDllName )
-import CmdLineOpts ( DynFlags )
+#endif
import Literal ( hashLiteral, literalType, litIsDupable,
litIsTrivial, isZeroLit, Literal( MachLabel ) )
import DataCon ( DataCon, dataConRepArity, dataConArgTys,
import IdInfo ( GlobalIdDetails(..), megaSeqIdInfo )
import NewDemand ( appIsBottom )
import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe,
- splitFunTy,
+ splitFunTy, tcEqTypeX,
applyTys, isUnLiftedType, seqType, mkTyVarTy,
splitForAllTy_maybe, isForAllTy, splitRecNewType_maybe,
- splitTyConApp_maybe, eqType, funResultTy, applyTy,
- funResultTy, applyTy
+ splitTyConApp_maybe, coreEqType, funResultTy, applyTy
)
import TyCon ( tyConArity )
--- gaw 2004
import TysWiredIn ( boolTy, trueDataCon, falseDataCon )
import CostCentre ( CostCentre )
import BasicTypes ( Arity )
import Unique ( Unique )
import Outputable
import TysPrim ( alphaTy ) -- Debugging only
-import Util ( equalLength, lengthAtLeast )
+import Util ( equalLength, lengthAtLeast, foldl2 )
\end{code}
exprType (Var var) = idType var
exprType (Lit lit) = literalType lit
exprType (Let _ body) = exprType body
--- gaw 2004
exprType (Case _ _ ty alts) = ty
-exprType (Note (Coerce ty _) e) = ty -- **! should take usage from e
+exprType (Note (Coerce ty _) e) = ty -- **! should take usage from e
exprType (Note other_note e) = exprType e
exprType (Lam binder expr) = mkPiType binder (exprType expr)
exprType e@(App _ _)
mkCoerce2 :: Type -> Type -> CoreExpr -> CoreExpr
mkCoerce2 to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr)
- = ASSERT( from_ty `eqType` to_ty2 )
+ = ASSERT( from_ty `coreEqType` to_ty2 )
mkCoerce2 to_ty from_ty2 expr
mkCoerce2 to_ty from_ty expr
- | to_ty `eqType` from_ty = expr
- | otherwise = ASSERT( from_ty `eqType` exprType expr )
+ | to_ty `coreEqType` from_ty = expr
+ | otherwise = ASSERT( from_ty `coreEqType` exprType expr )
Note (Coerce to_ty from_ty) expr
\end{code}
-- deals with them perfectly well.
bindNonRec bndr rhs body
--- gaw 2004
| needsCaseBinding (idType bndr) rhs = Case rhs bndr (exprType body) [(DEFAULT,[],body)]
| otherwise = Let (NonRec bndr rhs) body
mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
mkIfThenElse guard then_expr else_expr
--- gaw 2004
-- Not going to be refining, so okay to take the type of the "then" clause
= Case guard (mkWildId boolTy) (exprType then_expr)
- [ (DataAlt trueDataCon, [], then_expr),
- (DataAlt falseDataCon, [], else_expr) ]
+ [ (DataAlt falseDataCon, [], else_expr), -- Increasing order of tag!
+ (DataAlt trueDataCon, [], then_expr) ]
\end{code}
= case alts of
(deflt@(DEFAULT,_,_):alts) -> go alts deflt
other -> go alts panic_deflt
-
where
panic_deflt = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts))
- go [] deflt = deflt
- go (alt@(con1,_,_) : alts) deflt | con == con1 = alt
- | otherwise = ASSERT( not (con1 == DEFAULT) )
- go alts deflt
+ go [] deflt = deflt
+ go (alt@(con1,_,_) : alts) deflt
+ = case con `cmpAltCon` con1 of
+ LT -> deflt -- Missed it already; the alts are in increasing order
+ EQ -> alt
+ GT -> ASSERT( not (con1 == DEFAULT) ) go alts deflt
+
+isDefaultAlt :: CoreAlt -> Bool
+isDefaultAlt (DEFAULT, _, _) = True
+isDefaultAlt other = False
\end{code}
exprIsCheap (Note InlineMe e) = True
exprIsCheap (Note _ e) = exprIsCheap e
exprIsCheap (Lam x e) = isRuntimeVar x || exprIsCheap e
--- gaw 2004
exprIsCheap (Case e _ _ alts) = exprIsCheap e &&
and [exprIsCheap rhs | (_,_,rhs) <- alts]
-- Experimentally, treat (case x of ...) as cheap
| n_val_args == 0 = True -- Just a type application of
-- a variable (f t1 t2 t3)
-- counts as WHNF
- | otherwise = case globalIdDetails id of
- DataConWorkId _ -> True
- RecordSelId _ _ -> True -- I'm experimenting with making record selection
- ClassOpId _ -> True -- look cheap, so we will substitute it inside a
- -- lambda. Particularly for dictionary field selection
-
- PrimOpId op -> primOpIsCheap op -- In principle we should worry about primops
- -- that return a type variable, since the result
- -- might be applied to something, but I'm not going
- -- to bother to check the number of args
- other -> n_val_args < idArity id
+ | otherwise
+ = case globalIdDetails id of
+ DataConWorkId _ -> True
+ RecordSelId _ _ -> n_val_args == 1 -- I'm experimenting with making record selection
+ ClassOpId _ -> n_val_args == 1 -- 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)
+
+ PrimOpId op -> primOpIsCheap op -- In principle we should worry about primops
+ -- that return a type variable, since the result
+ -- might be applied to something, but I'm not going
+ -- to bother to check the number of args
+ other -> n_val_args < idArity id
\end{code}
exprOkForSpeculation returns True of an expression that it is
-- n is the number of args
go n (Note _ e) = go n e
go n (Let _ e) = go n e
--- gaw 2004
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
idAppIsBottom :: Id -> Int -> Bool
idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args
\end{code}
-@exprIsValue@ returns true for expressions that are certainly *already*
+@exprIsHNF@ returns true for expressions that are certainly *already*
evaluated to *head* normal form. This is used to decide whether it's ok
to change
type must be ok-for-speculation (or trivial).
\begin{code}
-exprIsValue :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP
-exprIsValue (Var v) -- NB: There are no value args at this point
+exprIsHNF :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP
+exprIsHNF (Var v) -- NB: There are no value args at this point
= isDataConWorkId v -- Catches nullary constructors,
-- so that [] and () are values, for example
|| idArity v > 0 -- Catches (e.g.) primops that don't have unfoldings
-- A worry: what if an Id's unfolding is just itself:
-- then we could get an infinite loop...
-exprIsValue (Lit l) = True
-exprIsValue (Type ty) = True -- Types are honorary Values;
+exprIsHNF (Lit l) = True
+exprIsHNF (Type ty) = True -- Types are honorary Values;
-- we don't mind copying them
-exprIsValue (Lam b e) = isRuntimeVar b || exprIsValue e
-exprIsValue (Note _ e) = exprIsValue e
-exprIsValue (App e (Type _)) = exprIsValue e
-exprIsValue (App e a) = app_is_value e [a]
-exprIsValue other = False
+exprIsHNF (Lam b e) = isRuntimeVar b || exprIsHNF e
+exprIsHNF (Note _ e) = exprIsHNF e
+exprIsHNF (App e (Type _)) = exprIsHNF e
+exprIsHNF (App e a) = app_is_value e [a]
+exprIsHNF other = False
-- There is at least one value argument
app_is_value (Var fun) args
This should diverge! But if we eta-expand, it won't. Again, we ignore this
"problem", because being scrupulous would lose an important transformation for
many programs.
+
+
+4. Newtypes
+
+Non-recursive newtypes are transparent, and should not get in the way.
+We do (currently) eta-expand recursive newtypes too. So if we have, say
+
+ newtype T = MkT ([T] -> Int)
+
+Suppose we have
+ e = coerce T f
+where f has arity 1. Then: etaExpandArity e = 1;
+that is, etaExpandArity looks through the coerce.
+
+When we eta-expand e to arity 1: eta_expand 1 e T
+we want to get: coerce T (\x::[T] -> (coerce ([T]->Int) e) x)
+
+HOWEVER, note that if you use coerce bogusly you can ge
+ coerce Int negate
+And since negate has arity 2, you might try to eta expand. But you can't
+decopose Int to a function type. Hence the final case in eta_expand.
-}
-- ===>
-- f x y = case x of { (a,b) -> e }
-- The difference is observable using 'seq'
--- gaw 2004
arityType (Case scrut _ _ alts) = case foldr1 andArityType [arityType rhs | (_,_,rhs) <- alts] of
xs@(AFun one_shot _) | one_shot -> xs
xs | exprIsCheap scrut -> xs
case splitRecNewType_maybe ty of {
Just ty' -> mkCoerce2 ty ty' (eta_expand n us (mkCoerce2 ty' ty expr) ty') ;
- Nothing -> pprTrace "Bad eta expand" (ppr n $$ ppr expr $$ ppr ty) expr
+ 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.
+ expr
}}}
\end{code}
cheapEqExpr (Var v1) (Var v2) = v1==v2
cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2
-cheapEqExpr (Type t1) (Type t2) = t1 `eqType` t2
+cheapEqExpr (Type t1) (Type t2) = t1 `coreEqType` t2
cheapEqExpr (App f1 a1) (App f2 a2)
= f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
\begin{code}
-eqExpr :: CoreExpr -> CoreExpr -> Bool
- -- Works ok at more general type, but only needed at CoreExpr
- -- Used in rule matching, so when we find a type we use
- -- eqTcType, which doesn't look through newtypes
- -- [And it doesn't risk falling into a black hole either.]
-eqExpr e1 e2
- = eq emptyVarEnv e1 e2
+tcEqExpr :: CoreExpr -> CoreExpr -> Bool
+-- Used in rule matching, so does *not* look through
+-- newtypes, predicate types; hence tcEqExpr
+
+tcEqExpr e1 e2 = tcEqExprX rn_env e1 e2
where
- -- The "env" maps variables in e1 to variables in ty2
- -- So when comparing lambdas etc,
- -- we in effect substitute v2 for v1 in e1 before continuing
- eq env (Var v1) (Var v2) = case lookupVarEnv env v1 of
- Just v1' -> v1' == v2
- Nothing -> v1 == v2
-
- eq env (Lit lit1) (Lit lit2) = lit1 == lit2
- eq env (App f1 a1) (App f2 a2) = eq env f1 f2 && eq env a1 a2
- eq env (Lam v1 e1) (Lam v2 e2) = eq (extendVarEnv env v1 v2) e1 e2
- eq env (Let (NonRec v1 r1) e1)
- (Let (NonRec v2 r2) e2) = eq env r1 r2 && eq (extendVarEnv env v1 v2) e1 e2
- eq env (Let (Rec ps1) e1)
- (Let (Rec ps2) e2) = equalLength ps1 ps2 &&
- and (zipWith eq_rhs ps1 ps2) &&
- eq env' e1 e2
+ rn_env = mkRnEnv2 (mkInScopeSet (exprFreeVars e1 `unionVarSet` exprFreeVars 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 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)
+ (Let (NonRec v2 r2) e2) = tcEqExprX env r1 r2
+ && tcEqExprX (rnBndr2 env v1 v2) e1 e2
+tcEqExprX env (Let (Rec ps1) e1)
+ (Let (Rec ps2) e2) = equalLength ps1 ps2
+ && and (zipWith eq_rhs ps1 ps2)
+ && tcEqExprX env' e1 e2
where
- env' = extendVarEnvList env [(v1,v2) | ((v1,_),(v2,_)) <- zip ps1 ps2]
- eq_rhs (_,r1) (_,r2) = eq env' r1 r2
- eq env (Case e1 v1 t1 a1)
- (Case e2 v2 t2 a2) = eq env e1 e2 &&
- t1 `eqType` t2 &&
- equalLength a1 a2 &&
- and (zipWith (eq_alt env') a1 a2)
+ env' = foldl2 rn_bndr2 env ps2 ps2
+ rn_bndr2 env (b1,_) (b2,_) = rnBndr2 env b1 b2
+ eq_rhs (_,r1) (_,r2) = tcEqExprX env' r1 r2
+tcEqExprX env (Case e1 v1 t1 a1)
+ (Case e2 v2 t2 a2) = tcEqExprX env e1 e2
+ && tcEqTypeX env t1 t2
+ && equalLength a1 a2
+ && and (zipWith (eq_alt env') a1 a2)
where
- env' = extendVarEnv env v1 v2
+ env' = rnBndr2 env v1 v2
- eq env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && eq env e1 e2
- eq env (Type t1) (Type t2) = t1 `eqType` t2
- eq env e1 e2 = False
+tcEqExprX env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && tcEqExprX env e1 e2
+tcEqExprX env (Type t1) (Type t2) = tcEqTypeX env t1 t2
+tcEqExprX env e1 e2 = False
- eq_list env [] [] = True
- eq_list env (e1:es1) (e2:es2) = eq env e1 e2 && eq_list env es1 es2
- eq_list env es1 es2 = False
-
- eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 &&
- eq (extendVarEnvList env (vs1 `zip` vs2)) r1 r2
-
- eq_note env (SCC cc1) (SCC cc2) = cc1 == cc2
- eq_note env (Coerce t1 f1) (Coerce t2 f2) = t1 `eqType` t2 && f1 `eqType` f2
- eq_note env InlineCall InlineCall = True
- eq_note env (CoreNote s1) (CoreNote s2) = s1 == s2
- eq_note env other1 other2 = False
+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 (Coerce t1 f1) (Coerce t2 f2) = tcEqTypeX env t1 t2 && tcEqTypeX env f1 f2
+eq_note env InlineCall InlineCall = True
+eq_note env (CoreNote s1) (CoreNote s2) = s1 == s2
+eq_note env other1 other2 = False
\end{code}
exprSize (App f a) = exprSize f + exprSize a
exprSize (Lam b e) = varSize b + exprSize e
exprSize (Let b e) = bindSize b + exprSize e
--- gaw 2004
exprSize (Case e b t as) = seqType t `seq` exprSize e + varSize b + 1 + foldr ((+) . altSize) 0 as
exprSize (Note n e) = noteSize n + exprSize e
exprSize (Type t) = seqType t `seq` 1
hash_expr (Note _ e) = hash_expr e
hash_expr (Let (NonRec b r) e) = hashId b
hash_expr (Let (Rec ((b,r):_)) e) = hashId b
--- gaw 2004
hash_expr (Case _ b _ _) = hashId b
hash_expr (App f e) = hash_expr f * fast_hash_expr e
hash_expr (Var v) = hashId v
and 'exectute' it rather than allocating it statically.
\begin{code}
-rhsIsStatic :: DynFlags -> CoreExpr -> Bool
+rhsIsStatic :: HomeModules -> CoreExpr -> Bool
-- This function is called only on *top-level* right-hand sides
-- Returns True if the RHS can be allocated statically, with
-- no thunks involved at all.
-- BUT watch out for
-- (i) Any cross-DLL references kill static-ness completely
-- because they must be 'executed' not statically allocated
+-- ("DLL" here really only refers to Windows DLLs, on other platforms,
+-- this is not necessary)
--
-- (ii) We treat partial applications as redexes, because in fact we
-- make a thunk for them that runs and builds a PAP
-- t = /\a. (:) (case w a of ...) (Nil a) FALSE (redex)
--
--
--- This is a bit like CoreUtils.exprIsValue, with the following differences:
+-- This is a bit like CoreUtils.exprIsHNF, with the following differences:
-- a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC)
--
-- b) (C x xs), where C is a contructors is updatable if the application is
-- When opt_RuntimeTypes is on, we keep type lambdas and treat
-- them as making the RHS re-entrant (non-updatable).
-rhsIsStatic dflags rhs = is_static False rhs
+rhsIsStatic hmods rhs = is_static False rhs
where
is_static :: Bool -- True <=> in a constructor argument; must be atomic
-> CoreExpr -> Bool
is_static in_arg other_expr = go other_expr 0
where
go (Var f) n_val_args
- | not (isDllName dflags (idName f))
+#if mingw32_TARGET_OS
+ | not (isDllName hmods (idName f))
+#endif
= saturated_data_con f n_val_args
|| (in_arg && n_val_args == 0)
-- A naked un-applied variable is *not* deemed a static RHS
projects / ghc-hetmet.git / blobdiff