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 -- The above warning supression flag is a temporary kludge.
11 -- While working on this module you are encouraged to remove it and fix
12 -- any warnings in the module. See
13 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
17 Expr(..), Alt, Bind(..), AltCon(..), Arg, Note(..),
18 CoreExpr, CoreAlt, CoreBind, CoreArg, CoreBndr,
19 TaggedExpr, TaggedAlt, TaggedBind, TaggedArg, TaggedBndr(..),
22 mkApps, mkTyApps, mkValApps, mkVarApps,
23 mkLit, mkIntLitInt, mkIntLit,
25 varToCoreExpr, varsToCoreExprs,
27 isTyVar, isId, cmpAltCon, cmpAlt, ltAlt,
28 bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts,
29 collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders,
34 isValArg, isTypeArg, valArgCount, valBndrCount, isRuntimeArg, isRuntimeVar,
37 Unfolding(..), UnfoldingGuidance(..), -- Both abstract everywhere but in CoreUnfold.lhs
38 noUnfolding, evaldUnfolding, mkOtherCon,
39 unfoldingTemplate, maybeUnfoldingTemplate, otherCons,
40 isValueUnfolding, isEvaldUnfolding, isCheapUnfolding, isCompulsoryUnfolding,
41 hasUnfolding, hasSomeUnfolding, neverUnfold,
44 seqExpr, seqExprs, seqUnfolding,
46 -- Annotated expressions
47 AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt,
48 deAnnotate, deAnnotate', deAnnAlt, collectAnnBndrs,
51 CoreRule(..), -- CoreSubst, CoreTidy, CoreFVs, PprCore only
52 RuleName, seqRules, ruleArity,
53 isBuiltinRule, ruleName, isLocalRule, ruleIdName
56 #include "HsVersions.h"
70 infixl 4 `mkApps`, `mkValApps`, `mkTyApps`, `mkVarApps`
71 -- Left associative, so that we can say (f `mkTyApps` xs `mkVarApps` ys)
74 %************************************************************************
76 \subsection{The main data types}
78 %************************************************************************
80 These data types are the heart of the compiler
83 infixl 8 `App` -- App brackets to the left
85 data Expr b -- "b" for the type of binders,
88 | App (Expr b) (Arg b) -- See Note [CoreSyn let/app invariant]
90 | Let (Bind b) (Expr b) -- See [CoreSyn let/app invariant],
91 -- and [CoreSyn letrec invariant]
92 | Case (Expr b) b Type [Alt b] -- Binder gets bound to value of scrutinee
93 -- See Note [CoreSyn case invariants]
94 | Cast (Expr b) Coercion
96 | Type Type -- This should only show up at the top
99 type Arg b = Expr b -- Can be a Type
101 type Alt b = (AltCon, [b], Expr b) -- (DEFAULT, [], rhs) is the default alternative
103 data AltCon = DataAlt DataCon -- Invariant: the DataCon is always from
104 -- a *data* type, and never from a *newtype*
110 data Bind b = NonRec b (Expr b)
111 | Rec [(b, (Expr b))]
114 -------------------------- CoreSyn INVARIANTS ---------------------------
116 Note [CoreSyn top-level invariant]
117 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
118 * The RHSs of all top-level lets must be of LIFTED type.
120 Note [CoreSyn letrec invariant]
121 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
122 * The RHS of a letrec must be of LIFTED type.
124 Note [CoreSyn let/app invariant]
125 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
126 * The RHS of a non-recursive let, *and* the argument of an App,
127 may be of UNLIFTED type, but only if the expression
128 is ok-for-speculation. This means that the let can be floated around
129 without difficulty. e.g.
131 y::Int# = fac 4# not ok [use case instead]
132 This is intially enforced by DsUtils.mkDsLet and mkDsApp
134 Note [CoreSyn case invariants]
135 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
136 Invariant: The DEFAULT case must be *first*, if it occurs at all
138 Invariant: The remaining cases are in order of increasing
141 This makes finding the relevant constructor easy,
142 and makes comparison easier too
144 Invariant: The list of alternatives is ALWAYS EXHAUSTIVE,
145 meaning that it covers all cases that can occur
147 An "exhausive" case does not necessarily mention all constructors:
148 data Foo = Red | Green | Blue
152 other -> f (case x of
155 The inner case does not need a Red alternative, because x can't be Red at
159 Note [CoreSyn let goal]
160 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
161 * The simplifier tries to ensure that if the RHS of a let is a constructor
162 application, its arguments are trivial, so that the constructor can be
170 | InlineMe -- Instructs simplifer to treat the enclosed expression
171 -- as very small, and inline it at its call sites
173 | CoreNote String -- A generic core annotation, propagated but not used by GHC
175 -- NOTE: we also treat expressions wrapped in InlineMe as
176 -- 'cheap' and 'dupable' (in the sense of exprIsCheap, exprIsDupable)
177 -- What this means is that we obediently inline even things that don't
178 -- look like valuse. This is sometimes important:
181 -- Here, f looks like a redex, and we aren't going to inline (.) because it's
182 -- inside an INLINE, so it'll stay looking like a redex. Nevertheless, we
183 -- should inline f even inside lambdas. In effect, we should trust the programmer.
187 %************************************************************************
189 \subsection{Transformation rules}
191 %************************************************************************
193 The CoreRule type and its friends are dealt with mainly in CoreRules,
194 but CoreFVs, Subst, PprCore, CoreTidy also inspect the representation.
198 "local" if the function it is a rule for is defined in the
199 same module as the rule itself.
201 "orphan" if nothing on the LHS is defined in the same module
205 type RuleName = FastString
210 ru_act :: Activation, -- When the rule is active
212 -- Rough-matching stuff
213 -- see comments with InstEnv.Instance( is_cls, is_rough )
214 ru_fn :: Name, -- Name of the Id at the head of this rule
215 ru_rough :: [Maybe Name], -- Name at the head of each argument
217 -- Proper-matching stuff
218 -- see comments with InstEnv.Instance( is_tvs, is_tys )
219 ru_bndrs :: [CoreBndr], -- Forall'd variables
220 ru_args :: [CoreExpr], -- LHS args
222 -- And the right-hand side
226 ru_local :: Bool -- The fn at the head of the rule is
227 -- defined in the same module as the rule
228 -- and is not an implicit Id (like a record sel
229 -- class op, or data con)
230 -- NB: ru_local is *not* used to decide orphan-hood
231 -- c.g. MkIface.coreRuleToIfaceRule
234 | BuiltinRule { -- Built-in rules are used for constant folding
235 ru_name :: RuleName, -- and suchlike. It has no free variables.
236 ru_fn :: Name, -- Name of the Id at
237 -- the head of this rule
238 ru_nargs :: Int, -- Number of args that ru_try expects,
239 -- including type args
240 ru_try :: [CoreExpr] -> Maybe CoreExpr }
241 -- This function does the rewrite. It given too many
242 -- arguments, it simply discards them; the returned CoreExpr
243 -- is just the rewrite of ru_fn applied to the first ru_nargs args
244 -- See Note [Extra args in rule matching] in Rules.lhs
246 isBuiltinRule (BuiltinRule {}) = True
247 isBuiltinRule _ = False
249 ruleArity :: CoreRule -> Int
250 ruleArity (BuiltinRule {ru_nargs = n}) = n
251 ruleArity (Rule {ru_args = args}) = length args
253 ruleName :: CoreRule -> RuleName
256 ruleIdName :: CoreRule -> Name
259 isLocalRule :: CoreRule -> Bool
260 isLocalRule = ru_local
264 %************************************************************************
268 %************************************************************************
270 The @Unfolding@ type is declared here to avoid numerous loops, but it
271 should be abstract everywhere except in CoreUnfold.lhs
277 | OtherCon [AltCon] -- It ain't one of these
278 -- (OtherCon xs) also indicates that something has been evaluated
279 -- and hence there's no point in re-evaluating it.
280 -- OtherCon [] is used even for non-data-type values
281 -- to indicated evaluated-ness. Notably:
282 -- data C = C !(Int -> Int)
283 -- case x of { C f -> ... }
284 -- Here, f gets an OtherCon [] unfolding.
286 | CompulsoryUnfolding CoreExpr -- There is no "original" definition,
287 -- so you'd better unfold.
289 | CoreUnfolding -- An unfolding with redundant cached information
290 CoreExpr -- Template; binder-info is correct
291 Bool -- True <=> top level binding
292 Bool -- exprIsHNF template (cached); it is ok to discard a `seq` on
294 Bool -- True <=> doesn't waste (much) work to expand inside an inlining
295 -- Basically it's exprIsCheap
296 UnfoldingGuidance -- Tells about the *size* of the template.
299 data UnfoldingGuidance
301 | UnfoldIfGoodArgs Int -- and "n" value args
303 [Int] -- Discount if the argument is evaluated.
304 -- (i.e., a simplification will definitely
305 -- be possible). One elt of the list per *value* arg.
307 Int -- The "size" of the unfolding; to be elaborated
310 Int -- Scrutinee discount: the discount to substract if the thing is in
311 -- a context (case (thing args) of ...),
312 -- (where there are the right number of arguments.)
314 noUnfolding = NoUnfolding
315 evaldUnfolding = OtherCon []
317 mkOtherCon = OtherCon
319 seqUnfolding :: Unfolding -> ()
320 seqUnfolding (CoreUnfolding e top b1 b2 g)
321 = seqExpr e `seq` top `seq` b1 `seq` b2 `seq` seqGuidance g
322 seqUnfolding other = ()
324 seqGuidance (UnfoldIfGoodArgs n ns a b) = n `seq` sum ns `seq` a `seq` b `seq` ()
325 seqGuidance other = ()
329 unfoldingTemplate :: Unfolding -> CoreExpr
330 unfoldingTemplate (CoreUnfolding expr _ _ _ _) = expr
331 unfoldingTemplate (CompulsoryUnfolding expr) = expr
332 unfoldingTemplate other = panic "getUnfoldingTemplate"
334 maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr
335 maybeUnfoldingTemplate (CoreUnfolding expr _ _ _ _) = Just expr
336 maybeUnfoldingTemplate (CompulsoryUnfolding expr) = Just expr
337 maybeUnfoldingTemplate other = Nothing
339 otherCons :: Unfolding -> [AltCon]
340 otherCons (OtherCon cons) = cons
343 isValueUnfolding :: Unfolding -> Bool
344 -- Returns False for OtherCon
345 isValueUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald
346 isValueUnfolding other = False
348 isEvaldUnfolding :: Unfolding -> Bool
349 -- Returns True for OtherCon
350 isEvaldUnfolding (OtherCon _) = True
351 isEvaldUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald
352 isEvaldUnfolding other = False
354 isCheapUnfolding :: Unfolding -> Bool
355 isCheapUnfolding (CoreUnfolding _ _ _ is_cheap _) = is_cheap
356 isCheapUnfolding other = False
358 isCompulsoryUnfolding :: Unfolding -> Bool
359 isCompulsoryUnfolding (CompulsoryUnfolding _) = True
360 isCompulsoryUnfolding other = False
362 hasUnfolding :: Unfolding -> Bool
363 hasUnfolding (CoreUnfolding _ _ _ _ _) = True
364 hasUnfolding (CompulsoryUnfolding _) = True
365 hasUnfolding other = False
367 hasSomeUnfolding :: Unfolding -> Bool
368 hasSomeUnfolding NoUnfolding = False
369 hasSomeUnfolding other = True
371 neverUnfold :: Unfolding -> Bool
372 neverUnfold NoUnfolding = True
373 neverUnfold (OtherCon _) = True
374 neverUnfold (CoreUnfolding _ _ _ _ UnfoldNever) = True
375 neverUnfold other = False
379 %************************************************************************
381 \subsection{The main data type}
383 %************************************************************************
386 -- The Ord is needed for the FiniteMap used in the lookForConstructor
387 -- in SimplEnv. If you declared that lookForConstructor *ignores*
388 -- constructor-applications with LitArg args, then you could get
391 instance Outputable AltCon where
392 ppr (DataAlt dc) = ppr dc
393 ppr (LitAlt lit) = ppr lit
394 ppr DEFAULT = ptext SLIT("__DEFAULT")
396 instance Show AltCon where
397 showsPrec p con = showsPrecSDoc p (ppr con)
399 cmpAlt :: Alt b -> Alt b -> Ordering
400 cmpAlt (con1, _, _) (con2, _, _) = con1 `cmpAltCon` con2
402 ltAlt :: Alt b -> Alt b -> Bool
403 ltAlt a1 a2 = case a1 `cmpAlt` a2 of { LT -> True; other -> False }
405 cmpAltCon :: AltCon -> AltCon -> Ordering
406 -- Compares AltCons within a single list of alternatives
407 cmpAltCon DEFAULT DEFAULT = EQ
408 cmpAltCon DEFAULT con = LT
410 cmpAltCon (DataAlt d1) (DataAlt d2) = dataConTag d1 `compare` dataConTag d2
411 cmpAltCon (DataAlt _) DEFAULT = GT
412 cmpAltCon (LitAlt l1) (LitAlt l2) = l1 `compare` l2
413 cmpAltCon (LitAlt _) DEFAULT = GT
415 cmpAltCon con1 con2 = WARN( True, text "Comparing incomparable AltCons" <+>
416 ppr con1 <+> ppr con2 )
421 %************************************************************************
423 \subsection{Useful synonyms}
425 %************************************************************************
431 type CoreExpr = Expr CoreBndr
432 type CoreArg = Arg CoreBndr
433 type CoreBind = Bind CoreBndr
434 type CoreAlt = Alt CoreBndr
437 Binders are ``tagged'' with a \tr{t}:
440 data TaggedBndr t = TB CoreBndr t -- TB for "tagged binder"
442 type TaggedBind t = Bind (TaggedBndr t)
443 type TaggedExpr t = Expr (TaggedBndr t)
444 type TaggedArg t = Arg (TaggedBndr t)
445 type TaggedAlt t = Alt (TaggedBndr t)
447 instance Outputable b => Outputable (TaggedBndr b) where
448 ppr (TB b l) = char '<' <> ppr b <> comma <> ppr l <> char '>'
450 instance Outputable b => OutputableBndr (TaggedBndr b) where
451 pprBndr _ b = ppr b -- Simple
455 %************************************************************************
457 \subsection{Core-constructing functions with checking}
459 %************************************************************************
462 mkApps :: Expr b -> [Arg b] -> Expr b
463 mkTyApps :: Expr b -> [Type] -> Expr b
464 mkValApps :: Expr b -> [Expr b] -> Expr b
465 mkVarApps :: Expr b -> [Var] -> Expr b
467 mkApps f args = foldl App f args
468 mkTyApps f args = foldl (\ e a -> App e (Type a)) f args
469 mkValApps f args = foldl (\ e a -> App e a) f args
470 mkVarApps f vars = foldl (\ e a -> App e (varToCoreExpr a)) f vars
472 mkLit :: Literal -> Expr b
473 mkIntLit :: Integer -> Expr b
474 mkIntLitInt :: Int -> Expr b
475 mkConApp :: DataCon -> [Arg b] -> Expr b
476 mkLets :: [Bind b] -> Expr b -> Expr b
477 mkLams :: [b] -> Expr b -> Expr b
480 mkConApp con args = mkApps (Var (dataConWorkId con)) args
482 mkLams binders body = foldr Lam body binders
483 mkLets binds body = foldr Let body binds
485 mkIntLit n = Lit (mkMachInt n)
486 mkIntLitInt n = Lit (mkMachInt (toInteger n))
488 varToCoreExpr :: CoreBndr -> Expr b
489 varToCoreExpr v | isId v = Var v
490 | otherwise = Type (mkTyVarTy v)
492 varsToCoreExprs :: [CoreBndr] -> [Expr b]
493 varsToCoreExprs vs = map varToCoreExpr vs
495 mkCast :: Expr b -> Coercion -> Expr b
496 mkCast e co = Cast e co
500 %************************************************************************
502 \subsection{Simple access functions}
504 %************************************************************************
507 bindersOf :: Bind b -> [b]
508 bindersOf (NonRec binder _) = [binder]
509 bindersOf (Rec pairs) = [binder | (binder, _) <- pairs]
511 bindersOfBinds :: [Bind b] -> [b]
512 bindersOfBinds binds = foldr ((++) . bindersOf) [] binds
514 rhssOfBind :: Bind b -> [Expr b]
515 rhssOfBind (NonRec _ rhs) = [rhs]
516 rhssOfBind (Rec pairs) = [rhs | (_,rhs) <- pairs]
518 rhssOfAlts :: [Alt b] -> [Expr b]
519 rhssOfAlts alts = [e | (_,_,e) <- alts]
521 flattenBinds :: [Bind b] -> [(b, Expr b)] -- Get all the lhs/rhs pairs
522 flattenBinds (NonRec b r : binds) = (b,r) : flattenBinds binds
523 flattenBinds (Rec prs1 : binds) = prs1 ++ flattenBinds binds
527 We often want to strip off leading lambdas before getting down to
528 business. @collectBinders@ is your friend.
530 We expect (by convention) type-, and value- lambdas in that
534 collectBinders :: Expr b -> ([b], Expr b)
535 collectTyBinders :: CoreExpr -> ([TyVar], CoreExpr)
536 collectValBinders :: CoreExpr -> ([Id], CoreExpr)
537 collectTyAndValBinders :: CoreExpr -> ([TyVar], [Id], CoreExpr)
542 go bs (Lam b e) = go (b:bs) e
543 go bs e = (reverse bs, e)
545 collectTyAndValBinders expr
548 (tvs, body1) = collectTyBinders expr
549 (ids, body) = collectValBinders body1
551 collectTyBinders expr
554 go tvs (Lam b e) | isTyVar b = go (b:tvs) e
555 go tvs e = (reverse tvs, e)
557 collectValBinders expr
560 go ids (Lam b e) | isId b = go (b:ids) e
561 go ids body = (reverse ids, body)
565 @collectArgs@ takes an application expression, returning the function
566 and the arguments to which it is applied.
569 collectArgs :: Expr b -> (Expr b, [Arg b])
573 go (App f a) as = go f (a:as)
577 coreExprCc gets the cost centre enclosing an expression, if any.
578 It looks inside lambdas because (scc "foo" \x.e) = \x.scc "foo" e
581 coreExprCc :: Expr b -> CostCentre
582 coreExprCc (Note (SCC cc) e) = cc
583 coreExprCc (Note other_note e) = coreExprCc e
584 coreExprCc (Lam _ e) = coreExprCc e
585 coreExprCc other = noCostCentre
590 %************************************************************************
592 \subsection{Predicates}
594 %************************************************************************
596 @isRuntimeVar v@ returns if (Lam v _) really becomes a lambda at runtime,
597 i.e. if type applications are actual lambdas because types are kept around
600 Similarly isRuntimeArg.
603 isRuntimeVar :: Var -> Bool
604 isRuntimeVar | opt_RuntimeTypes = \v -> True
605 | otherwise = \v -> isId v
607 isRuntimeArg :: CoreExpr -> Bool
608 isRuntimeArg | opt_RuntimeTypes = \e -> True
609 | otherwise = \e -> isValArg e
613 isValArg (Type _) = False
614 isValArg other = True
616 isTypeArg (Type _) = True
617 isTypeArg other = False
619 valBndrCount :: [CoreBndr] -> Int
621 valBndrCount (b : bs) | isId b = 1 + valBndrCount bs
622 | otherwise = valBndrCount bs
624 valArgCount :: [Arg b] -> Int
626 valArgCount (Type _ : args) = valArgCount args
627 valArgCount (other : args) = 1 + valArgCount args
631 %************************************************************************
633 \subsection{Seq stuff}
635 %************************************************************************
638 seqExpr :: CoreExpr -> ()
639 seqExpr (Var v) = v `seq` ()
640 seqExpr (Lit lit) = lit `seq` ()
641 seqExpr (App f a) = seqExpr f `seq` seqExpr a
642 seqExpr (Lam b e) = seqBndr b `seq` seqExpr e
643 seqExpr (Let b e) = seqBind b `seq` seqExpr e
644 seqExpr (Case e b t as) = seqExpr e `seq` seqBndr b `seq` seqType t `seq` seqAlts as
645 seqExpr (Cast e co) = seqExpr e `seq` seqType co
646 seqExpr (Note n e) = seqNote n `seq` seqExpr e
647 seqExpr (Type t) = seqType t
650 seqExprs (e:es) = seqExpr e `seq` seqExprs es
652 seqNote (CoreNote s) = s `seq` ()
655 seqBndr b = b `seq` ()
658 seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
660 seqBind (NonRec b e) = seqBndr b `seq` seqExpr e
661 seqBind (Rec prs) = seqPairs prs
664 seqPairs ((b,e):prs) = seqBndr b `seq` seqExpr e `seq` seqPairs prs
667 seqAlts ((c,bs,e):alts) = seqBndrs bs `seq` seqExpr e `seq` seqAlts alts
670 seqRules (Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs } : rules)
671 = seqBndrs bndrs `seq` seqExprs (rhs:args) `seq` seqRules rules
672 seqRules (BuiltinRule {} : rules) = seqRules rules
677 %************************************************************************
679 \subsection{Annotated core; annotation at every node in the tree}
681 %************************************************************************
684 type AnnExpr bndr annot = (annot, AnnExpr' bndr annot)
686 data AnnExpr' bndr annot
689 | AnnLam bndr (AnnExpr bndr annot)
690 | AnnApp (AnnExpr bndr annot) (AnnExpr bndr annot)
691 | AnnCase (AnnExpr bndr annot) bndr Type [AnnAlt bndr annot]
692 | AnnLet (AnnBind bndr annot) (AnnExpr bndr annot)
693 | AnnCast (AnnExpr bndr annot) Coercion
694 | AnnNote Note (AnnExpr bndr annot)
697 type AnnAlt bndr annot = (AltCon, [bndr], AnnExpr bndr annot)
699 data AnnBind bndr annot
700 = AnnNonRec bndr (AnnExpr bndr annot)
701 | AnnRec [(bndr, AnnExpr bndr annot)]
705 deAnnotate :: AnnExpr bndr annot -> Expr bndr
706 deAnnotate (_, e) = deAnnotate' e
708 deAnnotate' (AnnType t) = Type t
709 deAnnotate' (AnnVar v) = Var v
710 deAnnotate' (AnnLit lit) = Lit lit
711 deAnnotate' (AnnLam binder body) = Lam binder (deAnnotate body)
712 deAnnotate' (AnnApp fun arg) = App (deAnnotate fun) (deAnnotate arg)
713 deAnnotate' (AnnCast e co) = Cast (deAnnotate e) co
714 deAnnotate' (AnnNote note body) = Note note (deAnnotate body)
716 deAnnotate' (AnnLet bind body)
717 = Let (deAnnBind bind) (deAnnotate body)
719 deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs)
720 deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs]
722 deAnnotate' (AnnCase scrut v t alts)
723 = Case (deAnnotate scrut) v t (map deAnnAlt alts)
725 deAnnAlt :: AnnAlt bndr annot -> Alt bndr
726 deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs)
730 collectAnnBndrs :: AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot)
734 collect bs (_, AnnLam b body) = collect (b:bs) body
735 collect bs body = (reverse bs, body)