isTyVar, isId, cmpAltCon, cmpAlt, ltAlt,
bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts,
collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders,
- collectArgs,
- coreExprCc,
- flattenBinds,
+ collectArgs, coreExprCc,
+ mkTyBind, flattenBinds,
isValArg, isTypeArg, valArgCount, valBndrCount, isRuntimeArg, isRuntimeVar,
#include "HsVersions.h"
-import StaticFlags
import CostCentre
import Var
import Type
import BasicTypes
import FastString
import Outputable
+import Util
infixl 4 `mkApps`, `mkValApps`, `mkTyApps`, `mkVarApps`
-- Left associative, so that we can say (f `mkTyApps` xs `mkVarApps` ys)
Invariant: The list of alternatives is ALWAYS EXHAUSTIVE,
meaning that it covers all cases that can occur
- An "exhausive" case does not necessarily mention all constructors:
+ An "exhaustive" case does not necessarily mention all constructors:
data Foo = Red | Green | Blue
...case x of
Note [CoreSyn let goal]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+~~~~~~~~~~~~~~~~~~~~~~~
* The simplifier tries to ensure that if the RHS of a let is a constructor
application, its arguments are trivial, so that the constructor can be
inlined vigorously.
+Note [Type let]
+~~~~~~~~~~~~~~~
+We allow a *non-recursive* let to bind a type variable, thus
+ Let (NonRec tv (Type ty)) body
+This can be very convenient for postponing type substitutions until
+the next run of the simplifier.
+
+At the moment, the rest of the compiler only deals with type-let
+in a Let expression, rather than at top level. We may want to revist
+this choice.
+
\begin{code}
data Note
= SCC CostCentre
-- Locality
ru_local :: Bool -- The fn at the head of the rule is
-- defined in the same module as the rule
+ -- and is not an implicit Id (like a record sel
+ -- class op, or data con)
+ -- NB: ru_local is *not* used to decide orphan-hood
+ -- c.g. MkIface.coreRuleToIfaceRule
}
| BuiltinRule { -- Built-in rules are used for constant folding
ru_name :: RuleName, -- and suchlike. It has no free variables.
ru_fn :: Name, -- Name of the Id at
-- the head of this rule
- ru_nargs :: Int, -- Number of args that ru_try expects
+ ru_nargs :: Int, -- Number of args that ru_try expects,
+ -- including type args
ru_try :: [CoreExpr] -> Maybe CoreExpr }
+ -- This function does the rewrite. It given too many
+ -- arguments, it simply discards them; the returned CoreExpr
+ -- is just the rewrite of ru_fn applied to the first ru_nargs args
+ -- See Note [Extra args in rule matching] in Rules.lhs
+isBuiltinRule :: CoreRule -> Bool
isBuiltinRule (BuiltinRule {}) = True
isBuiltinRule _ = False
-- a context (case (thing args) of ...),
-- (where there are the right number of arguments.)
+noUnfolding, evaldUnfolding :: Unfolding
noUnfolding = NoUnfolding
evaldUnfolding = OtherCon []
+mkOtherCon :: [AltCon] -> Unfolding
mkOtherCon = OtherCon
seqUnfolding :: Unfolding -> ()
seqUnfolding (CoreUnfolding e top b1 b2 g)
= seqExpr e `seq` top `seq` b1 `seq` b2 `seq` seqGuidance g
-seqUnfolding other = ()
+seqUnfolding _ = ()
+seqGuidance :: UnfoldingGuidance -> ()
seqGuidance (UnfoldIfGoodArgs n ns a b) = n `seq` sum ns `seq` a `seq` b `seq` ()
-seqGuidance other = ()
+seqGuidance _ = ()
\end{code}
\begin{code}
unfoldingTemplate :: Unfolding -> CoreExpr
unfoldingTemplate (CoreUnfolding expr _ _ _ _) = expr
unfoldingTemplate (CompulsoryUnfolding expr) = expr
-unfoldingTemplate other = panic "getUnfoldingTemplate"
+unfoldingTemplate _ = panic "getUnfoldingTemplate"
maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr
maybeUnfoldingTemplate (CoreUnfolding expr _ _ _ _) = Just expr
maybeUnfoldingTemplate (CompulsoryUnfolding expr) = Just expr
-maybeUnfoldingTemplate other = Nothing
+maybeUnfoldingTemplate _ = Nothing
otherCons :: Unfolding -> [AltCon]
otherCons (OtherCon cons) = cons
-otherCons other = []
+otherCons _ = []
isValueUnfolding :: Unfolding -> Bool
-- Returns False for OtherCon
isValueUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald
-isValueUnfolding other = False
+isValueUnfolding _ = False
isEvaldUnfolding :: Unfolding -> Bool
-- Returns True for OtherCon
isEvaldUnfolding (OtherCon _) = True
isEvaldUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald
-isEvaldUnfolding other = False
+isEvaldUnfolding _ = False
isCheapUnfolding :: Unfolding -> Bool
isCheapUnfolding (CoreUnfolding _ _ _ is_cheap _) = is_cheap
-isCheapUnfolding other = False
+isCheapUnfolding _ = False
isCompulsoryUnfolding :: Unfolding -> Bool
isCompulsoryUnfolding (CompulsoryUnfolding _) = True
-isCompulsoryUnfolding other = False
+isCompulsoryUnfolding _ = False
hasUnfolding :: Unfolding -> Bool
hasUnfolding (CoreUnfolding _ _ _ _ _) = True
hasUnfolding (CompulsoryUnfolding _) = True
-hasUnfolding other = False
+hasUnfolding _ = False
hasSomeUnfolding :: Unfolding -> Bool
hasSomeUnfolding NoUnfolding = False
-hasSomeUnfolding other = True
+hasSomeUnfolding _ = True
neverUnfold :: Unfolding -> Bool
neverUnfold NoUnfolding = True
neverUnfold (OtherCon _) = True
neverUnfold (CoreUnfolding _ _ _ _ UnfoldNever) = True
-neverUnfold other = False
+neverUnfold _ = False
\end{code}
instance Outputable AltCon where
ppr (DataAlt dc) = ppr dc
ppr (LitAlt lit) = ppr lit
- ppr DEFAULT = ptext SLIT("__DEFAULT")
+ ppr DEFAULT = ptext (sLit "__DEFAULT")
instance Show AltCon where
showsPrec p con = showsPrecSDoc p (ppr con)
cmpAlt (con1, _, _) (con2, _, _) = con1 `cmpAltCon` con2
ltAlt :: Alt b -> Alt b -> Bool
-ltAlt a1 a2 = case a1 `cmpAlt` a2 of { LT -> True; other -> False }
+ltAlt a1 a2 = (a1 `cmpAlt` a2) == LT
cmpAltCon :: AltCon -> AltCon -> Ordering
-- Compares AltCons within a single list of alternatives
cmpAltCon DEFAULT DEFAULT = EQ
-cmpAltCon DEFAULT con = LT
+cmpAltCon DEFAULT _ = LT
cmpAltCon (DataAlt d1) (DataAlt d2) = dataConTag d1 `compare` dataConTag d2
cmpAltCon (DataAlt _) DEFAULT = GT
%************************************************************************
\begin{code}
+mkTyBind :: TyVar -> Type -> CoreBind
+mkTyBind tv ty = NonRec tv (Type ty)
+ -- Note [Type let]
+ -- A non-recursive let can bind a type variable
+
bindersOf :: Bind b -> [b]
bindersOf (NonRec binder _) = [binder]
bindersOf (Rec pairs) = [binder | (binder, _) <- pairs]
\begin{code}
coreExprCc :: Expr b -> CostCentre
-coreExprCc (Note (SCC cc) e) = cc
-coreExprCc (Note other_note e) = coreExprCc e
+coreExprCc (Note (SCC cc) _) = cc
+coreExprCc (Note _ e) = coreExprCc e
coreExprCc (Lam _ e) = coreExprCc e
-coreExprCc other = noCostCentre
+coreExprCc _ = noCostCentre
\end{code}
%* *
%************************************************************************
+At one time we optionally carried type arguments through to runtime.
@isRuntimeVar v@ returns if (Lam v _) really becomes a lambda at runtime,
i.e. if type applications are actual lambdas because types are kept around
-at runtime.
-
-Similarly isRuntimeArg.
+at runtime. Similarly isRuntimeArg.
\begin{code}
isRuntimeVar :: Var -> Bool
-isRuntimeVar | opt_RuntimeTypes = \v -> True
- | otherwise = \v -> isId v
+isRuntimeVar = isId
isRuntimeArg :: CoreExpr -> Bool
-isRuntimeArg | opt_RuntimeTypes = \e -> True
- | otherwise = \e -> isValArg e
-\end{code}
+isRuntimeArg = isValArg
-\begin{code}
+isValArg :: Expr b -> Bool
isValArg (Type _) = False
-isValArg other = True
+isValArg _ = True
+isTypeArg :: Expr b -> Bool
isTypeArg (Type _) = True
-isTypeArg other = False
+isTypeArg _ = False
valBndrCount :: [CoreBndr] -> Int
-valBndrCount [] = 0
-valBndrCount (b : bs) | isId b = 1 + valBndrCount bs
- | otherwise = valBndrCount bs
+valBndrCount = count isId
valArgCount :: [Arg b] -> Int
-valArgCount [] = 0
-valArgCount (Type _ : args) = valArgCount args
-valArgCount (other : args) = 1 + valArgCount args
+valArgCount = count isValArg
\end{code}
seqExpr (Note n e) = seqNote n `seq` seqExpr e
seqExpr (Type t) = seqType t
+seqExprs :: [CoreExpr] -> ()
seqExprs [] = ()
seqExprs (e:es) = seqExpr e `seq` seqExprs es
+seqNote :: Note -> ()
seqNote (CoreNote s) = s `seq` ()
-seqNote other = ()
+seqNote _ = ()
+seqBndr :: CoreBndr -> ()
seqBndr b = b `seq` ()
+seqBndrs :: [CoreBndr] -> ()
seqBndrs [] = ()
seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
+seqBind :: Bind CoreBndr -> ()
seqBind (NonRec b e) = seqBndr b `seq` seqExpr e
seqBind (Rec prs) = seqPairs prs
+seqPairs :: [(CoreBndr, CoreExpr)] -> ()
seqPairs [] = ()
seqPairs ((b,e):prs) = seqBndr b `seq` seqExpr e `seq` seqPairs prs
+seqAlts :: [CoreAlt] -> ()
seqAlts [] = ()
-seqAlts ((c,bs,e):alts) = seqBndrs bs `seq` seqExpr e `seq` seqAlts alts
+seqAlts ((c,bs,e):alts) = c `seq` seqBndrs bs `seq` seqExpr e `seq` seqAlts alts
+seqRules :: [CoreRule] -> ()
seqRules [] = ()
seqRules (Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs } : rules)
= seqBndrs bndrs `seq` seqExprs (rhs:args) `seq` seqRules rules
deAnnotate :: AnnExpr bndr annot -> Expr bndr
deAnnotate (_, e) = deAnnotate' e
+deAnnotate' :: AnnExpr' bndr annot -> Expr bndr
deAnnotate' (AnnType t) = Type t
deAnnotate' (AnnVar v) = Var v
deAnnotate' (AnnLit lit) = Lit lit