findDefault, findAlt,
-- Properties of expressions
- exprType,
+ exprType, coreAltType,
exprIsDupable, exprIsTrivial, exprIsCheap,
exprIsValue,exprOkForSpeculation, exprIsBig,
- exprIsConApp_maybe,
+ exprIsConApp_maybe, exprIsBottom,
rhsIsStatic,
-- Arity and eta expansion
import PprCore ( pprCoreExpr )
import Var ( Var, isId, isTyVar )
import VarEnv
-import Name ( hashName, isDllName )
+import Name ( hashName )
+import Packages ( isDllName )
+import CmdLineOpts ( DynFlags )
import Literal ( hashLiteral, literalType, litIsDupable,
litIsTrivial, isZeroLit, Literal( MachLabel ) )
import DataCon ( DataCon, dataConRepArity, dataConArgTys,
- isExistentialDataCon, dataConTyCon )
+ isVanillaDataCon, dataConTyCon )
import PrimOp ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap )
import Id ( Id, idType, globalIdDetails, idNewStrictness,
mkWildId, idArity, idName, idUnfolding, idInfo,
- isOneShotBndr, isDataConWorkId_maybe, mkSysLocal,
+ isOneShotBndr, isStateHackType, isDataConWorkId_maybe, mkSysLocal,
isDataConWorkId, isBottomingId
)
import IdInfo ( GlobalIdDetails(..), megaSeqIdInfo )
funResultTy, applyTy
)
import TyCon ( tyConArity )
+-- gaw 2004
import TysWiredIn ( boolTy, trueDataCon, falseDataCon )
import CostCentre ( CostCentre )
import BasicTypes ( Arity )
exprType (Var var) = idType var
exprType (Lit lit) = literalType lit
exprType (Let _ body) = exprType body
-exprType (Case _ _ alts) = coreAltsType alts
+-- gaw 2004
+exprType (Case _ _ ty alts) = ty
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 other = pprTrace "exprType" (pprCoreExpr other) alphaTy
-coreAltsType :: [CoreAlt] -> Type
-coreAltsType ((_,_,rhs) : _) = exprType rhs
+coreAltType :: CoreAlt -> Type
+coreAltType (_,_,rhs) = exprType rhs
\end{code}
@mkPiType@ makes a (->) type or a forall type, depending on whether
-- It's used by the desugarer to avoid building bindings
-- that give Core Lint a heart attack. Actually the simplifier
-- deals with them perfectly well.
+
bindNonRec bndr rhs body
- | needsCaseBinding (idType bndr) rhs = Case rhs bndr [(DEFAULT,[],body)]
+-- gaw 2004
+ | needsCaseBinding (idType bndr) rhs = Case rhs bndr (exprType body) [(DEFAULT,[],body)]
| otherwise = Let (NonRec bndr rhs) body
needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs)
mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
mkIfThenElse guard then_expr else_expr
- = Case guard (mkWildId boolTy)
+-- 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) ]
\end{code}
\begin{code}
exprIsCheap :: CoreExpr -> Bool
-exprIsCheap (Lit lit) = True
-exprIsCheap (Type _) = True
-exprIsCheap (Var _) = True
-exprIsCheap (Note InlineMe e) = True
-exprIsCheap (Note _ e) = exprIsCheap e
-exprIsCheap (Lam x e) = isRuntimeVar x || exprIsCheap e
-exprIsCheap (Case e _ alts) = exprIsCheap e &&
+exprIsCheap (Lit lit) = True
+exprIsCheap (Type _) = True
+exprIsCheap (Var _) = True
+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
-- (and case __coerce x etc.)
-- counts as WHNF
| otherwise = case globalIdDetails id of
DataConWorkId _ -> True
- RecordSelId _ -> True -- I'm experimenting with making record selection
+ 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
exprIsBottom e = go 0 e
where
-- n is the number of args
- go n (Note _ e) = go n e
- go n (Let _ e) = go n e
- 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 (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
idAppIsBottom :: Id -> Int -> Bool
idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args
case splitTyConApp_maybe to_ty of {
Nothing -> Nothing ;
- Just (tc, tc_arg_tys) | tc /= dataConTyCon dc -> Nothing
- | isExistentialDataCon dc -> Nothing
- | otherwise ->
+ Just (tc, tc_arg_tys) | tc /= dataConTyCon dc -> Nothing
+ | not (isVanillaDataCon dc) -> Nothing
+ | otherwise ->
-- Type constructor must match
-- We knock out existentials to keep matters simple(r)
let
-- | otherwise = ATop
arityType (Var v)
- = mk (idArity v)
+ = mk (idArity v) (arg_tys (idType v))
where
- mk :: Arity -> ArityType
- mk 0 | isBottomingId v = ABot
- | otherwise = ATop
- mk n = AFun False (mk (n-1))
-
- -- When the type of the Id encodes one-shot-ness,
- -- use the idinfo here
+ mk :: Arity -> [Type] -> ArityType
+ -- The argument types are only to steer the "state hack"
+ -- Consider case x of
+ -- True -> foo
+ -- False -> \(s:RealWorld) -> e
+ -- where foo has arity 1. Then we want the state hack to
+ -- apply to foo too, so we can eta expand the case.
+ mk 0 tys | isBottomingId v = ABot
+ | otherwise = ATop
+ mk n (ty:tys) = AFun (isStateHackType ty) (mk (n-1) tys)
+ mk n [] = AFun False (mk (n-1) [])
+
+ arg_tys :: Type -> [Type] -- Ignore for-alls
+ arg_tys ty
+ | Just (_, ty') <- splitForAllTy_maybe ty = arg_tys ty'
+ | Just (arg,res) <- splitFunTy_maybe ty = arg : arg_tys res
+ | otherwise = []
-- Lambdas; increase arity
arityType (Lam x e) | isId x = AFun (isOneShotBndr x) (arityType e)
-- ===>
-- f x y = case x of { (a,b) -> e }
-- The difference is observable using 'seq'
-arityType (Case scrut _ alts) = case foldr1 andArityType [arityType rhs | (_,_,rhs) <- alts] of
+-- 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
| otherwise -> ATop
where
env' = extendVarEnvList env [(v1,v2) | ((v1,_),(v2,_)) <- zip ps1 ps2]
eq_rhs (_,r1) (_,r2) = eq env' r1 r2
- eq env (Case e1 v1 a1)
- (Case e2 v2 a2) = eq env e1 e2 &&
+-- gaw 2004
+ 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)
where
exprSize :: CoreExpr -> Int
-- A measure of the size of the expressions
-- It also forces the expression pretty drastically as a side effect
-exprSize (Var v) = v `seq` 1
-exprSize (Lit lit) = lit `seq` 1
-exprSize (App f a) = exprSize f + exprSize a
-exprSize (Lam b e) = varSize b + exprSize e
-exprSize (Let b e) = bindSize b + exprSize e
-exprSize (Case e b as) = exprSize e + varSize b + foldr ((+) . altSize) 0 as
-exprSize (Note n e) = noteSize n + exprSize e
-exprSize (Type t) = seqType t `seq` 1
+exprSize (Var v) = v `seq` 1
+exprSize (Lit lit) = lit `seq` 1
+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
noteSize (SCC cc) = cc `seq` 1
noteSize (Coerce t1 t2) = seqType t1 `seq` seqType t2 `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
-hash_expr (Case _ b _) = 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
hash_expr (Lit lit) = hashLiteral lit
and 'exectute' it rather than allocating it statically.
\begin{code}
-rhsIsStatic :: CoreExpr -> Bool
+rhsIsStatic :: DynFlags -> 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.
-- When opt_RuntimeTypes is on, we keep type lambdas and treat
-- them as making the RHS re-entrant (non-updatable).
-rhsIsStatic rhs = is_static False rhs
-
-is_static :: Bool -- True <=> in a constructor argument; must be atomic
- -> CoreExpr -> Bool
-
-is_static False (Lam b e) = isRuntimeVar b || is_static False e
-
-is_static in_arg (Note (SCC _) e) = False
-is_static in_arg (Note _ e) = is_static in_arg e
-
-is_static in_arg (Lit lit)
- = case lit of
- MachLabel _ _ -> False
- other -> True
- -- A MachLabel (foreign import "&foo") in an argument
- -- prevents a constructor application from being static. The
- -- reason is that it might give rise to unresolvable symbols
- -- in the object file: under Linux, references to "weak"
- -- symbols from the data segment give rise to "unresolvable
- -- relocation" errors at link time This might be due to a bug
- -- in the linker, but we'll work around it here anyway.
- -- SDM 24/2/2004
-
-is_static in_arg other_expr = go other_expr 0
+rhsIsStatic dflags rhs = is_static False rhs
where
+ is_static :: Bool -- True <=> in a constructor argument; must be atomic
+ -> CoreExpr -> Bool
+
+ is_static False (Lam b e) = isRuntimeVar b || is_static False e
+
+ is_static in_arg (Note (SCC _) e) = False
+ is_static in_arg (Note _ e) = is_static in_arg e
+
+ is_static in_arg (Lit lit)
+ = case lit of
+ MachLabel _ _ -> False
+ other -> True
+ -- A MachLabel (foreign import "&foo") in an argument
+ -- prevents a constructor application from being static. The
+ -- reason is that it might give rise to unresolvable symbols
+ -- in the object file: under Linux, references to "weak"
+ -- symbols from the data segment give rise to "unresolvable
+ -- relocation" errors at link time This might be due to a bug
+ -- in the linker, but we'll work around it here anyway.
+ -- SDM 24/2/2004
+
+ is_static in_arg other_expr = go other_expr 0
+ where
go (Var f) n_val_args
- | not (isDllName (idName f))
+ | not (isDllName dflags (idName f))
= 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