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"
63 infixl 4 `mkApps`, `mkValApps`, `mkTyApps`, `mkVarApps`
64 -- Left associative, so that we can say (f `mkTyApps` xs `mkVarApps` ys)
67 %************************************************************************
69 \subsection{The main data types}
71 %************************************************************************
73 These data types are the heart of the compiler
76 infixl 8 `App` -- App brackets to the left
78 data Expr b -- "b" for the type of binders,
81 | App (Expr b) (Arg b) -- See Note [CoreSyn let/app invariant]
83 | Let (Bind b) (Expr b) -- See [CoreSyn let/app invariant],
84 -- and [CoreSyn letrec invariant]
85 | Case (Expr b) b Type [Alt b] -- Binder gets bound to value of scrutinee
86 -- See Note [CoreSyn case invariants]
87 | Cast (Expr b) Coercion
89 | Type Type -- This should only show up at the top
92 type Arg b = Expr b -- Can be a Type
94 type Alt b = (AltCon, [b], Expr b) -- (DEFAULT, [], rhs) is the default alternative
96 data AltCon = DataAlt DataCon -- Invariant: the DataCon is always from
97 -- a *data* type, and never from a *newtype*
103 data Bind b = NonRec b (Expr b)
104 | Rec [(b, (Expr b))]
107 -------------------------- CoreSyn INVARIANTS ---------------------------
109 Note [CoreSyn top-level invariant]
110 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
111 * The RHSs of all top-level lets must be of LIFTED type.
113 Note [CoreSyn letrec invariant]
114 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
115 * The RHS of a letrec must be of LIFTED type.
117 Note [CoreSyn let/app invariant]
118 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
119 * The RHS of a non-recursive let, *and* the argument of an App,
120 may be of UNLIFTED type, but only if the expression
121 is ok-for-speculation. This means that the let can be floated around
122 without difficulty. e.g.
124 y::Int# = fac 4# not ok [use case instead]
125 This is intially enforced by DsUtils.mkDsLet and mkDsApp
127 Note [CoreSyn case invariants]
128 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
129 Invariant: The DEFAULT case must be *first*, if it occurs at all
131 Invariant: The remaining cases are in order of increasing
134 This makes finding the relevant constructor easy,
135 and makes comparison easier too
137 Invariant: The list of alternatives is ALWAYS EXHAUSTIVE,
138 meaning that it covers all cases that can occur
140 An "exhaustive" case does not necessarily mention all constructors:
141 data Foo = Red | Green | Blue
145 other -> f (case x of
148 The inner case does not need a Red alternative, because x can't be Red at
152 Note [CoreSyn let goal]
153 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
154 * The simplifier tries to ensure that if the RHS of a let is a constructor
155 application, its arguments are trivial, so that the constructor can be
163 | InlineMe -- Instructs simplifer to treat the enclosed expression
164 -- as very small, and inline it at its call sites
166 | CoreNote String -- A generic core annotation, propagated but not used by GHC
168 -- NOTE: we also treat expressions wrapped in InlineMe as
169 -- 'cheap' and 'dupable' (in the sense of exprIsCheap, exprIsDupable)
170 -- What this means is that we obediently inline even things that don't
171 -- look like valuse. This is sometimes important:
174 -- Here, f looks like a redex, and we aren't going to inline (.) because it's
175 -- inside an INLINE, so it'll stay looking like a redex. Nevertheless, we
176 -- should inline f even inside lambdas. In effect, we should trust the programmer.
180 %************************************************************************
182 \subsection{Transformation rules}
184 %************************************************************************
186 The CoreRule type and its friends are dealt with mainly in CoreRules,
187 but CoreFVs, Subst, PprCore, CoreTidy also inspect the representation.
191 "local" if the function it is a rule for is defined in the
192 same module as the rule itself.
194 "orphan" if nothing on the LHS is defined in the same module
198 type RuleName = FastString
203 ru_act :: Activation, -- When the rule is active
205 -- Rough-matching stuff
206 -- see comments with InstEnv.Instance( is_cls, is_rough )
207 ru_fn :: Name, -- Name of the Id at the head of this rule
208 ru_rough :: [Maybe Name], -- Name at the head of each argument
210 -- Proper-matching stuff
211 -- see comments with InstEnv.Instance( is_tvs, is_tys )
212 ru_bndrs :: [CoreBndr], -- Forall'd variables
213 ru_args :: [CoreExpr], -- LHS args
215 -- And the right-hand side
219 ru_local :: Bool -- The fn at the head of the rule is
220 -- defined in the same module as the rule
221 -- and is not an implicit Id (like a record sel
222 -- class op, or data con)
223 -- NB: ru_local is *not* used to decide orphan-hood
224 -- c.g. MkIface.coreRuleToIfaceRule
227 | BuiltinRule { -- Built-in rules are used for constant folding
228 ru_name :: RuleName, -- and suchlike. It has no free variables.
229 ru_fn :: Name, -- Name of the Id at
230 -- the head of this rule
231 ru_nargs :: Int, -- Number of args that ru_try expects,
232 -- including type args
233 ru_try :: [CoreExpr] -> Maybe CoreExpr }
234 -- This function does the rewrite. It given too many
235 -- arguments, it simply discards them; the returned CoreExpr
236 -- is just the rewrite of ru_fn applied to the first ru_nargs args
237 -- See Note [Extra args in rule matching] in Rules.lhs
239 isBuiltinRule :: CoreRule -> Bool
240 isBuiltinRule (BuiltinRule {}) = True
241 isBuiltinRule _ = False
243 ruleArity :: CoreRule -> Int
244 ruleArity (BuiltinRule {ru_nargs = n}) = n
245 ruleArity (Rule {ru_args = args}) = length args
247 ruleName :: CoreRule -> RuleName
250 ruleIdName :: CoreRule -> Name
253 isLocalRule :: CoreRule -> Bool
254 isLocalRule = ru_local
258 %************************************************************************
262 %************************************************************************
264 The @Unfolding@ type is declared here to avoid numerous loops, but it
265 should be abstract everywhere except in CoreUnfold.lhs
271 | OtherCon [AltCon] -- It ain't one of these
272 -- (OtherCon xs) also indicates that something has been evaluated
273 -- and hence there's no point in re-evaluating it.
274 -- OtherCon [] is used even for non-data-type values
275 -- to indicated evaluated-ness. Notably:
276 -- data C = C !(Int -> Int)
277 -- case x of { C f -> ... }
278 -- Here, f gets an OtherCon [] unfolding.
280 | CompulsoryUnfolding CoreExpr -- There is no "original" definition,
281 -- so you'd better unfold.
283 | CoreUnfolding -- An unfolding with redundant cached information
284 CoreExpr -- Template; binder-info is correct
285 Bool -- True <=> top level binding
286 Bool -- exprIsHNF template (cached); it is ok to discard a `seq` on
288 Bool -- True <=> doesn't waste (much) work to expand inside an inlining
289 -- Basically it's exprIsCheap
290 UnfoldingGuidance -- Tells about the *size* of the template.
293 data UnfoldingGuidance
295 | UnfoldIfGoodArgs Int -- and "n" value args
297 [Int] -- Discount if the argument is evaluated.
298 -- (i.e., a simplification will definitely
299 -- be possible). One elt of the list per *value* arg.
301 Int -- The "size" of the unfolding; to be elaborated
304 Int -- Scrutinee discount: the discount to substract if the thing is in
305 -- a context (case (thing args) of ...),
306 -- (where there are the right number of arguments.)
308 noUnfolding, evaldUnfolding :: Unfolding
309 noUnfolding = NoUnfolding
310 evaldUnfolding = OtherCon []
312 mkOtherCon :: [AltCon] -> Unfolding
313 mkOtherCon = OtherCon
315 seqUnfolding :: Unfolding -> ()
316 seqUnfolding (CoreUnfolding e top b1 b2 g)
317 = seqExpr e `seq` top `seq` b1 `seq` b2 `seq` seqGuidance g
320 seqGuidance :: UnfoldingGuidance -> ()
321 seqGuidance (UnfoldIfGoodArgs n ns a b) = n `seq` sum ns `seq` a `seq` b `seq` ()
326 unfoldingTemplate :: Unfolding -> CoreExpr
327 unfoldingTemplate (CoreUnfolding expr _ _ _ _) = expr
328 unfoldingTemplate (CompulsoryUnfolding expr) = expr
329 unfoldingTemplate _ = panic "getUnfoldingTemplate"
331 maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr
332 maybeUnfoldingTemplate (CoreUnfolding expr _ _ _ _) = Just expr
333 maybeUnfoldingTemplate (CompulsoryUnfolding expr) = Just expr
334 maybeUnfoldingTemplate _ = Nothing
336 otherCons :: Unfolding -> [AltCon]
337 otherCons (OtherCon cons) = cons
340 isValueUnfolding :: Unfolding -> Bool
341 -- Returns False for OtherCon
342 isValueUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald
343 isValueUnfolding _ = False
345 isEvaldUnfolding :: Unfolding -> Bool
346 -- Returns True for OtherCon
347 isEvaldUnfolding (OtherCon _) = True
348 isEvaldUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald
349 isEvaldUnfolding _ = False
351 isCheapUnfolding :: Unfolding -> Bool
352 isCheapUnfolding (CoreUnfolding _ _ _ is_cheap _) = is_cheap
353 isCheapUnfolding _ = False
355 isCompulsoryUnfolding :: Unfolding -> Bool
356 isCompulsoryUnfolding (CompulsoryUnfolding _) = True
357 isCompulsoryUnfolding _ = False
359 hasUnfolding :: Unfolding -> Bool
360 hasUnfolding (CoreUnfolding _ _ _ _ _) = True
361 hasUnfolding (CompulsoryUnfolding _) = True
362 hasUnfolding _ = False
364 hasSomeUnfolding :: Unfolding -> Bool
365 hasSomeUnfolding NoUnfolding = False
366 hasSomeUnfolding _ = True
368 neverUnfold :: Unfolding -> Bool
369 neverUnfold NoUnfolding = True
370 neverUnfold (OtherCon _) = True
371 neverUnfold (CoreUnfolding _ _ _ _ UnfoldNever) = True
372 neverUnfold _ = False
376 %************************************************************************
378 \subsection{The main data type}
380 %************************************************************************
383 -- The Ord is needed for the FiniteMap used in the lookForConstructor
384 -- in SimplEnv. If you declared that lookForConstructor *ignores*
385 -- constructor-applications with LitArg args, then you could get
388 instance Outputable AltCon where
389 ppr (DataAlt dc) = ppr dc
390 ppr (LitAlt lit) = ppr lit
391 ppr DEFAULT = ptext (sLit "__DEFAULT")
393 instance Show AltCon where
394 showsPrec p con = showsPrecSDoc p (ppr con)
396 cmpAlt :: Alt b -> Alt b -> Ordering
397 cmpAlt (con1, _, _) (con2, _, _) = con1 `cmpAltCon` con2
399 ltAlt :: Alt b -> Alt b -> Bool
400 ltAlt a1 a2 = (a1 `cmpAlt` a2) == LT
402 cmpAltCon :: AltCon -> AltCon -> Ordering
403 -- Compares AltCons within a single list of alternatives
404 cmpAltCon DEFAULT DEFAULT = EQ
405 cmpAltCon DEFAULT _ = LT
407 cmpAltCon (DataAlt d1) (DataAlt d2) = dataConTag d1 `compare` dataConTag d2
408 cmpAltCon (DataAlt _) DEFAULT = GT
409 cmpAltCon (LitAlt l1) (LitAlt l2) = l1 `compare` l2
410 cmpAltCon (LitAlt _) DEFAULT = GT
412 cmpAltCon con1 con2 = WARN( True, text "Comparing incomparable AltCons" <+>
413 ppr con1 <+> ppr con2 )
418 %************************************************************************
420 \subsection{Useful synonyms}
422 %************************************************************************
428 type CoreExpr = Expr CoreBndr
429 type CoreArg = Arg CoreBndr
430 type CoreBind = Bind CoreBndr
431 type CoreAlt = Alt CoreBndr
434 Binders are ``tagged'' with a \tr{t}:
437 data TaggedBndr t = TB CoreBndr t -- TB for "tagged binder"
439 type TaggedBind t = Bind (TaggedBndr t)
440 type TaggedExpr t = Expr (TaggedBndr t)
441 type TaggedArg t = Arg (TaggedBndr t)
442 type TaggedAlt t = Alt (TaggedBndr t)
444 instance Outputable b => Outputable (TaggedBndr b) where
445 ppr (TB b l) = char '<' <> ppr b <> comma <> ppr l <> char '>'
447 instance Outputable b => OutputableBndr (TaggedBndr b) where
448 pprBndr _ b = ppr b -- Simple
452 %************************************************************************
454 \subsection{Core-constructing functions with checking}
456 %************************************************************************
459 mkApps :: Expr b -> [Arg b] -> Expr b
460 mkTyApps :: Expr b -> [Type] -> Expr b
461 mkValApps :: Expr b -> [Expr b] -> Expr b
462 mkVarApps :: Expr b -> [Var] -> Expr b
464 mkApps f args = foldl App f args
465 mkTyApps f args = foldl (\ e a -> App e (Type a)) f args
466 mkValApps f args = foldl (\ e a -> App e a) f args
467 mkVarApps f vars = foldl (\ e a -> App e (varToCoreExpr a)) f vars
469 mkLit :: Literal -> Expr b
470 mkIntLit :: Integer -> Expr b
471 mkIntLitInt :: Int -> Expr b
472 mkConApp :: DataCon -> [Arg b] -> Expr b
473 mkLets :: [Bind b] -> Expr b -> Expr b
474 mkLams :: [b] -> Expr b -> Expr b
477 mkConApp con args = mkApps (Var (dataConWorkId con)) args
479 mkLams binders body = foldr Lam body binders
480 mkLets binds body = foldr Let body binds
482 mkIntLit n = Lit (mkMachInt n)
483 mkIntLitInt n = Lit (mkMachInt (toInteger n))
485 varToCoreExpr :: CoreBndr -> Expr b
486 varToCoreExpr v | isId v = Var v
487 | otherwise = Type (mkTyVarTy v)
489 varsToCoreExprs :: [CoreBndr] -> [Expr b]
490 varsToCoreExprs vs = map varToCoreExpr vs
492 mkCast :: Expr b -> Coercion -> Expr b
493 mkCast e co = Cast e co
497 %************************************************************************
499 \subsection{Simple access functions}
501 %************************************************************************
504 bindersOf :: Bind b -> [b]
505 bindersOf (NonRec binder _) = [binder]
506 bindersOf (Rec pairs) = [binder | (binder, _) <- pairs]
508 bindersOfBinds :: [Bind b] -> [b]
509 bindersOfBinds binds = foldr ((++) . bindersOf) [] binds
511 rhssOfBind :: Bind b -> [Expr b]
512 rhssOfBind (NonRec _ rhs) = [rhs]
513 rhssOfBind (Rec pairs) = [rhs | (_,rhs) <- pairs]
515 rhssOfAlts :: [Alt b] -> [Expr b]
516 rhssOfAlts alts = [e | (_,_,e) <- alts]
518 flattenBinds :: [Bind b] -> [(b, Expr b)] -- Get all the lhs/rhs pairs
519 flattenBinds (NonRec b r : binds) = (b,r) : flattenBinds binds
520 flattenBinds (Rec prs1 : binds) = prs1 ++ flattenBinds binds
524 We often want to strip off leading lambdas before getting down to
525 business. @collectBinders@ is your friend.
527 We expect (by convention) type-, and value- lambdas in that
531 collectBinders :: Expr b -> ([b], Expr b)
532 collectTyBinders :: CoreExpr -> ([TyVar], CoreExpr)
533 collectValBinders :: CoreExpr -> ([Id], CoreExpr)
534 collectTyAndValBinders :: CoreExpr -> ([TyVar], [Id], CoreExpr)
539 go bs (Lam b e) = go (b:bs) e
540 go bs e = (reverse bs, e)
542 collectTyAndValBinders expr
545 (tvs, body1) = collectTyBinders expr
546 (ids, body) = collectValBinders body1
548 collectTyBinders expr
551 go tvs (Lam b e) | isTyVar b = go (b:tvs) e
552 go tvs e = (reverse tvs, e)
554 collectValBinders expr
557 go ids (Lam b e) | isId b = go (b:ids) e
558 go ids body = (reverse ids, body)
562 @collectArgs@ takes an application expression, returning the function
563 and the arguments to which it is applied.
566 collectArgs :: Expr b -> (Expr b, [Arg b])
570 go (App f a) as = go f (a:as)
574 coreExprCc gets the cost centre enclosing an expression, if any.
575 It looks inside lambdas because (scc "foo" \x.e) = \x.scc "foo" e
578 coreExprCc :: Expr b -> CostCentre
579 coreExprCc (Note (SCC cc) _) = cc
580 coreExprCc (Note _ e) = coreExprCc e
581 coreExprCc (Lam _ e) = coreExprCc e
582 coreExprCc _ = noCostCentre
587 %************************************************************************
589 \subsection{Predicates}
591 %************************************************************************
593 At one time we optionally carried type arguments through to runtime.
594 @isRuntimeVar v@ returns if (Lam v _) really becomes a lambda at runtime,
595 i.e. if type applications are actual lambdas because types are kept around
596 at runtime. Similarly isRuntimeArg.
599 isRuntimeVar :: Var -> Bool
602 isRuntimeArg :: CoreExpr -> Bool
603 isRuntimeArg = isValArg
605 isValArg :: Expr b -> Bool
606 isValArg (Type _) = False
609 isTypeArg :: Expr b -> Bool
610 isTypeArg (Type _) = True
613 valBndrCount :: [CoreBndr] -> Int
614 valBndrCount = count isId
616 valArgCount :: [Arg b] -> Int
617 valArgCount = count isValArg
621 %************************************************************************
623 \subsection{Seq stuff}
625 %************************************************************************
628 seqExpr :: CoreExpr -> ()
629 seqExpr (Var v) = v `seq` ()
630 seqExpr (Lit lit) = lit `seq` ()
631 seqExpr (App f a) = seqExpr f `seq` seqExpr a
632 seqExpr (Lam b e) = seqBndr b `seq` seqExpr e
633 seqExpr (Let b e) = seqBind b `seq` seqExpr e
634 seqExpr (Case e b t as) = seqExpr e `seq` seqBndr b `seq` seqType t `seq` seqAlts as
635 seqExpr (Cast e co) = seqExpr e `seq` seqType co
636 seqExpr (Note n e) = seqNote n `seq` seqExpr e
637 seqExpr (Type t) = seqType t
639 seqExprs :: [CoreExpr] -> ()
641 seqExprs (e:es) = seqExpr e `seq` seqExprs es
643 seqNote :: Note -> ()
644 seqNote (CoreNote s) = s `seq` ()
647 seqBndr :: CoreBndr -> ()
648 seqBndr b = b `seq` ()
650 seqBndrs :: [CoreBndr] -> ()
652 seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
654 seqBind :: Bind CoreBndr -> ()
655 seqBind (NonRec b e) = seqBndr b `seq` seqExpr e
656 seqBind (Rec prs) = seqPairs prs
658 seqPairs :: [(CoreBndr, CoreExpr)] -> ()
660 seqPairs ((b,e):prs) = seqBndr b `seq` seqExpr e `seq` seqPairs prs
662 seqAlts :: [CoreAlt] -> ()
664 seqAlts ((c,bs,e):alts) = c `seq` seqBndrs bs `seq` seqExpr e `seq` seqAlts alts
666 seqRules :: [CoreRule] -> ()
668 seqRules (Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs } : rules)
669 = seqBndrs bndrs `seq` seqExprs (rhs:args) `seq` seqRules rules
670 seqRules (BuiltinRule {} : rules) = seqRules rules
675 %************************************************************************
677 \subsection{Annotated core; annotation at every node in the tree}
679 %************************************************************************
682 type AnnExpr bndr annot = (annot, AnnExpr' bndr annot)
684 data AnnExpr' bndr annot
687 | AnnLam bndr (AnnExpr bndr annot)
688 | AnnApp (AnnExpr bndr annot) (AnnExpr bndr annot)
689 | AnnCase (AnnExpr bndr annot) bndr Type [AnnAlt bndr annot]
690 | AnnLet (AnnBind bndr annot) (AnnExpr bndr annot)
691 | AnnCast (AnnExpr bndr annot) Coercion
692 | AnnNote Note (AnnExpr bndr annot)
695 type AnnAlt bndr annot = (AltCon, [bndr], AnnExpr bndr annot)
697 data AnnBind bndr annot
698 = AnnNonRec bndr (AnnExpr bndr annot)
699 | AnnRec [(bndr, AnnExpr bndr annot)]
703 deAnnotate :: AnnExpr bndr annot -> Expr bndr
704 deAnnotate (_, e) = deAnnotate' e
706 deAnnotate' :: AnnExpr' bndr annot -> Expr bndr
707 deAnnotate' (AnnType t) = Type t
708 deAnnotate' (AnnVar v) = Var v
709 deAnnotate' (AnnLit lit) = Lit lit
710 deAnnotate' (AnnLam binder body) = Lam binder (deAnnotate body)
711 deAnnotate' (AnnApp fun arg) = App (deAnnotate fun) (deAnnotate arg)
712 deAnnotate' (AnnCast e co) = Cast (deAnnotate e) co
713 deAnnotate' (AnnNote note body) = Note note (deAnnotate body)
715 deAnnotate' (AnnLet bind body)
716 = Let (deAnnBind bind) (deAnnotate body)
718 deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs)
719 deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs]
721 deAnnotate' (AnnCase scrut v t alts)
722 = Case (deAnnotate scrut) v t (map deAnnAlt alts)
724 deAnnAlt :: AnnAlt bndr annot -> Alt bndr
725 deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs)
729 collectAnnBndrs :: AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot)
733 collect bs (_, AnnLam b body) = collect (b:bs) body
734 collect bs body = (reverse bs, body)