Utility functions on @Core@ syntax
\begin{code}
-{-# OPTIONS -w #-}
+{-# OPTIONS -fno-warn-incomplete-patterns #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
-- for details
+-- | Commonly useful utilites for manipulating the Core language
module CoreUtils (
- -- Construction
+ -- * Constructing expressions
mkInlineMe, mkSCC, mkCoerce, mkCoerceI,
bindNonRec, needsCaseBinding,
- mkIfThenElse, mkAltExpr, mkPiType, mkPiTypes,
+ mkAltExpr, mkPiType, mkPiTypes,
- -- Taking expressions apart
+ -- * Taking expressions apart
findDefault, findAlt, isDefaultAlt, mergeAlts, trimConArgs,
- -- Properties of expressions
- exprType, coreAltType,
+ -- * Properties of expressions
+ exprType, coreAltType, coreAltsType,
exprIsDupable, exprIsTrivial, exprIsCheap,
exprIsHNF,exprOkForSpeculation, exprIsBig,
exprIsConApp_maybe, exprIsBottom,
rhsIsStatic,
- -- Arity and eta expansion
+ -- * Arity and eta expansion
manifestArity, exprArity,
exprEtaExpandArity, etaExpand,
- -- Size
- coreBindsSize,
+ -- * Expression and bindings size
+ coreBindsSize, exprSize,
- -- Hashing
+ -- * Hashing
hashExpr,
- -- Equality
- cheapEqExpr, tcEqExpr, tcEqExprX, applyTypeToArgs, applyTypeToArg,
+ -- * Equality
+ cheapEqExpr, tcEqExpr, tcEqExprX,
+ -- * Manipulating data constructors and types
+ applyTypeToArgs, applyTypeToArg,
dataConOrigInstPat, dataConRepInstPat, dataConRepFSInstPat
) where
import VarSet
import VarEnv
import Name
+import Module
#if mingw32_TARGET_OS
import Packages
#endif
import Type
import Coercion
import TyCon
-import TysWiredIn
import CostCentre
import BasicTypes
-import PackageConfig
import Unique
import Outputable
import DynFlags
\begin{code}
exprType :: CoreExpr -> Type
-
+-- ^ Recover the type of a well-typed Core expression. Fails when
+-- applied to the actual 'CoreSyn.Type' expression as it cannot
+-- really be said to have a type
exprType (Var var) = idType var
exprType (Lit lit) = literalType lit
exprType (Let _ body) = exprType body
-exprType (Case _ _ ty alts) = ty
-exprType (Cast e co) = snd (coercionKind co)
-exprType (Note other_note e) = exprType e
+exprType (Case _ _ ty _) = ty
+exprType (Cast _ co) = snd (coercionKind co)
+exprType (Note _ e) = exprType e
exprType (Lam binder expr) = mkPiType binder (exprType expr)
exprType e@(App _ _)
= case collectArgs e of
exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy
coreAltType :: CoreAlt -> Type
+-- ^ Returns the type of the alternatives right hand side
coreAltType (_,_,rhs) = exprType rhs
-\end{code}
-@mkPiType@ makes a (->) type or a forall type, depending on whether
-it is given a type variable or a term variable. We cleverly use the
-lbvarinfo field to figure out the right annotation for the arrove in
-case of a term variable.
+coreAltsType :: [CoreAlt] -> Type
+-- ^ Returns the type of the first alternative, which should be the same as for all alternatives
+coreAltsType (alt:_) = coreAltType alt
+coreAltsType [] = panic "corAltsType"
+\end{code}
\begin{code}
-mkPiType :: Var -> Type -> Type -- The more polymorphic version
-mkPiTypes :: [Var] -> Type -> Type -- doesn't work...
-
-mkPiTypes vs ty = foldr mkPiType ty vs
+mkPiType :: Var -> Type -> Type
+-- ^ Makes a @(->)@ type or a forall type, depending
+-- on whether it is given a type variable or a term variable.
+mkPiTypes :: [Var] -> Type -> Type
+-- ^ 'mkPiType' for multiple type or value arguments
mkPiType v ty
| isId v = mkFunTy (idType v) ty
| otherwise = mkForAllTy v ty
+
+mkPiTypes vs ty = foldr mkPiType ty vs
\end{code}
\begin{code}
applyTypeToArg :: Type -> CoreExpr -> Type
+-- ^ Determines the type resulting from applying an expression to a function with the given type
applyTypeToArg fun_ty (Type arg_ty) = applyTy fun_ty arg_ty
-applyTypeToArg fun_ty other_arg = funResultTy fun_ty
+applyTypeToArg fun_ty _ = funResultTy fun_ty
applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type
--- A more efficient version of applyTypeToArg
--- when we have several args
--- The first argument is just for debugging
-applyTypeToArgs e op_ty [] = op_ty
+-- ^ A more efficient version of 'applyTypeToArg' when we have several arguments.
+-- The first argument is just for debugging, and gives some context
+applyTypeToArgs _ op_ty [] = op_ty
applyTypeToArgs e op_ty (Type ty : args)
= -- Accumulate type arguments so we can instantiate all at once
go rev_tys (Type ty : args) = go (ty:rev_tys) args
go rev_tys rest_args = applyTypeToArgs e op_ty' rest_args
where
- op_ty' = applyTys op_ty (reverse rev_tys)
+ op_ty' = applyTysD msg op_ty (reverse rev_tys)
+ msg = ptext (sLit "applyTypeToArgs") <+>
+ panic_msg e op_ty
-applyTypeToArgs e op_ty (other_arg : args)
+applyTypeToArgs e op_ty (_ : args)
= case (splitFunTy_maybe op_ty) of
Just (_, res_ty) -> applyTypeToArgs e res_ty args
- Nothing -> pprPanic "applyTypeToArgs" (pprCoreExpr e $$ ppr op_ty)
-\end{code}
-
+ Nothing -> pprPanic "applyTypeToArgs" (panic_msg e op_ty)
+panic_msg :: CoreExpr -> Type -> SDoc
+panic_msg e op_ty = pprCoreExpr e $$ ppr op_ty
+\end{code}
%************************************************************************
%* *
But it hardly seems worth it, so I don't bother.
\begin{code}
+-- | Wraps the given expression in an inlining hint unless the expression
+-- is trivial in some sense, so that doing so would usually hurt us
+mkInlineMe :: CoreExpr -> CoreExpr
mkInlineMe (Var v) = Var v
mkInlineMe e = Note InlineMe e
\end{code}
-
-
\begin{code}
+-- | Wrap the given expression in the coercion, dropping identity coercions and coalescing nested coercions
mkCoerceI :: CoercionI -> CoreExpr -> CoreExpr
mkCoerceI IdCo e = e
mkCoerceI (ACo co) e = mkCoerce co e
+-- | Wrap the given expression in the coercion safely, coalescing nested coercions
mkCoerce :: Coercion -> CoreExpr -> CoreExpr
mkCoerce co (Cast expr co2)
= ASSERT(let { (from_ty, _to_ty) = coercionKind co;
mkCoerce (mkTransCoercion co2 co) expr
mkCoerce co expr
- = let (from_ty, to_ty) = coercionKind co in
+ = let (from_ty, _to_ty) = coercionKind co in
-- if to_ty `coreEqType` from_ty
-- then expr
-- else
\end{code}
\begin{code}
+-- | Wraps the given expression in the cost centre unless
+-- in a way that maximises their utility to the user
mkSCC :: CostCentre -> Expr b -> Expr b
-- Note: Nested SCC's *are* preserved for the benefit of
-- cost centre stack profiling
-mkSCC cc (Lit lit) = Lit lit
+mkSCC _ (Lit lit) = Lit lit
mkSCC cc (Lam x e) = Lam x (mkSCC cc e) -- Move _scc_ inside lambda
mkSCC cc (Note (SCC cc') e) = Note (SCC cc) (Note (SCC cc') e)
mkSCC cc (Note n e) = Note n (mkSCC cc e) -- Move _scc_ inside notes
\begin{code}
bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr
--- (bindNonRec x r b) produces either
--- let x = r in b
--- or
--- case r of x { _DEFAULT_ -> b }
+-- ^ @bindNonRec x r b@ produces either:
+--
+-- > let x = r in b
+--
+-- or:
--
--- depending on whether x is unlifted or not
+-- > case r of x { _DEFAULT_ -> b }
+--
+-- depending on whether we have to use a @case@ or @let@
+-- binding for the expression (see 'needsCaseBinding').
-- 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.
-
+-- that give Core Lint a heart attack, although actually
+-- the simplifier deals with them perfectly well. See
+-- also 'MkCore.mkCoreLet'
bindNonRec bndr rhs body
- | needsCaseBinding (idType bndr) rhs = Case rhs bndr (exprType body) [(DEFAULT,[],body)]
+ | needsCaseBinding (idType bndr) rhs = Case rhs bndr (exprType body) [(DEFAULT, [], body)]
| otherwise = Let (NonRec bndr rhs) body
+-- | Tests whether we have to use a @case@ rather than @let@ binding for this expression
+-- as per the invariants of 'CoreExpr': see "CoreSyn#let_app_invariant"
+needsCaseBinding :: Type -> CoreExpr -> Bool
needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs)
-- Make a case expression instead of a let
-- These can arise either from the desugarer,
\end{code}
\begin{code}
-mkAltExpr :: AltCon -> [CoreBndr] -> [Type] -> CoreExpr
- -- This guy constructs the value that the scrutinee must have
- -- when you are in one particular branch of a case
+mkAltExpr :: AltCon -- ^ Case alternative constructor
+ -> [CoreBndr] -- ^ Things bound by the pattern match
+ -> [Type] -- ^ The type arguments to the case alternative
+ -> CoreExpr
+-- ^ This guy constructs the value that the scrutinee must have
+-- given that you are in one particular branch of a case
mkAltExpr (DataAlt con) args inst_tys
= mkConApp con (map Type inst_tys ++ varsToCoreExprs args)
mkAltExpr (LitAlt lit) [] []
= Lit lit
mkAltExpr (LitAlt _) _ _ = panic "mkAltExpr LitAlt"
mkAltExpr DEFAULT _ _ = panic "mkAltExpr DEFAULT"
-
-mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
-mkIfThenElse guard then_expr else_expr
--- Not going to be refining, so okay to take the type of the "then" clause
- = Case guard (mkWildId boolTy) (exprType then_expr)
- [ (DataAlt falseDataCon, [], else_expr), -- Increasing order of tag!
- (DataAlt trueDataCon, [], then_expr) ]
\end{code}
This makes it easy to find, though it makes matching marginally harder.
\begin{code}
+-- | Extract the default case alternative
findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)
findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs)
findDefault alts = (alts, Nothing)
+-- | Find the case alternative corresponding to a particular
+-- constructor: panics if no such constructor exists
findAlt :: AltCon -> [CoreAlt] -> CoreAlt
findAlt con alts
= case alts of
(deflt@(DEFAULT,_,_):alts) -> go alts deflt
- other -> go alts panic_deflt
+ _ -> go alts panic_deflt
where
panic_deflt = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts))
isDefaultAlt :: CoreAlt -> Bool
isDefaultAlt (DEFAULT, _, _) = True
-isDefaultAlt other = False
+isDefaultAlt _ = False
---------------------------------
mergeAlts :: [CoreAlt] -> [CoreAlt] -> [CoreAlt]
--- Merge preserving order; alternatives in the first arg
--- shadow ones in the second
+-- ^ Merge alternatives preserving order; alternatives in
+-- the first argument shadow ones in the second
mergeAlts [] as2 = as2
mergeAlts as1 [] = as1
mergeAlts (a1:as1) (a2:as2)
---------------------------------
trimConArgs :: AltCon -> [CoreArg] -> [CoreArg]
--- Given case (C a b x y) of
--- C b x y -> ...
--- we want to drop the leading type argument of the scrutinee
+-- ^ Given:
+--
+-- > case (C a b x y) of
+-- > C b x y -> ...
+--
+-- We want to drop the leading type argument of the scrutinee
-- leaving the arguments to match agains the pattern
trimConArgs DEFAULT args = ASSERT( null args ) []
-trimConArgs (LitAlt lit) args = ASSERT( null args ) []
+trimConArgs (LitAlt _) args = ASSERT( null args ) []
trimConArgs (DataAlt dc) args = dropList (dataConUnivTyVars dc) args
\end{code}
applications. Note that primop Ids aren't considered
trivial unless
-@exprIsBottom@ is true of expressions that are guaranteed to diverge
-
-
There used to be a gruesome test for (hasNoBinding v) in the
Var case:
exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0
-The idea here is that a constructor worker, like $wJust, is
-really short for (\x -> $wJust x), becuase $wJust has no binding.
+The idea here is that a constructor worker, like \$wJust, is
+really short for (\x -> \$wJust x), becuase \$wJust has no binding.
So it should be treated like a lambda. Ditto unsaturated primops.
But now constructor workers are not "have-no-binding" Ids. And
completely un-applied primops and foreign-call Ids are sufficiently
b) see the note [SCC-and-exprIsTrivial] in Simplify.simplLazyBind
\begin{code}
-exprIsTrivial (Var v) = True -- See notes above
-exprIsTrivial (Type _) = True
-exprIsTrivial (Lit lit) = litIsTrivial lit
-exprIsTrivial (App e arg) = not (isRuntimeArg arg) && exprIsTrivial e
-exprIsTrivial (Note (SCC _) e) = False -- See notes above
+exprIsTrivial :: CoreExpr -> Bool
+exprIsTrivial (Var _) = True -- See notes above
+exprIsTrivial (Type _) = True
+exprIsTrivial (Lit lit) = litIsTrivial lit
+exprIsTrivial (App e arg) = not (isRuntimeArg arg) && exprIsTrivial e
+exprIsTrivial (Note (SCC _) _) = False -- See notes above
exprIsTrivial (Note _ e) = exprIsTrivial e
-exprIsTrivial (Cast e co) = exprIsTrivial e
-exprIsTrivial (Lam b body) = not (isRuntimeVar b) && exprIsTrivial body
-exprIsTrivial other = False
+exprIsTrivial (Cast e _) = exprIsTrivial e
+exprIsTrivial (Lam b body) = not (isRuntimeVar b) && exprIsTrivial body
+exprIsTrivial _ = False
\end{code}
\begin{code}
-exprIsDupable (Type _) = True
-exprIsDupable (Var v) = True
-exprIsDupable (Lit lit) = litIsDupable lit
-exprIsDupable (Note InlineMe e) = True
+exprIsDupable :: CoreExpr -> Bool
+exprIsDupable (Type _) = True
+exprIsDupable (Var _) = True
+exprIsDupable (Lit lit) = litIsDupable lit
+exprIsDupable (Note InlineMe _) = True
exprIsDupable (Note _ e) = exprIsDupable e
-exprIsDupable (Cast e co) = exprIsDupable e
-exprIsDupable expr
+exprIsDupable (Cast e _) = exprIsDupable e
+exprIsDupable expr
= go expr 0
where
- go (Var v) n_args = True
+ go (Var _) _ = True
go (App f a) n_args = n_args < dupAppSize
&& exprIsDupable a
&& go f (n_args+1)
- go other n_args = False
+ go _ _ = False
dupAppSize :: Int
dupAppSize = 4 -- Size of application we are prepared to duplicate
\begin{code}
exprIsCheap :: CoreExpr -> Bool
-exprIsCheap (Lit lit) = True
+exprIsCheap (Lit _) = True
exprIsCheap (Type _) = True
exprIsCheap (Var _) = True
-exprIsCheap (Note InlineMe e) = True
+exprIsCheap (Note InlineMe _) = True
exprIsCheap (Note _ e) = exprIsCheap e
-exprIsCheap (Cast e co) = exprIsCheap e
+exprIsCheap (Cast e _) = exprIsCheap e
exprIsCheap (Lam x e) = isRuntimeVar x || exprIsCheap e
exprIsCheap (Case e _ _ alts) = exprIsCheap e &&
and [exprIsCheap rhs | (_,_,rhs) <- alts]
go (App f a) val_args | isRuntimeArg a = go f (a:val_args)
| otherwise = go f val_args
- go (Var f) [] = True -- Just a type application of a variable
+ go (Var _) [] = True -- Just a type application of a variable
-- (f t1 t2 t3) counts as WHNF
go (Var f) args
= case globalIdDetails f of
PrimOpId op -> go_primop op args
DataConWorkId _ -> go_pap args
- other | length args < idArity f -> go_pap args
+ _ | length args < idArity f -> go_pap args
- other -> isBottomingId f
+ _ -> isBottomingId f
-- Application of a function which
-- always gives bottom; we treat this as cheap
-- because it certainly doesn't need to be shared!
- go other args = False
+ go _ _ = False
--------------
go_pap args = all exprIsTrivial args
--------------
go_sel [arg] = exprIsCheap arg -- I'm experimenting with making record selection
- go_sel other = False -- look cheap, so we will substitute it inside a
+ go_sel _ = False -- 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)
\end{code}
-exprOkForSpeculation returns True of an expression that it is
-
- * safe to evaluate even if normal order eval might not
- evaluate the expression at all, or
-
- * safe *not* to evaluate even if normal order would do so
-
-It returns True iff
-
- the expression guarantees to terminate,
- soon,
- without raising an exception,
- without causing a side effect (e.g. writing a mutable variable)
-
-NB: if exprIsHNF e, then exprOkForSpecuation e
-
-E.G.
- let x = case y# +# 1# of { r# -> I# r# }
- in E
-==>
- case y# +# 1# of { r# ->
- let x = I# r#
- in E
- }
-
-We can only do this if the (y+1) is ok for speculation: it has no
-side effects, and can't diverge or raise an exception.
-
\begin{code}
+-- | 'exprOkForSpeculation' returns True of an expression that is:
+--
+-- * Safe to evaluate even if normal order eval might not
+-- evaluate the expression at all, or
+--
+-- * Safe /not/ to evaluate even if normal order would do so
+--
+-- Precisely, it returns @True@ iff:
+--
+-- * The expression guarantees to terminate,
+--
+-- * soon,
+--
+-- * without raising an exception,
+--
+-- * without causing a side effect (e.g. writing a mutable variable)
+--
+-- Note that if @exprIsHNF e@, then @exprOkForSpecuation e@.
+-- As an example of the considerations in this test, consider:
+--
+-- > let x = case y# +# 1# of { r# -> I# r# }
+-- > in E
+--
+-- being translated to:
+--
+-- > case y# +# 1# of { r# ->
+-- > let x = I# r#
+-- > in E
+-- > }
+--
+-- We can only do this if the @y + 1@ is ok for speculation: it has no
+-- side effects, and can't diverge or raise an exception.
exprOkForSpeculation :: CoreExpr -> Bool
exprOkForSpeculation (Lit _) = True
exprOkForSpeculation (Type _) = True
exprOkForSpeculation (Var v) = isUnLiftedType (idType v)
&& not (isTickBoxOp v)
exprOkForSpeculation (Note _ e) = exprOkForSpeculation e
-exprOkForSpeculation (Cast e co) = exprOkForSpeculation e
+exprOkForSpeculation (Cast e _) = exprOkForSpeculation e
exprOkForSpeculation other_expr
= case collectArgs other_expr of
(Var f, args) -> spec_ok (globalIdDetails f) args
- other -> False
+ _ -> False
where
- spec_ok (DataConWorkId _) args
+ spec_ok (DataConWorkId _) _
= True -- The strictness of the constructor has already
-- been expressed by its "wrapper", so we don't need
-- to take the arguments into account
-- A bit conservative: we don't really need
-- to care about lazy arguments, but this is easy
- spec_ok other args = False
+ spec_ok _ _ = False
+-- | True of dyadic operators that can fail only if the second arg is zero!
isDivOp :: PrimOp -> Bool
--- True of dyadic operators that can fail
--- only if the second arg is zero
-- This function probably belongs in PrimOp, or even in
-- an automagically generated file.. but it's such a
-- special case I thought I'd leave it here for now.
isDivOp IntegerDivModOp = True
isDivOp FloatDivOp = True
isDivOp DoubleDivOp = True
-isDivOp other = False
+isDivOp _ = False
\end{code}
-
\begin{code}
-exprIsBottom :: CoreExpr -> Bool -- True => definitely bottom
+-- | True of expressions that are guaranteed to diverge upon execution
+exprIsBottom :: CoreExpr -> Bool
exprIsBottom e = go 0 e
- where
- -- n is the number of args
- go n (Note _ e) = go n e
- go n (Cast e co) = 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 (Type _) = False
+ where
+ -- n is the number of args
+ go n (Note _ e) = go n e
+ go n (Cast e _) = go n e
+ go n (Let _ e) = go n e
+ go _ (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 _ (Lit _) = False
+ go _ (Lam _ _) = False
+ go _ (Type _) = False
idAppIsBottom :: Id -> Int -> Bool
idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args
\end{code}
-@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
-
- case x of _ -> e ===> e
-
-and to decide whether it's safe to discard a `seq`
-
-So, it does *not* treat variables as evaluated, unless they say they are.
-
-But it *does* treat partial applications and constructor applications
-as values, even if their arguments are non-trivial, provided the argument
-type is lifted;
- e.g. (:) (f x) (map f xs) is a value
- map (...redex...) is a value
-Because `seq` on such things completes immediately
-
-For unlifted argument types, we have to be careful:
- C (f x :: Int#)
-Suppose (f x) diverges; then C (f x) is not a value. However this can't
-happen: see CoreSyn Note [CoreSyn let/app invariant]. Args of unboxed
-type must be ok-for-speculation (or trivial).
-
\begin{code}
+
+-- | This returns true for expressions that are certainly /already/
+-- evaluated to /head/ normal form. This is used to decide whether it's ok
+-- to change:
+--
+-- > case x of _ -> e
+--
+-- into:
+--
+-- > e
+--
+-- and to decide whether it's safe to discard a 'seq'.
+-- So, it does /not/ treat variables as evaluated, unless they say they are.
+-- However, it /does/ treat partial applications and constructor applications
+-- as values, even if their arguments are non-trivial, provided the argument
+-- type is lifted. For example, both of these are values:
+--
+-- > (:) (f x) (map f xs)
+-- > map (...redex...)
+--
+-- Because 'seq' on such things completes immediately.
+--
+-- For unlifted argument types, we have to be careful:
+--
+-- > C (f x :: Int#)
+--
+-- Suppose @f x@ diverges; then @C (f x)@ is not a value. However this can't
+-- happen: see "CoreSyn#let_app_invariant". This invariant states that arguments of
+-- unboxed type must be ok-for-speculation (or trivial).
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,
-- A worry: what if an Id's unfolding is just itself:
-- then we could get an infinite loop...
-exprIsHNF (Lit l) = True
-exprIsHNF (Type ty) = True -- Types are honorary Values;
- -- we don't mind copying them
-exprIsHNF (Lam b e) = isRuntimeVar b || exprIsHNF e
-exprIsHNF (Note _ e) = exprIsHNF e
-exprIsHNF (Cast e co) = exprIsHNF e
+exprIsHNF (Lit _) = True
+exprIsHNF (Type _) = True -- Types are honorary Values;
+ -- we don't mind copying them
+exprIsHNF (Lam b e) = isRuntimeVar b || exprIsHNF e
+exprIsHNF (Note _ e) = exprIsHNF e
+exprIsHNF (Cast e _) = exprIsHNF e
exprIsHNF (App e (Type _)) = exprIsHNF e
exprIsHNF (App e a) = app_is_value e [a]
-exprIsHNF other = False
+exprIsHNF _ = False
-- There is at least one value argument
+app_is_value :: CoreExpr -> [CoreArg] -> Bool
app_is_value (Var fun) args
= idArity fun > valArgCount args -- Under-applied function
|| isDataConWorkId fun -- or data constructor
-app_is_value (Note n f) as = app_is_value f as
+app_is_value (Note _ f) as = app_is_value f as
app_is_value (Cast f _) as = app_is_value f as
app_is_value (App f a) as = app_is_value f (a:as)
-app_is_value other as = False
+app_is_value _ _ = False
\end{code}
+These InstPat functions go here to avoid circularity between DataCon and Id
+
\begin{code}
--- These InstPat functions go here to avoid circularity between DataCon and Id
-dataConRepInstPat = dataConInstPat dataConRepArgTys (repeat (FSLIT("ipv")))
+dataConRepInstPat, dataConOrigInstPat :: [Unique] -> DataCon -> [Type] -> ([TyVar], [CoVar], [Id])
+dataConRepFSInstPat :: [FastString] -> [Unique] -> DataCon -> [Type] -> ([TyVar], [CoVar], [Id])
+
+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
-- ...
--
-- has representation type
--- forall a. forall a1. forall b. (a :=: (a1,b)) =>
+-- forall a. forall a1. forall b. (a ~ (a1,b)) =>
-- Int -> b -> T a
--
-- dataConInstPat fss us T1 (a1',b') will return
--
--- ([a1'', b''], [c :: (a1', b'):=:(a1'', b'')], [x :: Int, y :: b''])
+-- ([a1'', b''], [c :: (a1', b')~(a1'', b'')], [x :: Int, y :: b''])
--
-- where the double-primed variables are created with the FastStrings and
-- Uniques given as fss and us
mk_id_var uniq fs ty = mkUserLocal (mkVarOccFS fs) uniq (substTy subst ty) noSrcSpan
arg_ids = zipWith3 mk_id_var id_uniqs id_fss arg_tys
+-- | Returns @Just (dc, [x1..xn])@ if the argument expression is
+-- a constructor application of the form @dc x1 .. xn@
exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
--- Returns (Just (dc, [x1..xn])) if the argument expression is
--- a constructor application of the form (dc x1 .. xn)
exprIsConApp_maybe (Cast expr co)
- = -- Here we do the PushC reduction rule as described in the FC paper
+ = -- Here we do the KPush reduction rule as described in the FC paper
case exprIsConApp_maybe expr of {
Nothing -> Nothing ;
Just (dc, dc_args) ->
-- The transformation applies iff we have
-- (C e1 ... en) `cast` co
- -- where co :: (T t1 .. tn) :=: (T s1 ..sn)
+ -- where co :: (T t1 .. tn) ~ (T s1 ..sn)
-- That is, with a T at the top of both sides
-- The left-hand one must be a T, because exprIsConApp returned True
-- but the right-hand one might not be. (Though it usually will.)
let
tc_arity = tyConArity from_tc
- (univ_args, rest1) = splitAt tc_arity dc_args
- (ex_args, rest2) = splitAt n_ex_tvs rest1
- (co_args, val_args) = splitAt n_cos rest2
+ (univ_args, rest1) = splitAt tc_arity dc_args
+ (ex_args, rest2) = splitAt n_ex_tvs rest1
+ (co_args_spec, rest3) = splitAt n_cos_spec rest2
+ (co_args_theta, val_args) = splitAt n_cos_theta rest3
arg_tys = dataConRepArgTys dc
dc_univ_tyvars = dataConUnivTyVars dc
dc_ex_tyvars = dataConExTyVars dc
dc_eq_spec = dataConEqSpec dc
+ dc_eq_theta = dataConEqTheta dc
dc_tyvars = dc_univ_tyvars ++ dc_ex_tyvars
n_ex_tvs = length dc_ex_tyvars
- n_cos = length dc_eq_spec
+ n_cos_spec = length dc_eq_spec
+ n_cos_theta = length dc_eq_theta
-- Make the "theta" from Fig 3 of the paper
gammas = decomposeCo tc_arity co
theta = zipOpenTvSubst dc_tyvars new_tys
-- First we cast the existential coercion arguments
- cast_co (tv,ty) (Type co) = Type $ mkSymCoercion (substTyVar theta tv)
- `mkTransCoercion` co
- `mkTransCoercion` (substTy theta ty)
- new_co_args = zipWith cast_co dc_eq_spec co_args
+ cast_co_spec (tv, ty) co
+ = cast_co_theta (mkEqPred (mkTyVarTy tv, ty)) co
+ cast_co_theta eqPred (Type co)
+ | (ty1, ty2) <- getEqPredTys eqPred
+ = Type $ mkSymCoercion (substTy theta ty1)
+ `mkTransCoercion` co
+ `mkTransCoercion` (substTy theta ty2)
+ new_co_args = zipWith cast_co_spec dc_eq_spec co_args_spec ++
+ zipWith cast_co_theta dc_eq_theta co_args_theta
-- ...and now value arguments
new_val_args = zipWith cast_arg arg_tys val_args
isCheapUnfolding unf
= exprIsConApp_maybe (unfoldingTemplate unf)
- analyse other = Nothing
+ analyse _ = Nothing
\end{code}
%************************************************************************
\begin{code}
+-- ^ The Arity returned is the number of value args the
+-- expression can be applied to without doing much work
exprEtaExpandArity :: DynFlags -> CoreExpr -> Arity
-{- The Arity returned is the number of value args the
- thing can be applied to without doing much work
-
+{-
exprEtaExpandArity is used when eta expanding
e ==> \xy -> e x y
arityDepth :: ArityType -> Arity
arityDepth (AFun _ ty) = 1 + arityDepth ty
-arityDepth ty = 0
+arityDepth _ = 0
-andArityType ABot at2 = at2
-andArityType ATop at2 = ATop
+andArityType :: ArityType -> ArityType -> ArityType
+andArityType ABot at2 = at2
+andArityType ATop _ = ATop
andArityType (AFun t1 at1) (AFun t2 at2) = AFun (t1 && t2) (andArityType at1 at2)
-andArityType at1 at2 = andArityType at2 at1
+andArityType at1 at2 = andArityType at2 at1
arityType :: DynFlags -> CoreExpr -> ArityType
-- (go1 e) = [b1,..,bn]
-- means expression can be rewritten \x_b1 -> ... \x_bn -> body
-- where bi is True <=> the lambda is one-shot
-arityType dflags (Note n e) = arityType dflags e
+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 co) = arityType dflags e
+arityType dflags (Cast e _) = arityType dflags e
-arityType dflags (Var v)
+arityType _ (Var v)
= mk (idArity v) (arg_tys (idType v))
where
mk :: Arity -> [Type] -> ArityType
-- 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
- | (ty:tys) <- tys, isStateHackType ty = AFun True ATop
- | otherwise = ATop
+ mk 0 tys | isBottomingId v = ABot
+ | (ty:_) <- tys, isStateHackType ty = AFun True ATop
+ | otherwise = ATop
mk n (ty:tys) = AFun (isStateHackType ty) (mk (n-1) tys)
mk n [] = AFun False (mk (n-1) [])
-- Applications; decrease arity
arityType dflags (App f (Type _)) = arityType dflags f
-arityType dflags (App f a) = case arityType dflags f of
- AFun one_shot xs | exprIsCheap a -> xs
- other -> ATop
+arityType dflags (App f a)
+ = case arityType dflags f of
+ ABot -> ABot -- If function diverges, ignore argument
+ ATop -> ATop -- No no info about function
+ AFun _ xs
+ | exprIsCheap a -> xs
+ | otherwise -> ATop
-- Case/Let; keep arity if either the expression is cheap
-- or it's a 1-shot lambda
-- The difference is observable using 'seq'
arityType dflags (Case scrut _ _ alts)
= case foldr1 andArityType [arityType dflags rhs | (_,_,rhs) <- alts] of
- xs | exprIsCheap scrut -> xs
- xs@(AFun one_shot _) | one_shot -> AFun True ATop
- other -> ATop
+ xs | exprIsCheap scrut -> xs
+ AFun one_shot _ | one_shot -> AFun True ATop
+ _ -> ATop
arityType dflags (Let b e)
= case arityType dflags e of
- xs | cheap_bind b -> xs
- xs@(AFun one_shot _) | one_shot -> AFun True ATop
- other -> ATop
+ xs | cheap_bind b -> xs
+ AFun one_shot _ | one_shot -> AFun True ATop
+ _ -> ATop
where
cheap_bind (NonRec b e) = is_cheap (b,e)
cheap_bind (Rec prs) = all is_cheap prs
-- One could go further and make exprIsCheap reply True to any
-- dictionary-typed expression, but that's more work.
-arityType dflags other = ATop
+arityType _ _ = ATop
{- NOT NEEDED ANY MORE: etaExpand is cleverer
ok_note InlineMe = False
\begin{code}
-etaExpand :: Arity -- Result should have this number of value args
- -> [Unique]
- -> CoreExpr -> Type -- Expression and its type
- -> CoreExpr
--- (etaExpand n us e ty) returns an expression with
--- the same meaning as 'e', but with arity 'n'.
+-- | @etaExpand n us e ty@ returns an expression with
+-- the same meaning as @e@, but with arity @n@.
+--
+-- Given:
+--
+-- > e' = etaExpand n us e ty
--
--- Given e' = etaExpand n us e ty
--- We should have
--- ty = exprType e = exprType e'
+-- We should have that:
--
+-- > ty = exprType e = exprType e'
+etaExpand :: Arity -- ^ Result should have this number of value args
+ -> [Unique] -- ^ Uniques to assign to the new binders
+ -> CoreExpr -- ^ Expression to expand
+ -> Type -- ^ Type of expression to expand
+ -> CoreExpr
-- Note that SCCs are not treated specially. If we have
-- etaExpand 2 (\x -> scc "foo" e)
-- = (\xy -> (scc "foo" e) y)
| 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
| otherwise = manifestArity e
manifestArity (Note _ e) = manifestArity e
manifestArity (Cast e _) = manifestArity e
-manifestArity e = 0
+manifestArity _ = 0
-- etaExpand deals with for-alls. For example:
-- etaExpand 1 E
--
-- It deals with coerces too, though they are now rare
-- so perhaps the extra code isn't worth it
+eta_expand :: Int -> [Unique] -> CoreExpr -> Type -> CoreExpr
-eta_expand n us expr ty
+eta_expand n _ expr ty
| n == 0 &&
-- The ILX code generator requires eta expansion for type arguments
-- too, but alas the 'n' doesn't tell us how many of them there
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}
+-- | An approximate, fast, version of 'exprEtaExpandArity'
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 n e) = go e
- go (Cast e _) = go e
- go (App e (Type t)) = 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@ is a cheap equality test which bales out fast!
- True => definitely equal
- False => may or may not be equal
-
\begin{code}
+-- | A cheap equality test which bales out fast!
+-- If it returns @True@ the arguments are definitely equal,
+-- otherwise, they may or may not be equal.
+--
+-- See also 'exprIsBig'
cheapEqExpr :: Expr b -> Expr b -> Bool
cheapEqExpr (Var v1) (Var v2) = v1==v2
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
--- Returns True of expressions that are too big to be compared by cheapEqExpr
+-- ^ Returns @True@ of expressions that are too big to be compared by 'cheapEqExpr'
exprIsBig (Lit _) = False
-exprIsBig (Var v) = False
-exprIsBig (Type t) = False
+exprIsBig (Var _) = False
+exprIsBig (Type _) = False
exprIsBig (App f a) = exprIsBig f || exprIsBig a
exprIsBig (Cast e _) = exprIsBig e -- Hopefully coercions are not too big!
-exprIsBig other = True
+exprIsBig _ = True
\end{code}
\begin{code}
tcEqExpr :: CoreExpr -> CoreExpr -> Bool
--- Used in rule matching, so does *not* look through
--- newtypes, predicate types; hence tcEqExpr
+-- ^ A kind of shallow equality used in rule matching, so does
+-- /not/ look through newtypes or predicate types
tcEqExpr e1 e2 = tcEqExprX rn_env e1 e2
where
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 _ (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)
where
env' = rnBndr2 env v1 v2
-tcEqExprX env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && tcEqExprX env e1 e2
+tcEqExprX env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && tcEqExprX env e1 e2
tcEqExprX env (Cast e1 co1) (Cast e2 co2) = tcEqTypeX env co1 co2 && tcEqExprX env e1 e2
-tcEqExprX env (Type t1) (Type t2) = tcEqTypeX env t1 t2
-tcEqExprX env e1 e2 = False
-
+tcEqExprX env (Type t1) (Type t2) = tcEqTypeX env t1 t2
+tcEqExprX _ _ _ = False
+
+eq_alt :: RnEnv2 -> CoreAlt -> CoreAlt -> Bool
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 (CoreNote s1) (CoreNote s2) = s1 == s2
-eq_note env other1 other2 = False
+eq_note :: RnEnv2 -> Note -> Note -> Bool
+eq_note _ (SCC cc1) (SCC cc2) = cc1 == cc2
+eq_note _ (CoreNote s1) (CoreNote s2) = s1 == s2
+eq_note _ _ _ = False
\end{code}
coreBindsSize bs = foldr ((+) . bindSize) 0 bs
exprSize :: CoreExpr -> Int
- -- A measure of the size of the expressions
- -- It also forces the expression pretty drastically as a side effect
+-- ^ A measure of the size of the expressions, strictly greater than 0
+-- 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 (Note n e) = noteSize n + exprSize e
exprSize (Type t) = seqType t `seq` 1
+noteSize :: Note -> Int
noteSize (SCC cc) = cc `seq` 1
noteSize InlineMe = 1
noteSize (CoreNote s) = s `seq` 1 -- hdaume: core annotations
megaSeqIdInfo (idInfo b) `seq`
1
-varsSize = foldr ((+) . varSize) 0
+varsSize :: [Var] -> Int
+varsSize = sum . map varSize
+bindSize :: CoreBind -> Int
bindSize (NonRec b e) = varSize b + exprSize e
bindSize (Rec prs) = foldr ((+) . pairSize) 0 prs
+pairSize :: (Var, CoreExpr) -> Int
pairSize (b,e) = varSize b + exprSize e
+altSize :: CoreAlt -> Int
altSize (c,bs,e) = c `seq` varsSize bs + exprSize e
\end{code}
\begin{code}
hashExpr :: CoreExpr -> Int
--- Two expressions that hash to the same Int may be equal (but may not be)
--- Two expressions that hash to the different Ints are definitely unequal
---
--- But "unequal" here means "not identical"; two alpha-equivalent
--- expressions may hash to the different Ints
+-- ^ Two expressions that hash to the same @Int@ may be equal (but may not be)
+-- Two expressions that hash to the different Ints are definitely unequal.
--
--- The emphasis is on a crude, fast hash, rather than on high precision
+-- The emphasis is on a crude, fast hash, rather than on high precision.
+--
+-- But unequal here means \"not identical\"; two alpha-equivalent
+-- expressions may hash to the different Ints.
--
--- We must be careful that \x.x and \y.y map to the same hash code,
--- (at least if we want the above invariant to be true)
+-- We must be careful that @\\x.x@ and @\\y.y@ map to the same hash code,
+-- (at least if we want the above invariant to be true).
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
-- signed types just isn't cool. In C it's even undefined.
hash_expr env (Note _ e) = hash_expr env e
-hash_expr env (Cast e co) = hash_expr env e
+hash_expr env (Cast e _) = hash_expr env e
hash_expr env (Var v) = hashVar env v
-hash_expr env (Lit lit) = fromIntegral (hashLiteral lit)
+hash_expr _ (Lit lit) = fromIntegral (hashLiteral lit)
hash_expr env (App f e) = hash_expr env f * fast_hash_expr env e
hash_expr env (Let (NonRec b r) e) = hash_expr (extend_env env b) e * fast_hash_expr env r
-hash_expr env (Let (Rec ((b,r):_)) e) = hash_expr (extend_env env b) e
+hash_expr env (Let (Rec ((b,_):_)) e) = hash_expr (extend_env env b) e
hash_expr env (Case e _ _ _) = hash_expr env e
hash_expr env (Lam b e) = hash_expr (extend_env env b) e
-hash_expr env (Type t) = WARN(True, text "hash_expr: type") 1
+hash_expr _ (Type _) = WARN(True, text "hash_expr: type") 1
-- Shouldn't happen. Better to use WARN than trace, because trace
-- prevents the CPR optimisation kicking in for hash_expr.
+fast_hash_expr :: HashEnv -> CoreExpr -> Word32
fast_hash_expr env (Var v) = hashVar env v
fast_hash_expr env (Type t) = fast_hash_type env t
-fast_hash_expr env (Lit lit) = fromIntegral (hashLiteral lit)
-fast_hash_expr env (Cast e co) = fast_hash_expr env e
-fast_hash_expr env (Note n e) = fast_hash_expr env e
-fast_hash_expr env (App f a) = fast_hash_expr env a -- A bit idiosyncratic ('a' not 'f')!
-fast_hash_expr env other = 1
+fast_hash_expr _ (Lit lit) = fromIntegral (hashLiteral lit)
+fast_hash_expr env (Cast e _) = fast_hash_expr env e
+fast_hash_expr env (Note _ e) = fast_hash_expr env e
+fast_hash_expr env (App _ a) = fast_hash_expr env a -- A bit idiosyncratic ('a' not 'f')!
+fast_hash_expr _ _ = 1
fast_hash_type :: HashEnv -> Type -> Word32
fast_hash_type env ty
labels in other DLLs).
If this happens we simply make the RHS into an updatable thunk,
-and 'exectute' it rather than allocating it statically.
+and 'execute' it rather than allocating it statically.
\begin{code}
+-- | This function is called only on *top-level* right-hand sides.
+-- Returns @True@ if the RHS can be allocated statically in the output,
+-- with no thunks involved at all.
rhsIsStatic :: PackageId -> 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.
---
-- 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
is_static False (Lam b e) = isRuntimeVar b || is_static False e
- is_static in_arg (Note (SCC _) e) = False
+ is_static _ (Note (SCC _) _) = False
is_static in_arg (Note _ e) = is_static in_arg e
- is_static in_arg (Cast e co) = is_static in_arg e
+ is_static in_arg (Cast e _) = is_static in_arg e
- is_static in_arg (Lit lit)
+ is_static _ (Lit lit)
= case lit of
MachLabel _ _ -> False
- other -> True
+ _ -> 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
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)
-- x = D# (1.0## /## 2.0##)
-- can't float because /## can fail.
- go (Note (SCC _) f) n_val_args = False
- go (Note _ f) n_val_args = go f n_val_args
- go (Cast e co) n_val_args = go e n_val_args
+ go (Note (SCC _) _) _ = False
+ go (Note _ f) n_val_args = go f n_val_args
+ go (Cast e _) n_val_args = go e n_val_args
- go other n_val_args = False
+ go _ _ = False
saturated_data_con f n_val_args
= case isDataConWorkId_maybe f of