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"
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_nargs :: Int, -- Number of args that ru_try expects
220 ru_try :: [CoreExpr] -> Maybe CoreExpr }
222 isBuiltinRule (BuiltinRule {}) = True
223 isBuiltinRule _ = False
225 ruleArity :: CoreRule -> Int
226 ruleArity (BuiltinRule {ru_nargs = n}) = n
227 ruleArity (Rule {ru_args = args}) = length args
229 ruleName :: CoreRule -> RuleName
232 ruleIdName :: CoreRule -> Name
235 isLocalRule :: CoreRule -> Bool
236 isLocalRule = ru_local
240 %************************************************************************
244 %************************************************************************
246 The @Unfolding@ type is declared here to avoid numerous loops, but it
247 should be abstract everywhere except in CoreUnfold.lhs
253 | OtherCon [AltCon] -- It ain't one of these
254 -- (OtherCon xs) also indicates that something has been evaluated
255 -- and hence there's no point in re-evaluating it.
256 -- OtherCon [] is used even for non-data-type values
257 -- to indicated evaluated-ness. Notably:
258 -- data C = C !(Int -> Int)
259 -- case x of { C f -> ... }
260 -- Here, f gets an OtherCon [] unfolding.
262 | CompulsoryUnfolding CoreExpr -- There is no "original" definition,
263 -- so you'd better unfold.
265 | CoreUnfolding -- An unfolding with redundant cached information
266 CoreExpr -- Template; binder-info is correct
267 Bool -- True <=> top level binding
268 Bool -- exprIsHNF template (cached); it is ok to discard a `seq` on
270 Bool -- True <=> doesn't waste (much) work to expand inside an inlining
271 -- Basically it's exprIsCheap
272 UnfoldingGuidance -- Tells about the *size* of the template.
275 data UnfoldingGuidance
277 | UnfoldIfGoodArgs Int -- and "n" value args
279 [Int] -- Discount if the argument is evaluated.
280 -- (i.e., a simplification will definitely
281 -- be possible). One elt of the list per *value* arg.
283 Int -- The "size" of the unfolding; to be elaborated
286 Int -- Scrutinee discount: the discount to substract if the thing is in
287 -- a context (case (thing args) of ...),
288 -- (where there are the right number of arguments.)
290 noUnfolding = NoUnfolding
291 evaldUnfolding = OtherCon []
293 mkOtherCon = OtherCon
295 seqUnfolding :: Unfolding -> ()
296 seqUnfolding (CoreUnfolding e top b1 b2 g)
297 = seqExpr e `seq` top `seq` b1 `seq` b2 `seq` seqGuidance g
298 seqUnfolding other = ()
300 seqGuidance (UnfoldIfGoodArgs n ns a b) = n `seq` sum ns `seq` a `seq` b `seq` ()
301 seqGuidance other = ()
305 unfoldingTemplate :: Unfolding -> CoreExpr
306 unfoldingTemplate (CoreUnfolding expr _ _ _ _) = expr
307 unfoldingTemplate (CompulsoryUnfolding expr) = expr
308 unfoldingTemplate other = panic "getUnfoldingTemplate"
310 maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr
311 maybeUnfoldingTemplate (CoreUnfolding expr _ _ _ _) = Just expr
312 maybeUnfoldingTemplate (CompulsoryUnfolding expr) = Just expr
313 maybeUnfoldingTemplate other = Nothing
315 otherCons :: Unfolding -> [AltCon]
316 otherCons (OtherCon cons) = cons
319 isValueUnfolding :: Unfolding -> Bool
320 -- Returns False for OtherCon
321 isValueUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald
322 isValueUnfolding other = False
324 isEvaldUnfolding :: Unfolding -> Bool
325 -- Returns True for OtherCon
326 isEvaldUnfolding (OtherCon _) = True
327 isEvaldUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald
328 isEvaldUnfolding other = False
330 isCheapUnfolding :: Unfolding -> Bool
331 isCheapUnfolding (CoreUnfolding _ _ _ is_cheap _) = is_cheap
332 isCheapUnfolding other = False
334 isCompulsoryUnfolding :: Unfolding -> Bool
335 isCompulsoryUnfolding (CompulsoryUnfolding _) = True
336 isCompulsoryUnfolding other = False
338 hasUnfolding :: Unfolding -> Bool
339 hasUnfolding (CoreUnfolding _ _ _ _ _) = True
340 hasUnfolding (CompulsoryUnfolding _) = True
341 hasUnfolding other = False
343 hasSomeUnfolding :: Unfolding -> Bool
344 hasSomeUnfolding NoUnfolding = False
345 hasSomeUnfolding other = True
347 neverUnfold :: Unfolding -> Bool
348 neverUnfold NoUnfolding = True
349 neverUnfold (OtherCon _) = True
350 neverUnfold (CoreUnfolding _ _ _ _ UnfoldNever) = True
351 neverUnfold other = False
355 %************************************************************************
357 \subsection{The main data type}
359 %************************************************************************
362 -- The Ord is needed for the FiniteMap used in the lookForConstructor
363 -- in SimplEnv. If you declared that lookForConstructor *ignores*
364 -- constructor-applications with LitArg args, then you could get
367 instance Outputable AltCon where
368 ppr (DataAlt dc) = ppr dc
369 ppr (LitAlt lit) = ppr lit
370 ppr DEFAULT = ptext SLIT("__DEFAULT")
372 instance Show AltCon where
373 showsPrec p con = showsPrecSDoc p (ppr con)
375 cmpAlt :: Alt b -> Alt b -> Ordering
376 cmpAlt (con1, _, _) (con2, _, _) = con1 `cmpAltCon` con2
378 ltAlt :: Alt b -> Alt b -> Bool
379 ltAlt a1 a2 = case a1 `cmpAlt` a2 of { LT -> True; other -> False }
381 cmpAltCon :: AltCon -> AltCon -> Ordering
382 -- Compares AltCons within a single list of alternatives
383 cmpAltCon DEFAULT DEFAULT = EQ
384 cmpAltCon DEFAULT con = LT
386 cmpAltCon (DataAlt d1) (DataAlt d2) = dataConTag d1 `compare` dataConTag d2
387 cmpAltCon (DataAlt _) DEFAULT = GT
388 cmpAltCon (LitAlt l1) (LitAlt l2) = l1 `compare` l2
389 cmpAltCon (LitAlt _) DEFAULT = GT
391 cmpAltCon con1 con2 = WARN( True, text "Comparing incomparable AltCons" <+>
392 ppr con1 <+> ppr con2 )
397 %************************************************************************
399 \subsection{Useful synonyms}
401 %************************************************************************
407 type CoreExpr = Expr CoreBndr
408 type CoreArg = Arg CoreBndr
409 type CoreBind = Bind CoreBndr
410 type CoreAlt = Alt CoreBndr
413 Binders are ``tagged'' with a \tr{t}:
416 data TaggedBndr t = TB CoreBndr t -- TB for "tagged binder"
418 type TaggedBind t = Bind (TaggedBndr t)
419 type TaggedExpr t = Expr (TaggedBndr t)
420 type TaggedArg t = Arg (TaggedBndr t)
421 type TaggedAlt t = Alt (TaggedBndr t)
423 instance Outputable b => Outputable (TaggedBndr b) where
424 ppr (TB b l) = char '<' <> ppr b <> comma <> ppr l <> char '>'
426 instance Outputable b => OutputableBndr (TaggedBndr b) where
427 pprBndr _ b = ppr b -- Simple
431 %************************************************************************
433 \subsection{Core-constructing functions with checking}
435 %************************************************************************
438 mkApps :: Expr b -> [Arg b] -> Expr b
439 mkTyApps :: Expr b -> [Type] -> Expr b
440 mkValApps :: Expr b -> [Expr b] -> Expr b
441 mkVarApps :: Expr b -> [Var] -> Expr b
443 mkApps f args = foldl App f args
444 mkTyApps f args = foldl (\ e a -> App e (Type a)) f args
445 mkValApps f args = foldl (\ e a -> App e a) f args
446 mkVarApps f vars = foldl (\ e a -> App e (varToCoreExpr a)) f vars
448 mkLit :: Literal -> Expr b
449 mkIntLit :: Integer -> Expr b
450 mkIntLitInt :: Int -> Expr b
451 mkConApp :: DataCon -> [Arg b] -> Expr b
452 mkLets :: [Bind b] -> Expr b -> Expr b
453 mkLams :: [b] -> Expr b -> Expr b
456 mkConApp con args = mkApps (Var (dataConWorkId con)) args
458 mkLams binders body = foldr Lam body binders
459 mkLets binds body = foldr Let body binds
461 mkIntLit n = Lit (mkMachInt n)
462 mkIntLitInt n = Lit (mkMachInt (toInteger n))
464 varToCoreExpr :: CoreBndr -> Expr b
465 varToCoreExpr v | isId v = Var v
466 | otherwise = Type (mkTyVarTy v)
468 varsToCoreExprs :: [CoreBndr] -> [Expr b]
469 varsToCoreExprs vs = map varToCoreExpr vs
471 mkCast :: Expr b -> Coercion -> Expr b
472 mkCast e co = Cast e co
476 %************************************************************************
478 \subsection{Simple access functions}
480 %************************************************************************
483 bindersOf :: Bind b -> [b]
484 bindersOf (NonRec binder _) = [binder]
485 bindersOf (Rec pairs) = [binder | (binder, _) <- pairs]
487 bindersOfBinds :: [Bind b] -> [b]
488 bindersOfBinds binds = foldr ((++) . bindersOf) [] binds
490 rhssOfBind :: Bind b -> [Expr b]
491 rhssOfBind (NonRec _ rhs) = [rhs]
492 rhssOfBind (Rec pairs) = [rhs | (_,rhs) <- pairs]
494 rhssOfAlts :: [Alt b] -> [Expr b]
495 rhssOfAlts alts = [e | (_,_,e) <- alts]
497 flattenBinds :: [Bind b] -> [(b, Expr b)] -- Get all the lhs/rhs pairs
498 flattenBinds (NonRec b r : binds) = (b,r) : flattenBinds binds
499 flattenBinds (Rec prs1 : binds) = prs1 ++ flattenBinds binds
503 We often want to strip off leading lambdas before getting down to
504 business. @collectBinders@ is your friend.
506 We expect (by convention) type-, and value- lambdas in that
510 collectBinders :: Expr b -> ([b], Expr b)
511 collectTyBinders :: CoreExpr -> ([TyVar], CoreExpr)
512 collectValBinders :: CoreExpr -> ([Id], CoreExpr)
513 collectTyAndValBinders :: CoreExpr -> ([TyVar], [Id], CoreExpr)
518 go bs (Lam b e) = go (b:bs) e
519 go bs e = (reverse bs, e)
521 collectTyAndValBinders expr
524 (tvs, body1) = collectTyBinders expr
525 (ids, body) = collectValBinders body1
527 collectTyBinders expr
530 go tvs (Lam b e) | isTyVar b = go (b:tvs) e
531 go tvs e = (reverse tvs, e)
533 collectValBinders expr
536 go ids (Lam b e) | isId b = go (b:ids) e
537 go ids body = (reverse ids, body)
541 @collectArgs@ takes an application expression, returning the function
542 and the arguments to which it is applied.
545 collectArgs :: Expr b -> (Expr b, [Arg b])
549 go (App f a) as = go f (a:as)
553 coreExprCc gets the cost centre enclosing an expression, if any.
554 It looks inside lambdas because (scc "foo" \x.e) = \x.scc "foo" e
557 coreExprCc :: Expr b -> CostCentre
558 coreExprCc (Note (SCC cc) e) = cc
559 coreExprCc (Note other_note e) = coreExprCc e
560 coreExprCc (Lam _ e) = coreExprCc e
561 coreExprCc other = noCostCentre
566 %************************************************************************
568 \subsection{Predicates}
570 %************************************************************************
572 @isRuntimeVar v@ returns if (Lam v _) really becomes a lambda at runtime,
573 i.e. if type applications are actual lambdas because types are kept around
576 Similarly isRuntimeArg.
579 isRuntimeVar :: Var -> Bool
580 isRuntimeVar | opt_RuntimeTypes = \v -> True
581 | otherwise = \v -> isId v
583 isRuntimeArg :: CoreExpr -> Bool
584 isRuntimeArg | opt_RuntimeTypes = \e -> True
585 | otherwise = \e -> isValArg e
589 isValArg (Type _) = False
590 isValArg other = True
592 isTypeArg (Type _) = True
593 isTypeArg other = False
595 valBndrCount :: [CoreBndr] -> Int
597 valBndrCount (b : bs) | isId b = 1 + valBndrCount bs
598 | otherwise = valBndrCount bs
600 valArgCount :: [Arg b] -> Int
602 valArgCount (Type _ : args) = valArgCount args
603 valArgCount (other : args) = 1 + valArgCount args
607 %************************************************************************
609 \subsection{Seq stuff}
611 %************************************************************************
614 seqExpr :: CoreExpr -> ()
615 seqExpr (Var v) = v `seq` ()
616 seqExpr (Lit lit) = lit `seq` ()
617 seqExpr (App f a) = seqExpr f `seq` seqExpr a
618 seqExpr (Lam b e) = seqBndr b `seq` seqExpr e
619 seqExpr (Let b e) = seqBind b `seq` seqExpr e
620 seqExpr (Case e b t as) = seqExpr e `seq` seqBndr b `seq` seqType t `seq` seqAlts as
621 seqExpr (Cast e co) = seqExpr e `seq` seqType co
622 seqExpr (Note n e) = seqNote n `seq` seqExpr e
623 seqExpr (Type t) = seqType t
626 seqExprs (e:es) = seqExpr e `seq` seqExprs es
628 seqNote (CoreNote s) = s `seq` ()
629 seqNote (TickBox m n) = m `seq` () -- no need for seq on n, because n is strict
630 seqNote (BinaryTickBox m t f)
631 = m `seq` () -- likewise on t and f.
634 seqBndr b = b `seq` ()
637 seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
639 seqBind (NonRec b e) = seqBndr b `seq` seqExpr e
640 seqBind (Rec prs) = seqPairs prs
643 seqPairs ((b,e):prs) = seqBndr b `seq` seqExpr e `seq` seqPairs prs
646 seqAlts ((c,bs,e):alts) = seqBndrs bs `seq` seqExpr e `seq` seqAlts alts
649 seqRules (Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs } : rules)
650 = seqBndrs bndrs `seq` seqExprs (rhs:args) `seq` seqRules rules
651 seqRules (BuiltinRule {} : rules) = seqRules rules
656 %************************************************************************
658 \subsection{Annotated core; annotation at every node in the tree}
660 %************************************************************************
663 type AnnExpr bndr annot = (annot, AnnExpr' bndr annot)
665 data AnnExpr' bndr annot
668 | AnnLam bndr (AnnExpr bndr annot)
669 | AnnApp (AnnExpr bndr annot) (AnnExpr bndr annot)
670 | AnnCase (AnnExpr bndr annot) bndr Type [AnnAlt bndr annot]
671 | AnnLet (AnnBind bndr annot) (AnnExpr bndr annot)
672 | AnnCast (AnnExpr bndr annot) Coercion
673 | AnnNote Note (AnnExpr bndr annot)
676 type AnnAlt bndr annot = (AltCon, [bndr], AnnExpr bndr annot)
678 data AnnBind bndr annot
679 = AnnNonRec bndr (AnnExpr bndr annot)
680 | AnnRec [(bndr, AnnExpr bndr annot)]
684 deAnnotate :: AnnExpr bndr annot -> Expr bndr
685 deAnnotate (_, e) = deAnnotate' e
687 deAnnotate' (AnnType t) = Type t
688 deAnnotate' (AnnVar v) = Var v
689 deAnnotate' (AnnLit lit) = Lit lit
690 deAnnotate' (AnnLam binder body) = Lam binder (deAnnotate body)
691 deAnnotate' (AnnApp fun arg) = App (deAnnotate fun) (deAnnotate arg)
692 deAnnotate' (AnnCast e co) = Cast (deAnnotate e) co
693 deAnnotate' (AnnNote note body) = Note note (deAnnotate body)
695 deAnnotate' (AnnLet bind body)
696 = Let (deAnnBind bind) (deAnnotate body)
698 deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs)
699 deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs]
701 deAnnotate' (AnnCase scrut v t alts)
702 = Case (deAnnotate scrut) v t (map deAnnAlt alts)
704 deAnnAlt :: AnnAlt bndr annot -> Alt bndr
705 deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs)
709 collectAnnBndrs :: AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot)
713 collect bs (_, AnnLam b body) = collect (b:bs) body
714 collect bs body = (reverse bs, body)