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 "exhausive" 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 (BuiltinRule {}) = True
240 isBuiltinRule _ = False
242 ruleArity :: CoreRule -> Int
243 ruleArity (BuiltinRule {ru_nargs = n}) = n
244 ruleArity (Rule {ru_args = args}) = length args
246 ruleName :: CoreRule -> RuleName
249 ruleIdName :: CoreRule -> Name
252 isLocalRule :: CoreRule -> Bool
253 isLocalRule = ru_local
257 %************************************************************************
261 %************************************************************************
263 The @Unfolding@ type is declared here to avoid numerous loops, but it
264 should be abstract everywhere except in CoreUnfold.lhs
270 | OtherCon [AltCon] -- It ain't one of these
271 -- (OtherCon xs) also indicates that something has been evaluated
272 -- and hence there's no point in re-evaluating it.
273 -- OtherCon [] is used even for non-data-type values
274 -- to indicated evaluated-ness. Notably:
275 -- data C = C !(Int -> Int)
276 -- case x of { C f -> ... }
277 -- Here, f gets an OtherCon [] unfolding.
279 | CompulsoryUnfolding CoreExpr -- There is no "original" definition,
280 -- so you'd better unfold.
282 | CoreUnfolding -- An unfolding with redundant cached information
283 CoreExpr -- Template; binder-info is correct
284 Bool -- True <=> top level binding
285 Bool -- exprIsHNF template (cached); it is ok to discard a `seq` on
287 Bool -- True <=> doesn't waste (much) work to expand inside an inlining
288 -- Basically it's exprIsCheap
289 UnfoldingGuidance -- Tells about the *size* of the template.
292 data UnfoldingGuidance
294 | UnfoldIfGoodArgs Int -- and "n" value args
296 [Int] -- Discount if the argument is evaluated.
297 -- (i.e., a simplification will definitely
298 -- be possible). One elt of the list per *value* arg.
300 Int -- The "size" of the unfolding; to be elaborated
303 Int -- Scrutinee discount: the discount to substract if the thing is in
304 -- a context (case (thing args) of ...),
305 -- (where there are the right number of arguments.)
307 noUnfolding = NoUnfolding
308 evaldUnfolding = OtherCon []
310 mkOtherCon = OtherCon
312 seqUnfolding :: Unfolding -> ()
313 seqUnfolding (CoreUnfolding e top b1 b2 g)
314 = seqExpr e `seq` top `seq` b1 `seq` b2 `seq` seqGuidance g
315 seqUnfolding other = ()
317 seqGuidance (UnfoldIfGoodArgs n ns a b) = n `seq` sum ns `seq` a `seq` b `seq` ()
318 seqGuidance other = ()
322 unfoldingTemplate :: Unfolding -> CoreExpr
323 unfoldingTemplate (CoreUnfolding expr _ _ _ _) = expr
324 unfoldingTemplate (CompulsoryUnfolding expr) = expr
325 unfoldingTemplate other = panic "getUnfoldingTemplate"
327 maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr
328 maybeUnfoldingTemplate (CoreUnfolding expr _ _ _ _) = Just expr
329 maybeUnfoldingTemplate (CompulsoryUnfolding expr) = Just expr
330 maybeUnfoldingTemplate other = Nothing
332 otherCons :: Unfolding -> [AltCon]
333 otherCons (OtherCon cons) = cons
336 isValueUnfolding :: Unfolding -> Bool
337 -- Returns False for OtherCon
338 isValueUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald
339 isValueUnfolding other = False
341 isEvaldUnfolding :: Unfolding -> Bool
342 -- Returns True for OtherCon
343 isEvaldUnfolding (OtherCon _) = True
344 isEvaldUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald
345 isEvaldUnfolding other = False
347 isCheapUnfolding :: Unfolding -> Bool
348 isCheapUnfolding (CoreUnfolding _ _ _ is_cheap _) = is_cheap
349 isCheapUnfolding other = False
351 isCompulsoryUnfolding :: Unfolding -> Bool
352 isCompulsoryUnfolding (CompulsoryUnfolding _) = True
353 isCompulsoryUnfolding other = False
355 hasUnfolding :: Unfolding -> Bool
356 hasUnfolding (CoreUnfolding _ _ _ _ _) = True
357 hasUnfolding (CompulsoryUnfolding _) = True
358 hasUnfolding other = False
360 hasSomeUnfolding :: Unfolding -> Bool
361 hasSomeUnfolding NoUnfolding = False
362 hasSomeUnfolding other = True
364 neverUnfold :: Unfolding -> Bool
365 neverUnfold NoUnfolding = True
366 neverUnfold (OtherCon _) = True
367 neverUnfold (CoreUnfolding _ _ _ _ UnfoldNever) = True
368 neverUnfold other = False
372 %************************************************************************
374 \subsection{The main data type}
376 %************************************************************************
379 -- The Ord is needed for the FiniteMap used in the lookForConstructor
380 -- in SimplEnv. If you declared that lookForConstructor *ignores*
381 -- constructor-applications with LitArg args, then you could get
384 instance Outputable AltCon where
385 ppr (DataAlt dc) = ppr dc
386 ppr (LitAlt lit) = ppr lit
387 ppr DEFAULT = ptext SLIT("__DEFAULT")
389 instance Show AltCon where
390 showsPrec p con = showsPrecSDoc p (ppr con)
392 cmpAlt :: Alt b -> Alt b -> Ordering
393 cmpAlt (con1, _, _) (con2, _, _) = con1 `cmpAltCon` con2
395 ltAlt :: Alt b -> Alt b -> Bool
396 ltAlt a1 a2 = case a1 `cmpAlt` a2 of { LT -> True; other -> False }
398 cmpAltCon :: AltCon -> AltCon -> Ordering
399 -- Compares AltCons within a single list of alternatives
400 cmpAltCon DEFAULT DEFAULT = EQ
401 cmpAltCon DEFAULT con = LT
403 cmpAltCon (DataAlt d1) (DataAlt d2) = dataConTag d1 `compare` dataConTag d2
404 cmpAltCon (DataAlt _) DEFAULT = GT
405 cmpAltCon (LitAlt l1) (LitAlt l2) = l1 `compare` l2
406 cmpAltCon (LitAlt _) DEFAULT = GT
408 cmpAltCon con1 con2 = WARN( True, text "Comparing incomparable AltCons" <+>
409 ppr con1 <+> ppr con2 )
414 %************************************************************************
416 \subsection{Useful synonyms}
418 %************************************************************************
424 type CoreExpr = Expr CoreBndr
425 type CoreArg = Arg CoreBndr
426 type CoreBind = Bind CoreBndr
427 type CoreAlt = Alt CoreBndr
430 Binders are ``tagged'' with a \tr{t}:
433 data TaggedBndr t = TB CoreBndr t -- TB for "tagged binder"
435 type TaggedBind t = Bind (TaggedBndr t)
436 type TaggedExpr t = Expr (TaggedBndr t)
437 type TaggedArg t = Arg (TaggedBndr t)
438 type TaggedAlt t = Alt (TaggedBndr t)
440 instance Outputable b => Outputable (TaggedBndr b) where
441 ppr (TB b l) = char '<' <> ppr b <> comma <> ppr l <> char '>'
443 instance Outputable b => OutputableBndr (TaggedBndr b) where
444 pprBndr _ b = ppr b -- Simple
448 %************************************************************************
450 \subsection{Core-constructing functions with checking}
452 %************************************************************************
455 mkApps :: Expr b -> [Arg b] -> Expr b
456 mkTyApps :: Expr b -> [Type] -> Expr b
457 mkValApps :: Expr b -> [Expr b] -> Expr b
458 mkVarApps :: Expr b -> [Var] -> Expr b
460 mkApps f args = foldl App f args
461 mkTyApps f args = foldl (\ e a -> App e (Type a)) f args
462 mkValApps f args = foldl (\ e a -> App e a) f args
463 mkVarApps f vars = foldl (\ e a -> App e (varToCoreExpr a)) f vars
465 mkLit :: Literal -> Expr b
466 mkIntLit :: Integer -> Expr b
467 mkIntLitInt :: Int -> Expr b
468 mkConApp :: DataCon -> [Arg b] -> Expr b
469 mkLets :: [Bind b] -> Expr b -> Expr b
470 mkLams :: [b] -> Expr b -> Expr b
473 mkConApp con args = mkApps (Var (dataConWorkId con)) args
475 mkLams binders body = foldr Lam body binders
476 mkLets binds body = foldr Let body binds
478 mkIntLit n = Lit (mkMachInt n)
479 mkIntLitInt n = Lit (mkMachInt (toInteger n))
481 varToCoreExpr :: CoreBndr -> Expr b
482 varToCoreExpr v | isId v = Var v
483 | otherwise = Type (mkTyVarTy v)
485 varsToCoreExprs :: [CoreBndr] -> [Expr b]
486 varsToCoreExprs vs = map varToCoreExpr vs
488 mkCast :: Expr b -> Coercion -> Expr b
489 mkCast e co = Cast e co
493 %************************************************************************
495 \subsection{Simple access functions}
497 %************************************************************************
500 bindersOf :: Bind b -> [b]
501 bindersOf (NonRec binder _) = [binder]
502 bindersOf (Rec pairs) = [binder | (binder, _) <- pairs]
504 bindersOfBinds :: [Bind b] -> [b]
505 bindersOfBinds binds = foldr ((++) . bindersOf) [] binds
507 rhssOfBind :: Bind b -> [Expr b]
508 rhssOfBind (NonRec _ rhs) = [rhs]
509 rhssOfBind (Rec pairs) = [rhs | (_,rhs) <- pairs]
511 rhssOfAlts :: [Alt b] -> [Expr b]
512 rhssOfAlts alts = [e | (_,_,e) <- alts]
514 flattenBinds :: [Bind b] -> [(b, Expr b)] -- Get all the lhs/rhs pairs
515 flattenBinds (NonRec b r : binds) = (b,r) : flattenBinds binds
516 flattenBinds (Rec prs1 : binds) = prs1 ++ flattenBinds binds
520 We often want to strip off leading lambdas before getting down to
521 business. @collectBinders@ is your friend.
523 We expect (by convention) type-, and value- lambdas in that
527 collectBinders :: Expr b -> ([b], Expr b)
528 collectTyBinders :: CoreExpr -> ([TyVar], CoreExpr)
529 collectValBinders :: CoreExpr -> ([Id], CoreExpr)
530 collectTyAndValBinders :: CoreExpr -> ([TyVar], [Id], CoreExpr)
535 go bs (Lam b e) = go (b:bs) e
536 go bs e = (reverse bs, e)
538 collectTyAndValBinders expr
541 (tvs, body1) = collectTyBinders expr
542 (ids, body) = collectValBinders body1
544 collectTyBinders expr
547 go tvs (Lam b e) | isTyVar b = go (b:tvs) e
548 go tvs e = (reverse tvs, e)
550 collectValBinders expr
553 go ids (Lam b e) | isId b = go (b:ids) e
554 go ids body = (reverse ids, body)
558 @collectArgs@ takes an application expression, returning the function
559 and the arguments to which it is applied.
562 collectArgs :: Expr b -> (Expr b, [Arg b])
566 go (App f a) as = go f (a:as)
570 coreExprCc gets the cost centre enclosing an expression, if any.
571 It looks inside lambdas because (scc "foo" \x.e) = \x.scc "foo" e
574 coreExprCc :: Expr b -> CostCentre
575 coreExprCc (Note (SCC cc) e) = cc
576 coreExprCc (Note other_note e) = coreExprCc e
577 coreExprCc (Lam _ e) = coreExprCc e
578 coreExprCc other = noCostCentre
583 %************************************************************************
585 \subsection{Predicates}
587 %************************************************************************
589 @isRuntimeVar v@ returns if (Lam v _) really becomes a lambda at runtime,
590 i.e. if type applications are actual lambdas because types are kept around
593 Similarly isRuntimeArg.
596 isRuntimeVar :: Var -> Bool
597 isRuntimeVar | opt_RuntimeTypes = \v -> True
598 | otherwise = \v -> isId v
600 isRuntimeArg :: CoreExpr -> Bool
601 isRuntimeArg | opt_RuntimeTypes = \e -> True
602 | otherwise = \e -> isValArg e
606 isValArg (Type _) = False
607 isValArg other = True
609 isTypeArg (Type _) = True
610 isTypeArg other = False
612 valBndrCount :: [CoreBndr] -> Int
614 valBndrCount (b : bs) | isId b = 1 + valBndrCount bs
615 | otherwise = valBndrCount bs
617 valArgCount :: [Arg b] -> Int
619 valArgCount (Type _ : args) = valArgCount args
620 valArgCount (other : args) = 1 + valArgCount args
624 %************************************************************************
626 \subsection{Seq stuff}
628 %************************************************************************
631 seqExpr :: CoreExpr -> ()
632 seqExpr (Var v) = v `seq` ()
633 seqExpr (Lit lit) = lit `seq` ()
634 seqExpr (App f a) = seqExpr f `seq` seqExpr a
635 seqExpr (Lam b e) = seqBndr b `seq` seqExpr e
636 seqExpr (Let b e) = seqBind b `seq` seqExpr e
637 seqExpr (Case e b t as) = seqExpr e `seq` seqBndr b `seq` seqType t `seq` seqAlts as
638 seqExpr (Cast e co) = seqExpr e `seq` seqType co
639 seqExpr (Note n e) = seqNote n `seq` seqExpr e
640 seqExpr (Type t) = seqType t
643 seqExprs (e:es) = seqExpr e `seq` seqExprs es
645 seqNote (CoreNote s) = s `seq` ()
648 seqBndr b = b `seq` ()
651 seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
653 seqBind (NonRec b e) = seqBndr b `seq` seqExpr e
654 seqBind (Rec prs) = seqPairs prs
657 seqPairs ((b,e):prs) = seqBndr b `seq` seqExpr e `seq` seqPairs prs
660 seqAlts ((c,bs,e):alts) = seqBndrs bs `seq` seqExpr e `seq` seqAlts alts
663 seqRules (Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs } : rules)
664 = seqBndrs bndrs `seq` seqExprs (rhs:args) `seq` seqRules rules
665 seqRules (BuiltinRule {} : rules) = seqRules rules
670 %************************************************************************
672 \subsection{Annotated core; annotation at every node in the tree}
674 %************************************************************************
677 type AnnExpr bndr annot = (annot, AnnExpr' bndr annot)
679 data AnnExpr' bndr annot
682 | AnnLam bndr (AnnExpr bndr annot)
683 | AnnApp (AnnExpr bndr annot) (AnnExpr bndr annot)
684 | AnnCase (AnnExpr bndr annot) bndr Type [AnnAlt bndr annot]
685 | AnnLet (AnnBind bndr annot) (AnnExpr bndr annot)
686 | AnnCast (AnnExpr bndr annot) Coercion
687 | AnnNote Note (AnnExpr bndr annot)
690 type AnnAlt bndr annot = (AltCon, [bndr], AnnExpr bndr annot)
692 data AnnBind bndr annot
693 = AnnNonRec bndr (AnnExpr bndr annot)
694 | AnnRec [(bndr, AnnExpr bndr annot)]
698 deAnnotate :: AnnExpr bndr annot -> Expr bndr
699 deAnnotate (_, e) = deAnnotate' e
701 deAnnotate' (AnnType t) = Type t
702 deAnnotate' (AnnVar v) = Var v
703 deAnnotate' (AnnLit lit) = Lit lit
704 deAnnotate' (AnnLam binder body) = Lam binder (deAnnotate body)
705 deAnnotate' (AnnApp fun arg) = App (deAnnotate fun) (deAnnotate arg)
706 deAnnotate' (AnnCast e co) = Cast (deAnnotate e) co
707 deAnnotate' (AnnNote note body) = Note note (deAnnotate body)
709 deAnnotate' (AnnLet bind body)
710 = Let (deAnnBind bind) (deAnnotate body)
712 deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs)
713 deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs]
715 deAnnotate' (AnnCase scrut v t alts)
716 = Case (deAnnotate scrut) v t (map deAnnAlt alts)
718 deAnnAlt :: AnnAlt bndr annot -> Alt bndr
719 deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs)
723 collectAnnBndrs :: AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot)
727 collect bs (_, AnnLam b body) = collect (b:bs) body
728 collect bs body = (reverse bs, body)