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
46 isBuiltinRule, ruleName, isLocalRule, ruleIdName
49 #include "HsVersions.h"
65 infixl 4 `mkApps`, `mkValApps`, `mkTyApps`, `mkVarApps`
66 -- Left associative, so that we can say (f `mkTyApps` xs `mkVarApps` ys)
69 %************************************************************************
71 \subsection{The main data types}
73 %************************************************************************
75 These data types are the heart of the compiler
78 infixl 8 `App` -- App brackets to the left
80 data Expr b -- "b" for the type of binders,
83 | App (Expr b) (Arg b)
85 | Let (Bind b) (Expr b)
86 | Case (Expr b) b Type [Alt b] -- Binder gets bound to value of scrutinee
87 -- Invariant: The list of alternatives is ALWAYS EXHAUSTIVE,
88 -- meaning that it covers all cases that can occur
89 -- See the example below
91 -- Invariant: The DEFAULT case must be *first*, if it occurs at all
92 -- Invariant: The remaining cases are in order of increasing
95 -- This makes finding the relevant constructor easy,
96 -- and makes comparison easier too
97 | Cast (Expr b) Coercion
99 | Type Type -- This should only show up at the top
102 -- An "exhausive" case does not necessarily mention all constructors:
103 -- data Foo = Red | Green | Blue
107 -- other -> f (case x of
110 -- The inner case does not need a Red alternative, because x can't be Red at
111 -- that program point.
114 type Arg b = Expr b -- Can be a Type
116 type Alt b = (AltCon, [b], Expr b) -- (DEFAULT, [], rhs) is the default alternative
118 data AltCon = DataAlt DataCon -- Invariant: the DataCon is always from
119 -- a *data* type, and never from a *newtype*
125 data Bind b = NonRec b (Expr b)
126 | Rec [(b, (Expr b))]
131 | InlineMe -- Instructs simplifer to treat the enclosed expression
132 -- as very small, and inline it at its call sites
134 | CoreNote String -- A generic core annotation, propagated but not used by GHC
136 | TickBox Module !Int -- ^Tick box for Hpc-style coverage
137 | BinaryTickBox Module !Int !Int
138 -- ^Binary tick box, with a tick for result = True, result = False
141 -- NOTE: we also treat expressions wrapped in InlineMe as
142 -- 'cheap' and 'dupable' (in the sense of exprIsCheap, exprIsDupable)
143 -- What this means is that we obediently inline even things that don't
144 -- look like valuse. This is sometimes important:
147 -- Here, f looks like a redex, and we aren't going to inline (.) because it's
148 -- inside an INLINE, so it'll stay looking like a redex. Nevertheless, we
149 -- should inline f even inside lambdas. In effect, we should trust the programmer.
154 * The RHS of a letrec, and the RHSs of all top-level lets,
155 must be of LIFTED type.
157 * The RHS of a let, may be of UNLIFTED type, but only if the expression
158 is ok-for-speculation. This means that the let can be floated around
159 without difficulty. e.g.
161 y::Int# = fac 4# not ok [use case instead]
163 * The argument of an App can be of any type.
165 * The simplifier tries to ensure that if the RHS of a let is a constructor
166 application, its arguments are trivial, so that the constructor can be
170 %************************************************************************
172 \subsection{Transformation rules}
174 %************************************************************************
176 The CoreRule type and its friends are dealt with mainly in CoreRules,
177 but CoreFVs, Subst, PprCore, CoreTidy also inspect the representation.
181 "local" if the function it is a rule for is defined in the
182 same module as the rule itself.
184 "orphan" if nothing on the LHS is defined in the same module
188 type RuleName = FastString
193 ru_act :: Activation, -- When the rule is active
195 -- Rough-matching stuff
196 -- see comments with InstEnv.Instance( is_cls, is_rough )
197 ru_fn :: Name, -- Name of the Id at the head of this rule
198 ru_rough :: [Maybe Name], -- Name at the head of each argument
200 -- Proper-matching stuff
201 -- see comments with InstEnv.Instance( is_tvs, is_tys )
202 ru_bndrs :: [CoreBndr], -- Forall'd variables
203 ru_args :: [CoreExpr], -- LHS args
205 -- And the right-hand side
209 ru_local :: Bool, -- The fn at the head of the rule is
210 -- defined in the same module as the rule
212 -- Orphan-hood; see Note [Orphans] in InstEnv
213 ru_orph :: Maybe OccName }
215 | BuiltinRule { -- Built-in rules are used for constant folding
216 ru_name :: RuleName, -- and suchlike. It has no free variables.
217 ru_fn :: Name, -- Name of the Id at
218 -- the head of this rule
219 ru_try :: [CoreExpr] -> Maybe CoreExpr }
221 isBuiltinRule (BuiltinRule {}) = True
222 isBuiltinRule _ = False
224 ruleName :: CoreRule -> RuleName
227 ruleIdName :: CoreRule -> Name
230 isLocalRule :: CoreRule -> Bool
231 isLocalRule = ru_local
235 %************************************************************************
239 %************************************************************************
241 The @Unfolding@ type is declared here to avoid numerous loops, but it
242 should be abstract everywhere except in CoreUnfold.lhs
248 | OtherCon [AltCon] -- It ain't one of these
249 -- (OtherCon xs) also indicates that something has been evaluated
250 -- and hence there's no point in re-evaluating it.
251 -- OtherCon [] is used even for non-data-type values
252 -- to indicated evaluated-ness. Notably:
253 -- data C = C !(Int -> Int)
254 -- case x of { C f -> ... }
255 -- Here, f gets an OtherCon [] unfolding.
257 | CompulsoryUnfolding CoreExpr -- There is no "original" definition,
258 -- so you'd better unfold.
260 | CoreUnfolding -- An unfolding with redundant cached information
261 CoreExpr -- Template; binder-info is correct
262 Bool -- True <=> top level binding
263 Bool -- exprIsHNF template (cached); it is ok to discard a `seq` on
265 Bool -- True <=> doesn't waste (much) work to expand inside an inlining
266 -- Basically it's exprIsCheap
267 UnfoldingGuidance -- Tells about the *size* of the template.
270 data UnfoldingGuidance
272 | UnfoldIfGoodArgs Int -- and "n" value args
274 [Int] -- Discount if the argument is evaluated.
275 -- (i.e., a simplification will definitely
276 -- be possible). One elt of the list per *value* arg.
278 Int -- The "size" of the unfolding; to be elaborated
281 Int -- Scrutinee discount: the discount to substract if the thing is in
282 -- a context (case (thing args) of ...),
283 -- (where there are the right number of arguments.)
285 noUnfolding = NoUnfolding
286 evaldUnfolding = OtherCon []
288 mkOtherCon = OtherCon
290 seqUnfolding :: Unfolding -> ()
291 seqUnfolding (CoreUnfolding e top b1 b2 g)
292 = seqExpr e `seq` top `seq` b1 `seq` b2 `seq` seqGuidance g
293 seqUnfolding other = ()
295 seqGuidance (UnfoldIfGoodArgs n ns a b) = n `seq` sum ns `seq` a `seq` b `seq` ()
296 seqGuidance other = ()
300 unfoldingTemplate :: Unfolding -> CoreExpr
301 unfoldingTemplate (CoreUnfolding expr _ _ _ _) = expr
302 unfoldingTemplate (CompulsoryUnfolding expr) = expr
303 unfoldingTemplate other = panic "getUnfoldingTemplate"
305 maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr
306 maybeUnfoldingTemplate (CoreUnfolding expr _ _ _ _) = Just expr
307 maybeUnfoldingTemplate (CompulsoryUnfolding expr) = Just expr
308 maybeUnfoldingTemplate other = Nothing
310 otherCons :: Unfolding -> [AltCon]
311 otherCons (OtherCon cons) = cons
314 isValueUnfolding :: Unfolding -> Bool
315 -- Returns False for OtherCon
316 isValueUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald
317 isValueUnfolding other = False
319 isEvaldUnfolding :: Unfolding -> Bool
320 -- Returns True for OtherCon
321 isEvaldUnfolding (OtherCon _) = True
322 isEvaldUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald
323 isEvaldUnfolding other = False
325 isCheapUnfolding :: Unfolding -> Bool
326 isCheapUnfolding (CoreUnfolding _ _ _ is_cheap _) = is_cheap
327 isCheapUnfolding other = False
329 isCompulsoryUnfolding :: Unfolding -> Bool
330 isCompulsoryUnfolding (CompulsoryUnfolding _) = True
331 isCompulsoryUnfolding other = False
333 hasUnfolding :: Unfolding -> Bool
334 hasUnfolding (CoreUnfolding _ _ _ _ _) = True
335 hasUnfolding (CompulsoryUnfolding _) = True
336 hasUnfolding other = False
338 hasSomeUnfolding :: Unfolding -> Bool
339 hasSomeUnfolding NoUnfolding = False
340 hasSomeUnfolding other = True
342 neverUnfold :: Unfolding -> Bool
343 neverUnfold NoUnfolding = True
344 neverUnfold (OtherCon _) = True
345 neverUnfold (CoreUnfolding _ _ _ _ UnfoldNever) = True
346 neverUnfold other = False
350 %************************************************************************
352 \subsection{The main data type}
354 %************************************************************************
357 -- The Ord is needed for the FiniteMap used in the lookForConstructor
358 -- in SimplEnv. If you declared that lookForConstructor *ignores*
359 -- constructor-applications with LitArg args, then you could get
362 instance Outputable AltCon where
363 ppr (DataAlt dc) = ppr dc
364 ppr (LitAlt lit) = ppr lit
365 ppr DEFAULT = ptext SLIT("__DEFAULT")
367 instance Show AltCon where
368 showsPrec p con = showsPrecSDoc p (ppr con)
370 cmpAlt :: Alt b -> Alt b -> Ordering
371 cmpAlt (con1, _, _) (con2, _, _) = con1 `cmpAltCon` con2
373 ltAlt :: Alt b -> Alt b -> Bool
374 ltAlt a1 a2 = case a1 `cmpAlt` a2 of { LT -> True; other -> False }
376 cmpAltCon :: AltCon -> AltCon -> Ordering
377 -- Compares AltCons within a single list of alternatives
378 cmpAltCon DEFAULT DEFAULT = EQ
379 cmpAltCon DEFAULT con = LT
381 cmpAltCon (DataAlt d1) (DataAlt d2) = dataConTag d1 `compare` dataConTag d2
382 cmpAltCon (DataAlt _) DEFAULT = GT
383 cmpAltCon (LitAlt l1) (LitAlt l2) = l1 `compare` l2
384 cmpAltCon (LitAlt _) DEFAULT = GT
386 cmpAltCon con1 con2 = WARN( True, text "Comparing incomparable AltCons" <+>
387 ppr con1 <+> ppr con2 )
392 %************************************************************************
394 \subsection{Useful synonyms}
396 %************************************************************************
402 type CoreExpr = Expr CoreBndr
403 type CoreArg = Arg CoreBndr
404 type CoreBind = Bind CoreBndr
405 type CoreAlt = Alt CoreBndr
408 Binders are ``tagged'' with a \tr{t}:
411 data TaggedBndr t = TB CoreBndr t -- TB for "tagged binder"
413 type TaggedBind t = Bind (TaggedBndr t)
414 type TaggedExpr t = Expr (TaggedBndr t)
415 type TaggedArg t = Arg (TaggedBndr t)
416 type TaggedAlt t = Alt (TaggedBndr t)
418 instance Outputable b => Outputable (TaggedBndr b) where
419 ppr (TB b l) = char '<' <> ppr b <> comma <> ppr l <> char '>'
421 instance Outputable b => OutputableBndr (TaggedBndr b) where
422 pprBndr _ b = ppr b -- Simple
426 %************************************************************************
428 \subsection{Core-constructing functions with checking}
430 %************************************************************************
433 mkApps :: Expr b -> [Arg b] -> Expr b
434 mkTyApps :: Expr b -> [Type] -> Expr b
435 mkValApps :: Expr b -> [Expr b] -> Expr b
436 mkVarApps :: Expr b -> [Var] -> Expr b
438 mkApps f args = foldl App f args
439 mkTyApps f args = foldl (\ e a -> App e (Type a)) f args
440 mkValApps f args = foldl (\ e a -> App e a) f args
441 mkVarApps f vars = foldl (\ e a -> App e (varToCoreExpr a)) f vars
443 mkLit :: Literal -> Expr b
444 mkIntLit :: Integer -> Expr b
445 mkIntLitInt :: Int -> Expr b
446 mkConApp :: DataCon -> [Arg b] -> Expr b
447 mkLets :: [Bind b] -> Expr b -> Expr b
448 mkLams :: [b] -> Expr b -> Expr b
451 mkConApp con args = mkApps (Var (dataConWorkId con)) args
453 mkLams binders body = foldr Lam body binders
454 mkLets binds body = foldr Let body binds
456 mkIntLit n = Lit (mkMachInt n)
457 mkIntLitInt n = Lit (mkMachInt (toInteger n))
459 varToCoreExpr :: CoreBndr -> Expr b
460 varToCoreExpr v | isId v = Var v
461 | otherwise = Type (mkTyVarTy v)
463 varsToCoreExprs :: [CoreBndr] -> [Expr b]
464 varsToCoreExprs vs = map varToCoreExpr vs
466 mkCast :: Expr b -> Coercion -> Expr b
467 mkCast e co = Cast e co
471 %************************************************************************
473 \subsection{Simple access functions}
475 %************************************************************************
478 bindersOf :: Bind b -> [b]
479 bindersOf (NonRec binder _) = [binder]
480 bindersOf (Rec pairs) = [binder | (binder, _) <- pairs]
482 bindersOfBinds :: [Bind b] -> [b]
483 bindersOfBinds binds = foldr ((++) . bindersOf) [] binds
485 rhssOfBind :: Bind b -> [Expr b]
486 rhssOfBind (NonRec _ rhs) = [rhs]
487 rhssOfBind (Rec pairs) = [rhs | (_,rhs) <- pairs]
489 rhssOfAlts :: [Alt b] -> [Expr b]
490 rhssOfAlts alts = [e | (_,_,e) <- alts]
492 flattenBinds :: [Bind b] -> [(b, Expr b)] -- Get all the lhs/rhs pairs
493 flattenBinds (NonRec b r : binds) = (b,r) : flattenBinds binds
494 flattenBinds (Rec prs1 : binds) = prs1 ++ flattenBinds binds
498 We often want to strip off leading lambdas before getting down to
499 business. @collectBinders@ is your friend.
501 We expect (by convention) type-, and value- lambdas in that
505 collectBinders :: Expr b -> ([b], Expr b)
506 collectTyBinders :: CoreExpr -> ([TyVar], CoreExpr)
507 collectValBinders :: CoreExpr -> ([Id], CoreExpr)
508 collectTyAndValBinders :: CoreExpr -> ([TyVar], [Id], CoreExpr)
513 go bs (Lam b e) = go (b:bs) e
514 go bs e = (reverse bs, e)
516 collectTyAndValBinders expr
519 (tvs, body1) = collectTyBinders expr
520 (ids, body) = collectValBinders body1
522 collectTyBinders expr
525 go tvs (Lam b e) | isTyVar b = go (b:tvs) e
526 go tvs e = (reverse tvs, e)
528 collectValBinders expr
531 go ids (Lam b e) | isId b = go (b:ids) e
532 go ids body = (reverse ids, body)
536 @collectArgs@ takes an application expression, returning the function
537 and the arguments to which it is applied.
540 collectArgs :: Expr b -> (Expr b, [Arg b])
544 go (App f a) as = go f (a:as)
548 coreExprCc gets the cost centre enclosing an expression, if any.
549 It looks inside lambdas because (scc "foo" \x.e) = \x.scc "foo" e
552 coreExprCc :: Expr b -> CostCentre
553 coreExprCc (Note (SCC cc) e) = cc
554 coreExprCc (Note other_note e) = coreExprCc e
555 coreExprCc (Lam _ e) = coreExprCc e
556 coreExprCc other = noCostCentre
561 %************************************************************************
563 \subsection{Predicates}
565 %************************************************************************
567 @isRuntimeVar v@ returns if (Lam v _) really becomes a lambda at runtime,
568 i.e. if type applications are actual lambdas because types are kept around
571 Similarly isRuntimeArg.
574 isRuntimeVar :: Var -> Bool
575 isRuntimeVar | opt_RuntimeTypes = \v -> True
576 | otherwise = \v -> isId v
578 isRuntimeArg :: CoreExpr -> Bool
579 isRuntimeArg | opt_RuntimeTypes = \e -> True
580 | otherwise = \e -> isValArg e
584 isValArg (Type _) = False
585 isValArg other = True
587 isTypeArg (Type _) = True
588 isTypeArg other = False
590 valBndrCount :: [CoreBndr] -> Int
592 valBndrCount (b : bs) | isId b = 1 + valBndrCount bs
593 | otherwise = valBndrCount bs
595 valArgCount :: [Arg b] -> Int
597 valArgCount (Type _ : args) = valArgCount args
598 valArgCount (other : args) = 1 + valArgCount args
602 %************************************************************************
604 \subsection{Seq stuff}
606 %************************************************************************
609 seqExpr :: CoreExpr -> ()
610 seqExpr (Var v) = v `seq` ()
611 seqExpr (Lit lit) = lit `seq` ()
612 seqExpr (App f a) = seqExpr f `seq` seqExpr a
613 seqExpr (Lam b e) = seqBndr b `seq` seqExpr e
614 seqExpr (Let b e) = seqBind b `seq` seqExpr e
615 seqExpr (Case e b t as) = seqExpr e `seq` seqBndr b `seq` seqType t `seq` seqAlts as
616 seqExpr (Cast e co) = seqExpr e `seq` seqType co
617 seqExpr (Note n e) = seqNote n `seq` seqExpr e
618 seqExpr (Type t) = seqType t
621 seqExprs (e:es) = seqExpr e `seq` seqExprs es
623 seqNote (CoreNote s) = s `seq` ()
624 seqNote (TickBox m n) = m `seq` () -- no need for seq on n, because n is strict
625 seqNote (BinaryTickBox m t f)
626 = m `seq` () -- likewise on t and f.
629 seqBndr b = b `seq` ()
632 seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
634 seqBind (NonRec b e) = seqBndr b `seq` seqExpr e
635 seqBind (Rec prs) = seqPairs prs
638 seqPairs ((b,e):prs) = seqBndr b `seq` seqExpr e `seq` seqPairs prs
641 seqAlts ((c,bs,e):alts) = seqBndrs bs `seq` seqExpr e `seq` seqAlts alts
644 seqRules (Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs } : rules)
645 = seqBndrs bndrs `seq` seqExprs (rhs:args) `seq` seqRules rules
646 seqRules (BuiltinRule {} : rules) = seqRules rules
651 %************************************************************************
653 \subsection{Annotated core; annotation at every node in the tree}
655 %************************************************************************
658 type AnnExpr bndr annot = (annot, AnnExpr' bndr annot)
660 data AnnExpr' bndr annot
663 | AnnLam bndr (AnnExpr bndr annot)
664 | AnnApp (AnnExpr bndr annot) (AnnExpr bndr annot)
665 | AnnCase (AnnExpr bndr annot) bndr Type [AnnAlt bndr annot]
666 | AnnLet (AnnBind bndr annot) (AnnExpr bndr annot)
667 | AnnCast (AnnExpr bndr annot) Coercion
668 | AnnNote Note (AnnExpr bndr annot)
671 type AnnAlt bndr annot = (AltCon, [bndr], AnnExpr bndr annot)
673 data AnnBind bndr annot
674 = AnnNonRec bndr (AnnExpr bndr annot)
675 | AnnRec [(bndr, AnnExpr bndr annot)]
679 deAnnotate :: AnnExpr bndr annot -> Expr bndr
680 deAnnotate (_, e) = deAnnotate' e
682 deAnnotate' (AnnType t) = Type t
683 deAnnotate' (AnnVar v) = Var v
684 deAnnotate' (AnnLit lit) = Lit lit
685 deAnnotate' (AnnLam binder body) = Lam binder (deAnnotate body)
686 deAnnotate' (AnnApp fun arg) = App (deAnnotate fun) (deAnnotate arg)
687 deAnnotate' (AnnCast e co) = Cast (deAnnotate e) co
688 deAnnotate' (AnnNote note body) = Note note (deAnnotate body)
690 deAnnotate' (AnnLet bind body)
691 = Let (deAnnBind bind) (deAnnotate body)
693 deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs)
694 deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs]
696 deAnnotate' (AnnCase scrut v t alts)
697 = Case (deAnnotate scrut) v t (map deAnnAlt alts)
699 deAnnAlt :: AnnAlt bndr annot -> Alt bndr
700 deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs)
704 collectAnnBndrs :: AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot)
708 collect bs (_, AnnLam b body) = collect (b:bs) body
709 collect bs body = (reverse bs, body)