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 ru_try :: [CoreExpr] -> Maybe CoreExpr }
234 isBuiltinRule (BuiltinRule {}) = True
235 isBuiltinRule _ = False
237 ruleArity :: CoreRule -> Int
238 ruleArity (BuiltinRule {ru_nargs = n}) = n
239 ruleArity (Rule {ru_args = args}) = length args
241 ruleName :: CoreRule -> RuleName
244 ruleIdName :: CoreRule -> Name
247 isLocalRule :: CoreRule -> Bool
248 isLocalRule = ru_local
252 %************************************************************************
256 %************************************************************************
258 The @Unfolding@ type is declared here to avoid numerous loops, but it
259 should be abstract everywhere except in CoreUnfold.lhs
265 | OtherCon [AltCon] -- It ain't one of these
266 -- (OtherCon xs) also indicates that something has been evaluated
267 -- and hence there's no point in re-evaluating it.
268 -- OtherCon [] is used even for non-data-type values
269 -- to indicated evaluated-ness. Notably:
270 -- data C = C !(Int -> Int)
271 -- case x of { C f -> ... }
272 -- Here, f gets an OtherCon [] unfolding.
274 | CompulsoryUnfolding CoreExpr -- There is no "original" definition,
275 -- so you'd better unfold.
277 | CoreUnfolding -- An unfolding with redundant cached information
278 CoreExpr -- Template; binder-info is correct
279 Bool -- True <=> top level binding
280 Bool -- exprIsHNF template (cached); it is ok to discard a `seq` on
282 Bool -- True <=> doesn't waste (much) work to expand inside an inlining
283 -- Basically it's exprIsCheap
284 UnfoldingGuidance -- Tells about the *size* of the template.
287 data UnfoldingGuidance
289 | UnfoldIfGoodArgs Int -- and "n" value args
291 [Int] -- Discount if the argument is evaluated.
292 -- (i.e., a simplification will definitely
293 -- be possible). One elt of the list per *value* arg.
295 Int -- The "size" of the unfolding; to be elaborated
298 Int -- Scrutinee discount: the discount to substract if the thing is in
299 -- a context (case (thing args) of ...),
300 -- (where there are the right number of arguments.)
302 noUnfolding = NoUnfolding
303 evaldUnfolding = OtherCon []
305 mkOtherCon = OtherCon
307 seqUnfolding :: Unfolding -> ()
308 seqUnfolding (CoreUnfolding e top b1 b2 g)
309 = seqExpr e `seq` top `seq` b1 `seq` b2 `seq` seqGuidance g
310 seqUnfolding other = ()
312 seqGuidance (UnfoldIfGoodArgs n ns a b) = n `seq` sum ns `seq` a `seq` b `seq` ()
313 seqGuidance other = ()
317 unfoldingTemplate :: Unfolding -> CoreExpr
318 unfoldingTemplate (CoreUnfolding expr _ _ _ _) = expr
319 unfoldingTemplate (CompulsoryUnfolding expr) = expr
320 unfoldingTemplate other = panic "getUnfoldingTemplate"
322 maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr
323 maybeUnfoldingTemplate (CoreUnfolding expr _ _ _ _) = Just expr
324 maybeUnfoldingTemplate (CompulsoryUnfolding expr) = Just expr
325 maybeUnfoldingTemplate other = Nothing
327 otherCons :: Unfolding -> [AltCon]
328 otherCons (OtherCon cons) = cons
331 isValueUnfolding :: Unfolding -> Bool
332 -- Returns False for OtherCon
333 isValueUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald
334 isValueUnfolding other = False
336 isEvaldUnfolding :: Unfolding -> Bool
337 -- Returns True for OtherCon
338 isEvaldUnfolding (OtherCon _) = True
339 isEvaldUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald
340 isEvaldUnfolding other = False
342 isCheapUnfolding :: Unfolding -> Bool
343 isCheapUnfolding (CoreUnfolding _ _ _ is_cheap _) = is_cheap
344 isCheapUnfolding other = False
346 isCompulsoryUnfolding :: Unfolding -> Bool
347 isCompulsoryUnfolding (CompulsoryUnfolding _) = True
348 isCompulsoryUnfolding other = False
350 hasUnfolding :: Unfolding -> Bool
351 hasUnfolding (CoreUnfolding _ _ _ _ _) = True
352 hasUnfolding (CompulsoryUnfolding _) = True
353 hasUnfolding other = False
355 hasSomeUnfolding :: Unfolding -> Bool
356 hasSomeUnfolding NoUnfolding = False
357 hasSomeUnfolding other = True
359 neverUnfold :: Unfolding -> Bool
360 neverUnfold NoUnfolding = True
361 neverUnfold (OtherCon _) = True
362 neverUnfold (CoreUnfolding _ _ _ _ UnfoldNever) = True
363 neverUnfold other = False
367 %************************************************************************
369 \subsection{The main data type}
371 %************************************************************************
374 -- The Ord is needed for the FiniteMap used in the lookForConstructor
375 -- in SimplEnv. If you declared that lookForConstructor *ignores*
376 -- constructor-applications with LitArg args, then you could get
379 instance Outputable AltCon where
380 ppr (DataAlt dc) = ppr dc
381 ppr (LitAlt lit) = ppr lit
382 ppr DEFAULT = ptext SLIT("__DEFAULT")
384 instance Show AltCon where
385 showsPrec p con = showsPrecSDoc p (ppr con)
387 cmpAlt :: Alt b -> Alt b -> Ordering
388 cmpAlt (con1, _, _) (con2, _, _) = con1 `cmpAltCon` con2
390 ltAlt :: Alt b -> Alt b -> Bool
391 ltAlt a1 a2 = case a1 `cmpAlt` a2 of { LT -> True; other -> False }
393 cmpAltCon :: AltCon -> AltCon -> Ordering
394 -- Compares AltCons within a single list of alternatives
395 cmpAltCon DEFAULT DEFAULT = EQ
396 cmpAltCon DEFAULT con = LT
398 cmpAltCon (DataAlt d1) (DataAlt d2) = dataConTag d1 `compare` dataConTag d2
399 cmpAltCon (DataAlt _) DEFAULT = GT
400 cmpAltCon (LitAlt l1) (LitAlt l2) = l1 `compare` l2
401 cmpAltCon (LitAlt _) DEFAULT = GT
403 cmpAltCon con1 con2 = WARN( True, text "Comparing incomparable AltCons" <+>
404 ppr con1 <+> ppr con2 )
409 %************************************************************************
411 \subsection{Useful synonyms}
413 %************************************************************************
419 type CoreExpr = Expr CoreBndr
420 type CoreArg = Arg CoreBndr
421 type CoreBind = Bind CoreBndr
422 type CoreAlt = Alt CoreBndr
425 Binders are ``tagged'' with a \tr{t}:
428 data TaggedBndr t = TB CoreBndr t -- TB for "tagged binder"
430 type TaggedBind t = Bind (TaggedBndr t)
431 type TaggedExpr t = Expr (TaggedBndr t)
432 type TaggedArg t = Arg (TaggedBndr t)
433 type TaggedAlt t = Alt (TaggedBndr t)
435 instance Outputable b => Outputable (TaggedBndr b) where
436 ppr (TB b l) = char '<' <> ppr b <> comma <> ppr l <> char '>'
438 instance Outputable b => OutputableBndr (TaggedBndr b) where
439 pprBndr _ b = ppr b -- Simple
443 %************************************************************************
445 \subsection{Core-constructing functions with checking}
447 %************************************************************************
450 mkApps :: Expr b -> [Arg b] -> Expr b
451 mkTyApps :: Expr b -> [Type] -> Expr b
452 mkValApps :: Expr b -> [Expr b] -> Expr b
453 mkVarApps :: Expr b -> [Var] -> Expr b
455 mkApps f args = foldl App f args
456 mkTyApps f args = foldl (\ e a -> App e (Type a)) f args
457 mkValApps f args = foldl (\ e a -> App e a) f args
458 mkVarApps f vars = foldl (\ e a -> App e (varToCoreExpr a)) f vars
460 mkLit :: Literal -> Expr b
461 mkIntLit :: Integer -> Expr b
462 mkIntLitInt :: Int -> Expr b
463 mkConApp :: DataCon -> [Arg b] -> Expr b
464 mkLets :: [Bind b] -> Expr b -> Expr b
465 mkLams :: [b] -> Expr b -> Expr b
468 mkConApp con args = mkApps (Var (dataConWorkId con)) args
470 mkLams binders body = foldr Lam body binders
471 mkLets binds body = foldr Let body binds
473 mkIntLit n = Lit (mkMachInt n)
474 mkIntLitInt n = Lit (mkMachInt (toInteger n))
476 varToCoreExpr :: CoreBndr -> Expr b
477 varToCoreExpr v | isId v = Var v
478 | otherwise = Type (mkTyVarTy v)
480 varsToCoreExprs :: [CoreBndr] -> [Expr b]
481 varsToCoreExprs vs = map varToCoreExpr vs
483 mkCast :: Expr b -> Coercion -> Expr b
484 mkCast e co = Cast e co
488 %************************************************************************
490 \subsection{Simple access functions}
492 %************************************************************************
495 bindersOf :: Bind b -> [b]
496 bindersOf (NonRec binder _) = [binder]
497 bindersOf (Rec pairs) = [binder | (binder, _) <- pairs]
499 bindersOfBinds :: [Bind b] -> [b]
500 bindersOfBinds binds = foldr ((++) . bindersOf) [] binds
502 rhssOfBind :: Bind b -> [Expr b]
503 rhssOfBind (NonRec _ rhs) = [rhs]
504 rhssOfBind (Rec pairs) = [rhs | (_,rhs) <- pairs]
506 rhssOfAlts :: [Alt b] -> [Expr b]
507 rhssOfAlts alts = [e | (_,_,e) <- alts]
509 flattenBinds :: [Bind b] -> [(b, Expr b)] -- Get all the lhs/rhs pairs
510 flattenBinds (NonRec b r : binds) = (b,r) : flattenBinds binds
511 flattenBinds (Rec prs1 : binds) = prs1 ++ flattenBinds binds
515 We often want to strip off leading lambdas before getting down to
516 business. @collectBinders@ is your friend.
518 We expect (by convention) type-, and value- lambdas in that
522 collectBinders :: Expr b -> ([b], Expr b)
523 collectTyBinders :: CoreExpr -> ([TyVar], CoreExpr)
524 collectValBinders :: CoreExpr -> ([Id], CoreExpr)
525 collectTyAndValBinders :: CoreExpr -> ([TyVar], [Id], CoreExpr)
530 go bs (Lam b e) = go (b:bs) e
531 go bs e = (reverse bs, e)
533 collectTyAndValBinders expr
536 (tvs, body1) = collectTyBinders expr
537 (ids, body) = collectValBinders body1
539 collectTyBinders expr
542 go tvs (Lam b e) | isTyVar b = go (b:tvs) e
543 go tvs e = (reverse tvs, e)
545 collectValBinders expr
548 go ids (Lam b e) | isId b = go (b:ids) e
549 go ids body = (reverse ids, body)
553 @collectArgs@ takes an application expression, returning the function
554 and the arguments to which it is applied.
557 collectArgs :: Expr b -> (Expr b, [Arg b])
561 go (App f a) as = go f (a:as)
565 coreExprCc gets the cost centre enclosing an expression, if any.
566 It looks inside lambdas because (scc "foo" \x.e) = \x.scc "foo" e
569 coreExprCc :: Expr b -> CostCentre
570 coreExprCc (Note (SCC cc) e) = cc
571 coreExprCc (Note other_note e) = coreExprCc e
572 coreExprCc (Lam _ e) = coreExprCc e
573 coreExprCc other = noCostCentre
578 %************************************************************************
580 \subsection{Predicates}
582 %************************************************************************
584 @isRuntimeVar v@ returns if (Lam v _) really becomes a lambda at runtime,
585 i.e. if type applications are actual lambdas because types are kept around
588 Similarly isRuntimeArg.
591 isRuntimeVar :: Var -> Bool
592 isRuntimeVar | opt_RuntimeTypes = \v -> True
593 | otherwise = \v -> isId v
595 isRuntimeArg :: CoreExpr -> Bool
596 isRuntimeArg | opt_RuntimeTypes = \e -> True
597 | otherwise = \e -> isValArg e
601 isValArg (Type _) = False
602 isValArg other = True
604 isTypeArg (Type _) = True
605 isTypeArg other = False
607 valBndrCount :: [CoreBndr] -> Int
609 valBndrCount (b : bs) | isId b = 1 + valBndrCount bs
610 | otherwise = valBndrCount bs
612 valArgCount :: [Arg b] -> Int
614 valArgCount (Type _ : args) = valArgCount args
615 valArgCount (other : args) = 1 + valArgCount args
619 %************************************************************************
621 \subsection{Seq stuff}
623 %************************************************************************
626 seqExpr :: CoreExpr -> ()
627 seqExpr (Var v) = v `seq` ()
628 seqExpr (Lit lit) = lit `seq` ()
629 seqExpr (App f a) = seqExpr f `seq` seqExpr a
630 seqExpr (Lam b e) = seqBndr b `seq` seqExpr e
631 seqExpr (Let b e) = seqBind b `seq` seqExpr e
632 seqExpr (Case e b t as) = seqExpr e `seq` seqBndr b `seq` seqType t `seq` seqAlts as
633 seqExpr (Cast e co) = seqExpr e `seq` seqType co
634 seqExpr (Note n e) = seqNote n `seq` seqExpr e
635 seqExpr (Type t) = seqType t
638 seqExprs (e:es) = seqExpr e `seq` seqExprs es
640 seqNote (CoreNote s) = s `seq` ()
643 seqBndr b = b `seq` ()
646 seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
648 seqBind (NonRec b e) = seqBndr b `seq` seqExpr e
649 seqBind (Rec prs) = seqPairs prs
652 seqPairs ((b,e):prs) = seqBndr b `seq` seqExpr e `seq` seqPairs prs
655 seqAlts ((c,bs,e):alts) = seqBndrs bs `seq` seqExpr e `seq` seqAlts alts
658 seqRules (Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs } : rules)
659 = seqBndrs bndrs `seq` seqExprs (rhs:args) `seq` seqRules rules
660 seqRules (BuiltinRule {} : rules) = seqRules rules
665 %************************************************************************
667 \subsection{Annotated core; annotation at every node in the tree}
669 %************************************************************************
672 type AnnExpr bndr annot = (annot, AnnExpr' bndr annot)
674 data AnnExpr' bndr annot
677 | AnnLam bndr (AnnExpr bndr annot)
678 | AnnApp (AnnExpr bndr annot) (AnnExpr bndr annot)
679 | AnnCase (AnnExpr bndr annot) bndr Type [AnnAlt bndr annot]
680 | AnnLet (AnnBind bndr annot) (AnnExpr bndr annot)
681 | AnnCast (AnnExpr bndr annot) Coercion
682 | AnnNote Note (AnnExpr bndr annot)
685 type AnnAlt bndr annot = (AltCon, [bndr], AnnExpr bndr annot)
687 data AnnBind bndr annot
688 = AnnNonRec bndr (AnnExpr bndr annot)
689 | AnnRec [(bndr, AnnExpr bndr annot)]
693 deAnnotate :: AnnExpr bndr annot -> Expr bndr
694 deAnnotate (_, e) = deAnnotate' e
696 deAnnotate' (AnnType t) = Type t
697 deAnnotate' (AnnVar v) = Var v
698 deAnnotate' (AnnLit lit) = Lit lit
699 deAnnotate' (AnnLam binder body) = Lam binder (deAnnotate body)
700 deAnnotate' (AnnApp fun arg) = App (deAnnotate fun) (deAnnotate arg)
701 deAnnotate' (AnnCast e co) = Cast (deAnnotate e) co
702 deAnnotate' (AnnNote note body) = Note note (deAnnotate body)
704 deAnnotate' (AnnLet bind body)
705 = Let (deAnnBind bind) (deAnnotate body)
707 deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs)
708 deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs]
710 deAnnotate' (AnnCase scrut v t alts)
711 = Case (deAnnotate scrut) v t (map deAnnAlt alts)
713 deAnnAlt :: AnnAlt bndr annot -> Alt bndr
714 deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs)
718 collectAnnBndrs :: AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot)
722 collect bs (_, AnnLam b body) = collect (b:bs) body
723 collect bs body = (reverse bs, body)