2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
6 CoreSyn: A data type for the Haskell compiler midsection
10 Expr(..), Alt, Bind(..), AltCon(..), Arg, Note(..),
11 CoreExpr, CoreAlt, CoreBind, CoreArg, CoreBndr,
12 TaggedExpr, TaggedAlt, TaggedBind, TaggedArg, TaggedBndr(..),
15 mkApps, mkTyApps, mkValApps, mkVarApps,
16 mkLit, mkIntLitInt, mkIntLit,
18 varToCoreExpr, varsToCoreExprs,
20 isTyVar, isId, cmpAltCon, cmpAlt, ltAlt,
21 bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts,
22 collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders,
27 isValArg, isTypeArg, valArgCount, valBndrCount, isRuntimeArg, isRuntimeVar,
30 Unfolding(..), UnfoldingGuidance(..), -- Both abstract everywhere but in CoreUnfold.lhs
31 noUnfolding, evaldUnfolding, mkOtherCon,
32 unfoldingTemplate, maybeUnfoldingTemplate, otherCons,
33 isValueUnfolding, isEvaldUnfolding, isCheapUnfolding, isCompulsoryUnfolding,
34 hasUnfolding, hasSomeUnfolding, neverUnfold,
37 seqExpr, seqExprs, seqUnfolding,
39 -- Annotated expressions
40 AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt,
41 deAnnotate, deAnnotate', deAnnAlt, collectAnnBndrs,
44 CoreRule(..), -- CoreSubst, CoreTidy, CoreFVs, PprCore only
45 RuleName, seqRules, ruleArity,
46 isBuiltinRule, ruleName, isLocalRule, ruleIdName
49 #include "HsVersions.h"
64 infixl 4 `mkApps`, `mkValApps`, `mkTyApps`, `mkVarApps`
65 -- Left associative, so that we can say (f `mkTyApps` xs `mkVarApps` ys)
68 %************************************************************************
70 \subsection{The main data types}
72 %************************************************************************
74 These data types are the heart of the compiler
77 infixl 8 `App` -- App brackets to the left
79 data Expr b -- "b" for the type of binders,
82 | App (Expr b) (Arg b) -- See Note [CoreSyn let/app invariant]
84 | Let (Bind b) (Expr b) -- See [CoreSyn let/app invariant],
85 -- and [CoreSyn letrec invariant]
86 | Case (Expr b) b Type [Alt b] -- Binder gets bound to value of scrutinee
87 -- See Note [CoreSyn case invariants]
88 | Cast (Expr b) Coercion
90 | Type Type -- This should only show up at the top
93 type Arg b = Expr b -- Can be a Type
95 type Alt b = (AltCon, [b], Expr b) -- (DEFAULT, [], rhs) is the default alternative
97 data AltCon = DataAlt DataCon -- Invariant: the DataCon is always from
98 -- a *data* type, and never from a *newtype*
104 data Bind b = NonRec b (Expr b)
105 | Rec [(b, (Expr b))]
108 -------------------------- CoreSyn INVARIANTS ---------------------------
110 Note [CoreSyn top-level invariant]
111 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
112 * The RHSs of all top-level lets must be of LIFTED type.
114 Note [CoreSyn letrec invariant]
115 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
116 * The RHS of a letrec must be of LIFTED type.
118 Note [CoreSyn let/app invariant]
119 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
120 * The RHS of a non-recursive let, *and* the argument of an App,
121 may be of UNLIFTED type, but only if the expression
122 is ok-for-speculation. This means that the let can be floated around
123 without difficulty. e.g.
125 y::Int# = fac 4# not ok [use case instead]
126 This is intially enforced by DsUtils.mkDsLet and mkDsApp
128 Note [CoreSyn case invariants]
129 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
130 Invariant: The DEFAULT case must be *first*, if it occurs at all
132 Invariant: The remaining cases are in order of increasing
135 This makes finding the relevant constructor easy,
136 and makes comparison easier too
138 Invariant: The list of alternatives is ALWAYS EXHAUSTIVE,
139 meaning that it covers all cases that can occur
141 An "exhausive" case does not necessarily mention all constructors:
142 data Foo = Red | Green | Blue
146 other -> f (case x of
149 The inner case does not need a Red alternative, because x can't be Red at
153 Note [CoreSyn let goal]
154 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
155 * The simplifier tries to ensure that if the RHS of a let is a constructor
156 application, its arguments are trivial, so that the constructor can be
164 | InlineMe -- Instructs simplifer to treat the enclosed expression
165 -- as very small, and inline it at its call sites
167 | CoreNote String -- A generic core annotation, propagated but not used by GHC
169 -- NOTE: we also treat expressions wrapped in InlineMe as
170 -- 'cheap' and 'dupable' (in the sense of exprIsCheap, exprIsDupable)
171 -- What this means is that we obediently inline even things that don't
172 -- look like valuse. This is sometimes important:
175 -- Here, f looks like a redex, and we aren't going to inline (.) because it's
176 -- inside an INLINE, so it'll stay looking like a redex. Nevertheless, we
177 -- should inline f even inside lambdas. In effect, we should trust the programmer.
181 %************************************************************************
183 \subsection{Transformation rules}
185 %************************************************************************
187 The CoreRule type and its friends are dealt with mainly in CoreRules,
188 but CoreFVs, Subst, PprCore, CoreTidy also inspect the representation.
192 "local" if the function it is a rule for is defined in the
193 same module as the rule itself.
195 "orphan" if nothing on the LHS is defined in the same module
199 type RuleName = FastString
204 ru_act :: Activation, -- When the rule is active
206 -- Rough-matching stuff
207 -- see comments with InstEnv.Instance( is_cls, is_rough )
208 ru_fn :: Name, -- Name of the Id at the head of this rule
209 ru_rough :: [Maybe Name], -- Name at the head of each argument
211 -- Proper-matching stuff
212 -- see comments with InstEnv.Instance( is_tvs, is_tys )
213 ru_bndrs :: [CoreBndr], -- Forall'd variables
214 ru_args :: [CoreExpr], -- LHS args
216 -- And the right-hand side
220 ru_local :: Bool -- The fn at the head of the rule is
221 -- defined in the same module as the rule
224 | BuiltinRule { -- Built-in rules are used for constant folding
225 ru_name :: RuleName, -- and suchlike. It has no free variables.
226 ru_fn :: Name, -- Name of the Id at
227 -- the head of this rule
228 ru_nargs :: Int, -- Number of args that ru_try expects
229 ru_try :: [CoreExpr] -> Maybe CoreExpr }
231 isBuiltinRule (BuiltinRule {}) = True
232 isBuiltinRule _ = False
234 ruleArity :: CoreRule -> Int
235 ruleArity (BuiltinRule {ru_nargs = n}) = n
236 ruleArity (Rule {ru_args = args}) = length args
238 ruleName :: CoreRule -> RuleName
241 ruleIdName :: CoreRule -> Name
244 isLocalRule :: CoreRule -> Bool
245 isLocalRule = ru_local
249 %************************************************************************
253 %************************************************************************
255 The @Unfolding@ type is declared here to avoid numerous loops, but it
256 should be abstract everywhere except in CoreUnfold.lhs
262 | OtherCon [AltCon] -- It ain't one of these
263 -- (OtherCon xs) also indicates that something has been evaluated
264 -- and hence there's no point in re-evaluating it.
265 -- OtherCon [] is used even for non-data-type values
266 -- to indicated evaluated-ness. Notably:
267 -- data C = C !(Int -> Int)
268 -- case x of { C f -> ... }
269 -- Here, f gets an OtherCon [] unfolding.
271 | CompulsoryUnfolding CoreExpr -- There is no "original" definition,
272 -- so you'd better unfold.
274 | CoreUnfolding -- An unfolding with redundant cached information
275 CoreExpr -- Template; binder-info is correct
276 Bool -- True <=> top level binding
277 Bool -- exprIsHNF template (cached); it is ok to discard a `seq` on
279 Bool -- True <=> doesn't waste (much) work to expand inside an inlining
280 -- Basically it's exprIsCheap
281 UnfoldingGuidance -- Tells about the *size* of the template.
284 data UnfoldingGuidance
286 | UnfoldIfGoodArgs Int -- and "n" value args
288 [Int] -- Discount if the argument is evaluated.
289 -- (i.e., a simplification will definitely
290 -- be possible). One elt of the list per *value* arg.
292 Int -- The "size" of the unfolding; to be elaborated
295 Int -- Scrutinee discount: the discount to substract if the thing is in
296 -- a context (case (thing args) of ...),
297 -- (where there are the right number of arguments.)
299 noUnfolding = NoUnfolding
300 evaldUnfolding = OtherCon []
302 mkOtherCon = OtherCon
304 seqUnfolding :: Unfolding -> ()
305 seqUnfolding (CoreUnfolding e top b1 b2 g)
306 = seqExpr e `seq` top `seq` b1 `seq` b2 `seq` seqGuidance g
307 seqUnfolding other = ()
309 seqGuidance (UnfoldIfGoodArgs n ns a b) = n `seq` sum ns `seq` a `seq` b `seq` ()
310 seqGuidance other = ()
314 unfoldingTemplate :: Unfolding -> CoreExpr
315 unfoldingTemplate (CoreUnfolding expr _ _ _ _) = expr
316 unfoldingTemplate (CompulsoryUnfolding expr) = expr
317 unfoldingTemplate other = panic "getUnfoldingTemplate"
319 maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr
320 maybeUnfoldingTemplate (CoreUnfolding expr _ _ _ _) = Just expr
321 maybeUnfoldingTemplate (CompulsoryUnfolding expr) = Just expr
322 maybeUnfoldingTemplate other = Nothing
324 otherCons :: Unfolding -> [AltCon]
325 otherCons (OtherCon cons) = cons
328 isValueUnfolding :: Unfolding -> Bool
329 -- Returns False for OtherCon
330 isValueUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald
331 isValueUnfolding other = False
333 isEvaldUnfolding :: Unfolding -> Bool
334 -- Returns True for OtherCon
335 isEvaldUnfolding (OtherCon _) = True
336 isEvaldUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald
337 isEvaldUnfolding other = False
339 isCheapUnfolding :: Unfolding -> Bool
340 isCheapUnfolding (CoreUnfolding _ _ _ is_cheap _) = is_cheap
341 isCheapUnfolding other = False
343 isCompulsoryUnfolding :: Unfolding -> Bool
344 isCompulsoryUnfolding (CompulsoryUnfolding _) = True
345 isCompulsoryUnfolding other = False
347 hasUnfolding :: Unfolding -> Bool
348 hasUnfolding (CoreUnfolding _ _ _ _ _) = True
349 hasUnfolding (CompulsoryUnfolding _) = True
350 hasUnfolding other = False
352 hasSomeUnfolding :: Unfolding -> Bool
353 hasSomeUnfolding NoUnfolding = False
354 hasSomeUnfolding other = True
356 neverUnfold :: Unfolding -> Bool
357 neverUnfold NoUnfolding = True
358 neverUnfold (OtherCon _) = True
359 neverUnfold (CoreUnfolding _ _ _ _ UnfoldNever) = True
360 neverUnfold other = False
364 %************************************************************************
366 \subsection{The main data type}
368 %************************************************************************
371 -- The Ord is needed for the FiniteMap used in the lookForConstructor
372 -- in SimplEnv. If you declared that lookForConstructor *ignores*
373 -- constructor-applications with LitArg args, then you could get
376 instance Outputable AltCon where
377 ppr (DataAlt dc) = ppr dc
378 ppr (LitAlt lit) = ppr lit
379 ppr DEFAULT = ptext SLIT("__DEFAULT")
381 instance Show AltCon where
382 showsPrec p con = showsPrecSDoc p (ppr con)
384 cmpAlt :: Alt b -> Alt b -> Ordering
385 cmpAlt (con1, _, _) (con2, _, _) = con1 `cmpAltCon` con2
387 ltAlt :: Alt b -> Alt b -> Bool
388 ltAlt a1 a2 = case a1 `cmpAlt` a2 of { LT -> True; other -> False }
390 cmpAltCon :: AltCon -> AltCon -> Ordering
391 -- Compares AltCons within a single list of alternatives
392 cmpAltCon DEFAULT DEFAULT = EQ
393 cmpAltCon DEFAULT con = LT
395 cmpAltCon (DataAlt d1) (DataAlt d2) = dataConTag d1 `compare` dataConTag d2
396 cmpAltCon (DataAlt _) DEFAULT = GT
397 cmpAltCon (LitAlt l1) (LitAlt l2) = l1 `compare` l2
398 cmpAltCon (LitAlt _) DEFAULT = GT
400 cmpAltCon con1 con2 = WARN( True, text "Comparing incomparable AltCons" <+>
401 ppr con1 <+> ppr con2 )
406 %************************************************************************
408 \subsection{Useful synonyms}
410 %************************************************************************
416 type CoreExpr = Expr CoreBndr
417 type CoreArg = Arg CoreBndr
418 type CoreBind = Bind CoreBndr
419 type CoreAlt = Alt CoreBndr
422 Binders are ``tagged'' with a \tr{t}:
425 data TaggedBndr t = TB CoreBndr t -- TB for "tagged binder"
427 type TaggedBind t = Bind (TaggedBndr t)
428 type TaggedExpr t = Expr (TaggedBndr t)
429 type TaggedArg t = Arg (TaggedBndr t)
430 type TaggedAlt t = Alt (TaggedBndr t)
432 instance Outputable b => Outputable (TaggedBndr b) where
433 ppr (TB b l) = char '<' <> ppr b <> comma <> ppr l <> char '>'
435 instance Outputable b => OutputableBndr (TaggedBndr b) where
436 pprBndr _ b = ppr b -- Simple
440 %************************************************************************
442 \subsection{Core-constructing functions with checking}
444 %************************************************************************
447 mkApps :: Expr b -> [Arg b] -> Expr b
448 mkTyApps :: Expr b -> [Type] -> Expr b
449 mkValApps :: Expr b -> [Expr b] -> Expr b
450 mkVarApps :: Expr b -> [Var] -> Expr b
452 mkApps f args = foldl App f args
453 mkTyApps f args = foldl (\ e a -> App e (Type a)) f args
454 mkValApps f args = foldl (\ e a -> App e a) f args
455 mkVarApps f vars = foldl (\ e a -> App e (varToCoreExpr a)) f vars
457 mkLit :: Literal -> Expr b
458 mkIntLit :: Integer -> Expr b
459 mkIntLitInt :: Int -> Expr b
460 mkConApp :: DataCon -> [Arg b] -> Expr b
461 mkLets :: [Bind b] -> Expr b -> Expr b
462 mkLams :: [b] -> Expr b -> Expr b
465 mkConApp con args = mkApps (Var (dataConWorkId con)) args
467 mkLams binders body = foldr Lam body binders
468 mkLets binds body = foldr Let body binds
470 mkIntLit n = Lit (mkMachInt n)
471 mkIntLitInt n = Lit (mkMachInt (toInteger n))
473 varToCoreExpr :: CoreBndr -> Expr b
474 varToCoreExpr v | isId v = Var v
475 | otherwise = Type (mkTyVarTy v)
477 varsToCoreExprs :: [CoreBndr] -> [Expr b]
478 varsToCoreExprs vs = map varToCoreExpr vs
480 mkCast :: Expr b -> Coercion -> Expr b
481 mkCast e co = Cast e co
485 %************************************************************************
487 \subsection{Simple access functions}
489 %************************************************************************
492 bindersOf :: Bind b -> [b]
493 bindersOf (NonRec binder _) = [binder]
494 bindersOf (Rec pairs) = [binder | (binder, _) <- pairs]
496 bindersOfBinds :: [Bind b] -> [b]
497 bindersOfBinds binds = foldr ((++) . bindersOf) [] binds
499 rhssOfBind :: Bind b -> [Expr b]
500 rhssOfBind (NonRec _ rhs) = [rhs]
501 rhssOfBind (Rec pairs) = [rhs | (_,rhs) <- pairs]
503 rhssOfAlts :: [Alt b] -> [Expr b]
504 rhssOfAlts alts = [e | (_,_,e) <- alts]
506 flattenBinds :: [Bind b] -> [(b, Expr b)] -- Get all the lhs/rhs pairs
507 flattenBinds (NonRec b r : binds) = (b,r) : flattenBinds binds
508 flattenBinds (Rec prs1 : binds) = prs1 ++ flattenBinds binds
512 We often want to strip off leading lambdas before getting down to
513 business. @collectBinders@ is your friend.
515 We expect (by convention) type-, and value- lambdas in that
519 collectBinders :: Expr b -> ([b], Expr b)
520 collectTyBinders :: CoreExpr -> ([TyVar], CoreExpr)
521 collectValBinders :: CoreExpr -> ([Id], CoreExpr)
522 collectTyAndValBinders :: CoreExpr -> ([TyVar], [Id], CoreExpr)
527 go bs (Lam b e) = go (b:bs) e
528 go bs e = (reverse bs, e)
530 collectTyAndValBinders expr
533 (tvs, body1) = collectTyBinders expr
534 (ids, body) = collectValBinders body1
536 collectTyBinders expr
539 go tvs (Lam b e) | isTyVar b = go (b:tvs) e
540 go tvs e = (reverse tvs, e)
542 collectValBinders expr
545 go ids (Lam b e) | isId b = go (b:ids) e
546 go ids body = (reverse ids, body)
550 @collectArgs@ takes an application expression, returning the function
551 and the arguments to which it is applied.
554 collectArgs :: Expr b -> (Expr b, [Arg b])
558 go (App f a) as = go f (a:as)
562 coreExprCc gets the cost centre enclosing an expression, if any.
563 It looks inside lambdas because (scc "foo" \x.e) = \x.scc "foo" e
566 coreExprCc :: Expr b -> CostCentre
567 coreExprCc (Note (SCC cc) e) = cc
568 coreExprCc (Note other_note e) = coreExprCc e
569 coreExprCc (Lam _ e) = coreExprCc e
570 coreExprCc other = noCostCentre
575 %************************************************************************
577 \subsection{Predicates}
579 %************************************************************************
581 @isRuntimeVar v@ returns if (Lam v _) really becomes a lambda at runtime,
582 i.e. if type applications are actual lambdas because types are kept around
585 Similarly isRuntimeArg.
588 isRuntimeVar :: Var -> Bool
589 isRuntimeVar | opt_RuntimeTypes = \v -> True
590 | otherwise = \v -> isId v
592 isRuntimeArg :: CoreExpr -> Bool
593 isRuntimeArg | opt_RuntimeTypes = \e -> True
594 | otherwise = \e -> isValArg e
598 isValArg (Type _) = False
599 isValArg other = True
601 isTypeArg (Type _) = True
602 isTypeArg other = False
604 valBndrCount :: [CoreBndr] -> Int
606 valBndrCount (b : bs) | isId b = 1 + valBndrCount bs
607 | otherwise = valBndrCount bs
609 valArgCount :: [Arg b] -> Int
611 valArgCount (Type _ : args) = valArgCount args
612 valArgCount (other : args) = 1 + valArgCount args
616 %************************************************************************
618 \subsection{Seq stuff}
620 %************************************************************************
623 seqExpr :: CoreExpr -> ()
624 seqExpr (Var v) = v `seq` ()
625 seqExpr (Lit lit) = lit `seq` ()
626 seqExpr (App f a) = seqExpr f `seq` seqExpr a
627 seqExpr (Lam b e) = seqBndr b `seq` seqExpr e
628 seqExpr (Let b e) = seqBind b `seq` seqExpr e
629 seqExpr (Case e b t as) = seqExpr e `seq` seqBndr b `seq` seqType t `seq` seqAlts as
630 seqExpr (Cast e co) = seqExpr e `seq` seqType co
631 seqExpr (Note n e) = seqNote n `seq` seqExpr e
632 seqExpr (Type t) = seqType t
635 seqExprs (e:es) = seqExpr e `seq` seqExprs es
637 seqNote (CoreNote s) = s `seq` ()
640 seqBndr b = b `seq` ()
643 seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
645 seqBind (NonRec b e) = seqBndr b `seq` seqExpr e
646 seqBind (Rec prs) = seqPairs prs
649 seqPairs ((b,e):prs) = seqBndr b `seq` seqExpr e `seq` seqPairs prs
652 seqAlts ((c,bs,e):alts) = seqBndrs bs `seq` seqExpr e `seq` seqAlts alts
655 seqRules (Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs } : rules)
656 = seqBndrs bndrs `seq` seqExprs (rhs:args) `seq` seqRules rules
657 seqRules (BuiltinRule {} : rules) = seqRules rules
662 %************************************************************************
664 \subsection{Annotated core; annotation at every node in the tree}
666 %************************************************************************
669 type AnnExpr bndr annot = (annot, AnnExpr' bndr annot)
671 data AnnExpr' bndr annot
674 | AnnLam bndr (AnnExpr bndr annot)
675 | AnnApp (AnnExpr bndr annot) (AnnExpr bndr annot)
676 | AnnCase (AnnExpr bndr annot) bndr Type [AnnAlt bndr annot]
677 | AnnLet (AnnBind bndr annot) (AnnExpr bndr annot)
678 | AnnCast (AnnExpr bndr annot) Coercion
679 | AnnNote Note (AnnExpr bndr annot)
682 type AnnAlt bndr annot = (AltCon, [bndr], AnnExpr bndr annot)
684 data AnnBind bndr annot
685 = AnnNonRec bndr (AnnExpr bndr annot)
686 | AnnRec [(bndr, AnnExpr bndr annot)]
690 deAnnotate :: AnnExpr bndr annot -> Expr bndr
691 deAnnotate (_, e) = deAnnotate' e
693 deAnnotate' (AnnType t) = Type t
694 deAnnotate' (AnnVar v) = Var v
695 deAnnotate' (AnnLit lit) = Lit lit
696 deAnnotate' (AnnLam binder body) = Lam binder (deAnnotate body)
697 deAnnotate' (AnnApp fun arg) = App (deAnnotate fun) (deAnnotate arg)
698 deAnnotate' (AnnCast e co) = Cast (deAnnotate e) co
699 deAnnotate' (AnnNote note body) = Note note (deAnnotate body)
701 deAnnotate' (AnnLet bind body)
702 = Let (deAnnBind bind) (deAnnotate body)
704 deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs)
705 deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs]
707 deAnnotate' (AnnCase scrut v t alts)
708 = Case (deAnnotate scrut) v t (map deAnnAlt alts)
710 deAnnAlt :: AnnAlt bndr annot -> Alt bndr
711 deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs)
715 collectAnnBndrs :: AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot)
719 collect bs (_, AnnLam b body) = collect (b:bs) body
720 collect bs body = (reverse bs, body)