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
223 -- Orphan-hood; see Note [Orphans] in InstEnv
224 ru_orph :: Maybe OccName }
226 | BuiltinRule { -- Built-in rules are used for constant folding
227 ru_name :: RuleName, -- and suchlike. It has no free variables.
228 ru_fn :: Name, -- Name of the Id at
229 -- the head of this rule
230 ru_nargs :: Int, -- Number of args that ru_try expects
231 ru_try :: [CoreExpr] -> Maybe CoreExpr }
233 isBuiltinRule (BuiltinRule {}) = True
234 isBuiltinRule _ = False
236 ruleArity :: CoreRule -> Int
237 ruleArity (BuiltinRule {ru_nargs = n}) = n
238 ruleArity (Rule {ru_args = args}) = length args
240 ruleName :: CoreRule -> RuleName
243 ruleIdName :: CoreRule -> Name
246 isLocalRule :: CoreRule -> Bool
247 isLocalRule = ru_local
251 %************************************************************************
255 %************************************************************************
257 The @Unfolding@ type is declared here to avoid numerous loops, but it
258 should be abstract everywhere except in CoreUnfold.lhs
264 | OtherCon [AltCon] -- It ain't one of these
265 -- (OtherCon xs) also indicates that something has been evaluated
266 -- and hence there's no point in re-evaluating it.
267 -- OtherCon [] is used even for non-data-type values
268 -- to indicated evaluated-ness. Notably:
269 -- data C = C !(Int -> Int)
270 -- case x of { C f -> ... }
271 -- Here, f gets an OtherCon [] unfolding.
273 | CompulsoryUnfolding CoreExpr -- There is no "original" definition,
274 -- so you'd better unfold.
276 | CoreUnfolding -- An unfolding with redundant cached information
277 CoreExpr -- Template; binder-info is correct
278 Bool -- True <=> top level binding
279 Bool -- exprIsHNF template (cached); it is ok to discard a `seq` on
281 Bool -- True <=> doesn't waste (much) work to expand inside an inlining
282 -- Basically it's exprIsCheap
283 UnfoldingGuidance -- Tells about the *size* of the template.
286 data UnfoldingGuidance
288 | UnfoldIfGoodArgs Int -- and "n" value args
290 [Int] -- Discount if the argument is evaluated.
291 -- (i.e., a simplification will definitely
292 -- be possible). One elt of the list per *value* arg.
294 Int -- The "size" of the unfolding; to be elaborated
297 Int -- Scrutinee discount: the discount to substract if the thing is in
298 -- a context (case (thing args) of ...),
299 -- (where there are the right number of arguments.)
301 noUnfolding = NoUnfolding
302 evaldUnfolding = OtherCon []
304 mkOtherCon = OtherCon
306 seqUnfolding :: Unfolding -> ()
307 seqUnfolding (CoreUnfolding e top b1 b2 g)
308 = seqExpr e `seq` top `seq` b1 `seq` b2 `seq` seqGuidance g
309 seqUnfolding other = ()
311 seqGuidance (UnfoldIfGoodArgs n ns a b) = n `seq` sum ns `seq` a `seq` b `seq` ()
312 seqGuidance other = ()
316 unfoldingTemplate :: Unfolding -> CoreExpr
317 unfoldingTemplate (CoreUnfolding expr _ _ _ _) = expr
318 unfoldingTemplate (CompulsoryUnfolding expr) = expr
319 unfoldingTemplate other = panic "getUnfoldingTemplate"
321 maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr
322 maybeUnfoldingTemplate (CoreUnfolding expr _ _ _ _) = Just expr
323 maybeUnfoldingTemplate (CompulsoryUnfolding expr) = Just expr
324 maybeUnfoldingTemplate other = Nothing
326 otherCons :: Unfolding -> [AltCon]
327 otherCons (OtherCon cons) = cons
330 isValueUnfolding :: Unfolding -> Bool
331 -- Returns False for OtherCon
332 isValueUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald
333 isValueUnfolding other = False
335 isEvaldUnfolding :: Unfolding -> Bool
336 -- Returns True for OtherCon
337 isEvaldUnfolding (OtherCon _) = True
338 isEvaldUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald
339 isEvaldUnfolding other = False
341 isCheapUnfolding :: Unfolding -> Bool
342 isCheapUnfolding (CoreUnfolding _ _ _ is_cheap _) = is_cheap
343 isCheapUnfolding other = False
345 isCompulsoryUnfolding :: Unfolding -> Bool
346 isCompulsoryUnfolding (CompulsoryUnfolding _) = True
347 isCompulsoryUnfolding other = False
349 hasUnfolding :: Unfolding -> Bool
350 hasUnfolding (CoreUnfolding _ _ _ _ _) = True
351 hasUnfolding (CompulsoryUnfolding _) = True
352 hasUnfolding other = False
354 hasSomeUnfolding :: Unfolding -> Bool
355 hasSomeUnfolding NoUnfolding = False
356 hasSomeUnfolding other = True
358 neverUnfold :: Unfolding -> Bool
359 neverUnfold NoUnfolding = True
360 neverUnfold (OtherCon _) = True
361 neverUnfold (CoreUnfolding _ _ _ _ UnfoldNever) = True
362 neverUnfold other = False
366 %************************************************************************
368 \subsection{The main data type}
370 %************************************************************************
373 -- The Ord is needed for the FiniteMap used in the lookForConstructor
374 -- in SimplEnv. If you declared that lookForConstructor *ignores*
375 -- constructor-applications with LitArg args, then you could get
378 instance Outputable AltCon where
379 ppr (DataAlt dc) = ppr dc
380 ppr (LitAlt lit) = ppr lit
381 ppr DEFAULT = ptext SLIT("__DEFAULT")
383 instance Show AltCon where
384 showsPrec p con = showsPrecSDoc p (ppr con)
386 cmpAlt :: Alt b -> Alt b -> Ordering
387 cmpAlt (con1, _, _) (con2, _, _) = con1 `cmpAltCon` con2
389 ltAlt :: Alt b -> Alt b -> Bool
390 ltAlt a1 a2 = case a1 `cmpAlt` a2 of { LT -> True; other -> False }
392 cmpAltCon :: AltCon -> AltCon -> Ordering
393 -- Compares AltCons within a single list of alternatives
394 cmpAltCon DEFAULT DEFAULT = EQ
395 cmpAltCon DEFAULT con = LT
397 cmpAltCon (DataAlt d1) (DataAlt d2) = dataConTag d1 `compare` dataConTag d2
398 cmpAltCon (DataAlt _) DEFAULT = GT
399 cmpAltCon (LitAlt l1) (LitAlt l2) = l1 `compare` l2
400 cmpAltCon (LitAlt _) DEFAULT = GT
402 cmpAltCon con1 con2 = WARN( True, text "Comparing incomparable AltCons" <+>
403 ppr con1 <+> ppr con2 )
408 %************************************************************************
410 \subsection{Useful synonyms}
412 %************************************************************************
418 type CoreExpr = Expr CoreBndr
419 type CoreArg = Arg CoreBndr
420 type CoreBind = Bind CoreBndr
421 type CoreAlt = Alt CoreBndr
424 Binders are ``tagged'' with a \tr{t}:
427 data TaggedBndr t = TB CoreBndr t -- TB for "tagged binder"
429 type TaggedBind t = Bind (TaggedBndr t)
430 type TaggedExpr t = Expr (TaggedBndr t)
431 type TaggedArg t = Arg (TaggedBndr t)
432 type TaggedAlt t = Alt (TaggedBndr t)
434 instance Outputable b => Outputable (TaggedBndr b) where
435 ppr (TB b l) = char '<' <> ppr b <> comma <> ppr l <> char '>'
437 instance Outputable b => OutputableBndr (TaggedBndr b) where
438 pprBndr _ b = ppr b -- Simple
442 %************************************************************************
444 \subsection{Core-constructing functions with checking}
446 %************************************************************************
449 mkApps :: Expr b -> [Arg b] -> Expr b
450 mkTyApps :: Expr b -> [Type] -> Expr b
451 mkValApps :: Expr b -> [Expr b] -> Expr b
452 mkVarApps :: Expr b -> [Var] -> Expr b
454 mkApps f args = foldl App f args
455 mkTyApps f args = foldl (\ e a -> App e (Type a)) f args
456 mkValApps f args = foldl (\ e a -> App e a) f args
457 mkVarApps f vars = foldl (\ e a -> App e (varToCoreExpr a)) f vars
459 mkLit :: Literal -> Expr b
460 mkIntLit :: Integer -> Expr b
461 mkIntLitInt :: Int -> Expr b
462 mkConApp :: DataCon -> [Arg b] -> Expr b
463 mkLets :: [Bind b] -> Expr b -> Expr b
464 mkLams :: [b] -> Expr b -> Expr b
467 mkConApp con args = mkApps (Var (dataConWorkId con)) args
469 mkLams binders body = foldr Lam body binders
470 mkLets binds body = foldr Let body binds
472 mkIntLit n = Lit (mkMachInt n)
473 mkIntLitInt n = Lit (mkMachInt (toInteger n))
475 varToCoreExpr :: CoreBndr -> Expr b
476 varToCoreExpr v | isId v = Var v
477 | otherwise = Type (mkTyVarTy v)
479 varsToCoreExprs :: [CoreBndr] -> [Expr b]
480 varsToCoreExprs vs = map varToCoreExpr vs
482 mkCast :: Expr b -> Coercion -> Expr b
483 mkCast e co = Cast e co
487 %************************************************************************
489 \subsection{Simple access functions}
491 %************************************************************************
494 bindersOf :: Bind b -> [b]
495 bindersOf (NonRec binder _) = [binder]
496 bindersOf (Rec pairs) = [binder | (binder, _) <- pairs]
498 bindersOfBinds :: [Bind b] -> [b]
499 bindersOfBinds binds = foldr ((++) . bindersOf) [] binds
501 rhssOfBind :: Bind b -> [Expr b]
502 rhssOfBind (NonRec _ rhs) = [rhs]
503 rhssOfBind (Rec pairs) = [rhs | (_,rhs) <- pairs]
505 rhssOfAlts :: [Alt b] -> [Expr b]
506 rhssOfAlts alts = [e | (_,_,e) <- alts]
508 flattenBinds :: [Bind b] -> [(b, Expr b)] -- Get all the lhs/rhs pairs
509 flattenBinds (NonRec b r : binds) = (b,r) : flattenBinds binds
510 flattenBinds (Rec prs1 : binds) = prs1 ++ flattenBinds binds
514 We often want to strip off leading lambdas before getting down to
515 business. @collectBinders@ is your friend.
517 We expect (by convention) type-, and value- lambdas in that
521 collectBinders :: Expr b -> ([b], Expr b)
522 collectTyBinders :: CoreExpr -> ([TyVar], CoreExpr)
523 collectValBinders :: CoreExpr -> ([Id], CoreExpr)
524 collectTyAndValBinders :: CoreExpr -> ([TyVar], [Id], CoreExpr)
529 go bs (Lam b e) = go (b:bs) e
530 go bs e = (reverse bs, e)
532 collectTyAndValBinders expr
535 (tvs, body1) = collectTyBinders expr
536 (ids, body) = collectValBinders body1
538 collectTyBinders expr
541 go tvs (Lam b e) | isTyVar b = go (b:tvs) e
542 go tvs e = (reverse tvs, e)
544 collectValBinders expr
547 go ids (Lam b e) | isId b = go (b:ids) e
548 go ids body = (reverse ids, body)
552 @collectArgs@ takes an application expression, returning the function
553 and the arguments to which it is applied.
556 collectArgs :: Expr b -> (Expr b, [Arg b])
560 go (App f a) as = go f (a:as)
564 coreExprCc gets the cost centre enclosing an expression, if any.
565 It looks inside lambdas because (scc "foo" \x.e) = \x.scc "foo" e
568 coreExprCc :: Expr b -> CostCentre
569 coreExprCc (Note (SCC cc) e) = cc
570 coreExprCc (Note other_note e) = coreExprCc e
571 coreExprCc (Lam _ e) = coreExprCc e
572 coreExprCc other = noCostCentre
577 %************************************************************************
579 \subsection{Predicates}
581 %************************************************************************
583 @isRuntimeVar v@ returns if (Lam v _) really becomes a lambda at runtime,
584 i.e. if type applications are actual lambdas because types are kept around
587 Similarly isRuntimeArg.
590 isRuntimeVar :: Var -> Bool
591 isRuntimeVar | opt_RuntimeTypes = \v -> True
592 | otherwise = \v -> isId v
594 isRuntimeArg :: CoreExpr -> Bool
595 isRuntimeArg | opt_RuntimeTypes = \e -> True
596 | otherwise = \e -> isValArg e
600 isValArg (Type _) = False
601 isValArg other = True
603 isTypeArg (Type _) = True
604 isTypeArg other = False
606 valBndrCount :: [CoreBndr] -> Int
608 valBndrCount (b : bs) | isId b = 1 + valBndrCount bs
609 | otherwise = valBndrCount bs
611 valArgCount :: [Arg b] -> Int
613 valArgCount (Type _ : args) = valArgCount args
614 valArgCount (other : args) = 1 + valArgCount args
618 %************************************************************************
620 \subsection{Seq stuff}
622 %************************************************************************
625 seqExpr :: CoreExpr -> ()
626 seqExpr (Var v) = v `seq` ()
627 seqExpr (Lit lit) = lit `seq` ()
628 seqExpr (App f a) = seqExpr f `seq` seqExpr a
629 seqExpr (Lam b e) = seqBndr b `seq` seqExpr e
630 seqExpr (Let b e) = seqBind b `seq` seqExpr e
631 seqExpr (Case e b t as) = seqExpr e `seq` seqBndr b `seq` seqType t `seq` seqAlts as
632 seqExpr (Cast e co) = seqExpr e `seq` seqType co
633 seqExpr (Note n e) = seqNote n `seq` seqExpr e
634 seqExpr (Type t) = seqType t
637 seqExprs (e:es) = seqExpr e `seq` seqExprs es
639 seqNote (CoreNote s) = s `seq` ()
642 seqBndr b = b `seq` ()
645 seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
647 seqBind (NonRec b e) = seqBndr b `seq` seqExpr e
648 seqBind (Rec prs) = seqPairs prs
651 seqPairs ((b,e):prs) = seqBndr b `seq` seqExpr e `seq` seqPairs prs
654 seqAlts ((c,bs,e):alts) = seqBndrs bs `seq` seqExpr e `seq` seqAlts alts
657 seqRules (Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs } : rules)
658 = seqBndrs bndrs `seq` seqExprs (rhs:args) `seq` seqRules rules
659 seqRules (BuiltinRule {} : rules) = seqRules rules
664 %************************************************************************
666 \subsection{Annotated core; annotation at every node in the tree}
668 %************************************************************************
671 type AnnExpr bndr annot = (annot, AnnExpr' bndr annot)
673 data AnnExpr' bndr annot
676 | AnnLam bndr (AnnExpr bndr annot)
677 | AnnApp (AnnExpr bndr annot) (AnnExpr bndr annot)
678 | AnnCase (AnnExpr bndr annot) bndr Type [AnnAlt bndr annot]
679 | AnnLet (AnnBind bndr annot) (AnnExpr bndr annot)
680 | AnnCast (AnnExpr bndr annot) Coercion
681 | AnnNote Note (AnnExpr bndr annot)
684 type AnnAlt bndr annot = (AltCon, [bndr], AnnExpr bndr annot)
686 data AnnBind bndr annot
687 = AnnNonRec bndr (AnnExpr bndr annot)
688 | AnnRec [(bndr, AnnExpr bndr annot)]
692 deAnnotate :: AnnExpr bndr annot -> Expr bndr
693 deAnnotate (_, e) = deAnnotate' e
695 deAnnotate' (AnnType t) = Type t
696 deAnnotate' (AnnVar v) = Var v
697 deAnnotate' (AnnLit lit) = Lit lit
698 deAnnotate' (AnnLam binder body) = Lam binder (deAnnotate body)
699 deAnnotate' (AnnApp fun arg) = App (deAnnotate fun) (deAnnotate arg)
700 deAnnotate' (AnnCast e co) = Cast (deAnnotate e) co
701 deAnnotate' (AnnNote note body) = Note note (deAnnotate body)
703 deAnnotate' (AnnLet bind body)
704 = Let (deAnnBind bind) (deAnnotate body)
706 deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs)
707 deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs]
709 deAnnotate' (AnnCase scrut v t alts)
710 = Case (deAnnotate scrut) v t (map deAnnAlt alts)
712 deAnnAlt :: AnnAlt bndr annot -> Alt bndr
713 deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs)
717 collectAnnBndrs :: AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot)
721 collect bs (_, AnnLam b body) = collect (b:bs) body
722 collect bs body = (reverse bs, body)