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"
64 infixl 4 `mkApps`, `mkValApps`, `mkTyApps`, `mkVarApps`
65 -- Left associative, so that we can say (f `mkTyApps` xs `mkVarApps` ys)
68 %************************************************************************
70 \subsection{The main data types}
72 %************************************************************************
74 These data types are the heart of the compiler
77 infixl 8 `App` -- App brackets to the left
79 data Expr b -- "b" for the type of binders,
82 | App (Expr b) (Arg b)
84 | Let (Bind b) (Expr b)
85 | Case (Expr b) b Type [Alt b] -- Binder gets bound to value of scrutinee
86 -- Invariant: The list of alternatives is ALWAYS EXHAUSTIVE,
87 -- meaning that it covers all cases that can occur
88 -- See the example below
90 -- Invariant: The DEFAULT case must be *first*, if it occurs at all
91 -- Invariant: The remaining cases are in order of increasing
94 -- This makes finding the relevant constructor easy,
95 -- and makes comparison easier too
96 | Cast (Expr b) Coercion
98 | Type Type -- This should only show up at the top
101 -- An "exhausive" case does not necessarily mention all constructors:
102 -- data Foo = Red | Green | Blue
106 -- other -> f (case x of
109 -- The inner case does not need a Red alternative, because x can't be Red at
110 -- that program point.
113 type Arg b = Expr b -- Can be a Type
115 type Alt b = (AltCon, [b], Expr b) -- (DEFAULT, [], rhs) is the default alternative
117 data AltCon = DataAlt DataCon -- Invariant: the DataCon is always from
118 -- a *data* type, and never from a *newtype*
124 data Bind b = NonRec b (Expr b)
125 | Rec [(b, (Expr b))]
130 | InlineMe -- Instructs simplifer to treat the enclosed expression
131 -- as very small, and inline it at its call sites
133 | CoreNote String -- A generic core annotation, propagated but not used by GHC
135 -- NOTE: we also treat expressions wrapped in InlineMe as
136 -- 'cheap' and 'dupable' (in the sense of exprIsCheap, exprIsDupable)
137 -- What this means is that we obediently inline even things that don't
138 -- look like valuse. This is sometimes important:
141 -- Here, f looks like a redex, and we aren't going to inline (.) because it's
142 -- inside an INLINE, so it'll stay looking like a redex. Nevertheless, we
143 -- should inline f even inside lambdas. In effect, we should trust the programmer.
148 * The RHS of a letrec, and the RHSs of all top-level lets,
149 must be of LIFTED type.
151 * The RHS of a let, may be of UNLIFTED type, but only if the expression
152 is ok-for-speculation. This means that the let can be floated around
153 without difficulty. e.g.
155 y::Int# = fac 4# not ok [use case instead]
157 * The argument of an App can be of any type.
159 * The simplifier tries to ensure that if the RHS of a let is a constructor
160 application, its arguments are trivial, so that the constructor can be
164 %************************************************************************
166 \subsection{Transformation rules}
168 %************************************************************************
170 The CoreRule type and its friends are dealt with mainly in CoreRules,
171 but CoreFVs, Subst, PprCore, CoreTidy also inspect the representation.
175 "local" if the function it is a rule for is defined in the
176 same module as the rule itself.
178 "orphan" if nothing on the LHS is defined in the same module
182 type RuleName = FastString
187 ru_act :: Activation, -- When the rule is active
189 -- Rough-matching stuff
190 -- see comments with InstEnv.Instance( is_cls, is_rough )
191 ru_fn :: Name, -- Name of the Id at the head of this rule
192 ru_rough :: [Maybe Name], -- Name at the head of each argument
194 -- Proper-matching stuff
195 -- see comments with InstEnv.Instance( is_tvs, is_tys )
196 ru_bndrs :: [CoreBndr], -- Forall'd variables
197 ru_args :: [CoreExpr], -- LHS args
199 -- And the right-hand side
203 ru_local :: Bool, -- The fn at the head of the rule is
204 -- defined in the same module as the rule
206 -- Orphan-hood; see Note [Orphans] in InstEnv
207 ru_orph :: Maybe OccName }
209 | BuiltinRule { -- Built-in rules are used for constant folding
210 ru_name :: RuleName, -- and suchlike. It has no free variables.
211 ru_fn :: Name, -- Name of the Id at
212 -- the head of this rule
213 ru_nargs :: Int, -- Number of args that ru_try expects
214 ru_try :: [CoreExpr] -> Maybe CoreExpr }
216 isBuiltinRule (BuiltinRule {}) = True
217 isBuiltinRule _ = False
219 ruleArity :: CoreRule -> Int
220 ruleArity (BuiltinRule {ru_nargs = n}) = n
221 ruleArity (Rule {ru_args = args}) = length args
223 ruleName :: CoreRule -> RuleName
226 ruleIdName :: CoreRule -> Name
229 isLocalRule :: CoreRule -> Bool
230 isLocalRule = ru_local
234 %************************************************************************
238 %************************************************************************
240 The @Unfolding@ type is declared here to avoid numerous loops, but it
241 should be abstract everywhere except in CoreUnfold.lhs
247 | OtherCon [AltCon] -- It ain't one of these
248 -- (OtherCon xs) also indicates that something has been evaluated
249 -- and hence there's no point in re-evaluating it.
250 -- OtherCon [] is used even for non-data-type values
251 -- to indicated evaluated-ness. Notably:
252 -- data C = C !(Int -> Int)
253 -- case x of { C f -> ... }
254 -- Here, f gets an OtherCon [] unfolding.
256 | CompulsoryUnfolding CoreExpr -- There is no "original" definition,
257 -- so you'd better unfold.
259 | CoreUnfolding -- An unfolding with redundant cached information
260 CoreExpr -- Template; binder-info is correct
261 Bool -- True <=> top level binding
262 Bool -- exprIsHNF template (cached); it is ok to discard a `seq` on
264 Bool -- True <=> doesn't waste (much) work to expand inside an inlining
265 -- Basically it's exprIsCheap
266 UnfoldingGuidance -- Tells about the *size* of the template.
269 data UnfoldingGuidance
271 | UnfoldIfGoodArgs Int -- and "n" value args
273 [Int] -- Discount if the argument is evaluated.
274 -- (i.e., a simplification will definitely
275 -- be possible). One elt of the list per *value* arg.
277 Int -- The "size" of the unfolding; to be elaborated
280 Int -- Scrutinee discount: the discount to substract if the thing is in
281 -- a context (case (thing args) of ...),
282 -- (where there are the right number of arguments.)
284 noUnfolding = NoUnfolding
285 evaldUnfolding = OtherCon []
287 mkOtherCon = OtherCon
289 seqUnfolding :: Unfolding -> ()
290 seqUnfolding (CoreUnfolding e top b1 b2 g)
291 = seqExpr e `seq` top `seq` b1 `seq` b2 `seq` seqGuidance g
292 seqUnfolding other = ()
294 seqGuidance (UnfoldIfGoodArgs n ns a b) = n `seq` sum ns `seq` a `seq` b `seq` ()
295 seqGuidance other = ()
299 unfoldingTemplate :: Unfolding -> CoreExpr
300 unfoldingTemplate (CoreUnfolding expr _ _ _ _) = expr
301 unfoldingTemplate (CompulsoryUnfolding expr) = expr
302 unfoldingTemplate other = panic "getUnfoldingTemplate"
304 maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr
305 maybeUnfoldingTemplate (CoreUnfolding expr _ _ _ _) = Just expr
306 maybeUnfoldingTemplate (CompulsoryUnfolding expr) = Just expr
307 maybeUnfoldingTemplate other = Nothing
309 otherCons :: Unfolding -> [AltCon]
310 otherCons (OtherCon cons) = cons
313 isValueUnfolding :: Unfolding -> Bool
314 -- Returns False for OtherCon
315 isValueUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald
316 isValueUnfolding other = False
318 isEvaldUnfolding :: Unfolding -> Bool
319 -- Returns True for OtherCon
320 isEvaldUnfolding (OtherCon _) = True
321 isEvaldUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald
322 isEvaldUnfolding other = False
324 isCheapUnfolding :: Unfolding -> Bool
325 isCheapUnfolding (CoreUnfolding _ _ _ is_cheap _) = is_cheap
326 isCheapUnfolding other = False
328 isCompulsoryUnfolding :: Unfolding -> Bool
329 isCompulsoryUnfolding (CompulsoryUnfolding _) = True
330 isCompulsoryUnfolding other = False
332 hasUnfolding :: Unfolding -> Bool
333 hasUnfolding (CoreUnfolding _ _ _ _ _) = True
334 hasUnfolding (CompulsoryUnfolding _) = True
335 hasUnfolding other = False
337 hasSomeUnfolding :: Unfolding -> Bool
338 hasSomeUnfolding NoUnfolding = False
339 hasSomeUnfolding other = True
341 neverUnfold :: Unfolding -> Bool
342 neverUnfold NoUnfolding = True
343 neverUnfold (OtherCon _) = True
344 neverUnfold (CoreUnfolding _ _ _ _ UnfoldNever) = True
345 neverUnfold other = False
349 %************************************************************************
351 \subsection{The main data type}
353 %************************************************************************
356 -- The Ord is needed for the FiniteMap used in the lookForConstructor
357 -- in SimplEnv. If you declared that lookForConstructor *ignores*
358 -- constructor-applications with LitArg args, then you could get
361 instance Outputable AltCon where
362 ppr (DataAlt dc) = ppr dc
363 ppr (LitAlt lit) = ppr lit
364 ppr DEFAULT = ptext SLIT("__DEFAULT")
366 instance Show AltCon where
367 showsPrec p con = showsPrecSDoc p (ppr con)
369 cmpAlt :: Alt b -> Alt b -> Ordering
370 cmpAlt (con1, _, _) (con2, _, _) = con1 `cmpAltCon` con2
372 ltAlt :: Alt b -> Alt b -> Bool
373 ltAlt a1 a2 = case a1 `cmpAlt` a2 of { LT -> True; other -> False }
375 cmpAltCon :: AltCon -> AltCon -> Ordering
376 -- Compares AltCons within a single list of alternatives
377 cmpAltCon DEFAULT DEFAULT = EQ
378 cmpAltCon DEFAULT con = LT
380 cmpAltCon (DataAlt d1) (DataAlt d2) = dataConTag d1 `compare` dataConTag d2
381 cmpAltCon (DataAlt _) DEFAULT = GT
382 cmpAltCon (LitAlt l1) (LitAlt l2) = l1 `compare` l2
383 cmpAltCon (LitAlt _) DEFAULT = GT
385 cmpAltCon con1 con2 = WARN( True, text "Comparing incomparable AltCons" <+>
386 ppr con1 <+> ppr con2 )
391 %************************************************************************
393 \subsection{Useful synonyms}
395 %************************************************************************
401 type CoreExpr = Expr CoreBndr
402 type CoreArg = Arg CoreBndr
403 type CoreBind = Bind CoreBndr
404 type CoreAlt = Alt CoreBndr
407 Binders are ``tagged'' with a \tr{t}:
410 data TaggedBndr t = TB CoreBndr t -- TB for "tagged binder"
412 type TaggedBind t = Bind (TaggedBndr t)
413 type TaggedExpr t = Expr (TaggedBndr t)
414 type TaggedArg t = Arg (TaggedBndr t)
415 type TaggedAlt t = Alt (TaggedBndr t)
417 instance Outputable b => Outputable (TaggedBndr b) where
418 ppr (TB b l) = char '<' <> ppr b <> comma <> ppr l <> char '>'
420 instance Outputable b => OutputableBndr (TaggedBndr b) where
421 pprBndr _ b = ppr b -- Simple
425 %************************************************************************
427 \subsection{Core-constructing functions with checking}
429 %************************************************************************
432 mkApps :: Expr b -> [Arg b] -> Expr b
433 mkTyApps :: Expr b -> [Type] -> Expr b
434 mkValApps :: Expr b -> [Expr b] -> Expr b
435 mkVarApps :: Expr b -> [Var] -> Expr b
437 mkApps f args = foldl App f args
438 mkTyApps f args = foldl (\ e a -> App e (Type a)) f args
439 mkValApps f args = foldl (\ e a -> App e a) f args
440 mkVarApps f vars = foldl (\ e a -> App e (varToCoreExpr a)) f vars
442 mkLit :: Literal -> Expr b
443 mkIntLit :: Integer -> Expr b
444 mkIntLitInt :: Int -> Expr b
445 mkConApp :: DataCon -> [Arg b] -> Expr b
446 mkLets :: [Bind b] -> Expr b -> Expr b
447 mkLams :: [b] -> Expr b -> Expr b
450 mkConApp con args = mkApps (Var (dataConWorkId con)) args
452 mkLams binders body = foldr Lam body binders
453 mkLets binds body = foldr Let body binds
455 mkIntLit n = Lit (mkMachInt n)
456 mkIntLitInt n = Lit (mkMachInt (toInteger n))
458 varToCoreExpr :: CoreBndr -> Expr b
459 varToCoreExpr v | isId v = Var v
460 | otherwise = Type (mkTyVarTy v)
462 varsToCoreExprs :: [CoreBndr] -> [Expr b]
463 varsToCoreExprs vs = map varToCoreExpr vs
465 mkCast :: Expr b -> Coercion -> Expr b
466 mkCast e co = Cast e co
470 %************************************************************************
472 \subsection{Simple access functions}
474 %************************************************************************
477 bindersOf :: Bind b -> [b]
478 bindersOf (NonRec binder _) = [binder]
479 bindersOf (Rec pairs) = [binder | (binder, _) <- pairs]
481 bindersOfBinds :: [Bind b] -> [b]
482 bindersOfBinds binds = foldr ((++) . bindersOf) [] binds
484 rhssOfBind :: Bind b -> [Expr b]
485 rhssOfBind (NonRec _ rhs) = [rhs]
486 rhssOfBind (Rec pairs) = [rhs | (_,rhs) <- pairs]
488 rhssOfAlts :: [Alt b] -> [Expr b]
489 rhssOfAlts alts = [e | (_,_,e) <- alts]
491 flattenBinds :: [Bind b] -> [(b, Expr b)] -- Get all the lhs/rhs pairs
492 flattenBinds (NonRec b r : binds) = (b,r) : flattenBinds binds
493 flattenBinds (Rec prs1 : binds) = prs1 ++ flattenBinds binds
497 We often want to strip off leading lambdas before getting down to
498 business. @collectBinders@ is your friend.
500 We expect (by convention) type-, and value- lambdas in that
504 collectBinders :: Expr b -> ([b], Expr b)
505 collectTyBinders :: CoreExpr -> ([TyVar], CoreExpr)
506 collectValBinders :: CoreExpr -> ([Id], CoreExpr)
507 collectTyAndValBinders :: CoreExpr -> ([TyVar], [Id], CoreExpr)
512 go bs (Lam b e) = go (b:bs) e
513 go bs e = (reverse bs, e)
515 collectTyAndValBinders expr
518 (tvs, body1) = collectTyBinders expr
519 (ids, body) = collectValBinders body1
521 collectTyBinders expr
524 go tvs (Lam b e) | isTyVar b = go (b:tvs) e
525 go tvs e = (reverse tvs, e)
527 collectValBinders expr
530 go ids (Lam b e) | isId b = go (b:ids) e
531 go ids body = (reverse ids, body)
535 @collectArgs@ takes an application expression, returning the function
536 and the arguments to which it is applied.
539 collectArgs :: Expr b -> (Expr b, [Arg b])
543 go (App f a) as = go f (a:as)
547 coreExprCc gets the cost centre enclosing an expression, if any.
548 It looks inside lambdas because (scc "foo" \x.e) = \x.scc "foo" e
551 coreExprCc :: Expr b -> CostCentre
552 coreExprCc (Note (SCC cc) e) = cc
553 coreExprCc (Note other_note e) = coreExprCc e
554 coreExprCc (Lam _ e) = coreExprCc e
555 coreExprCc other = noCostCentre
560 %************************************************************************
562 \subsection{Predicates}
564 %************************************************************************
566 @isRuntimeVar v@ returns if (Lam v _) really becomes a lambda at runtime,
567 i.e. if type applications are actual lambdas because types are kept around
570 Similarly isRuntimeArg.
573 isRuntimeVar :: Var -> Bool
574 isRuntimeVar | opt_RuntimeTypes = \v -> True
575 | otherwise = \v -> isId v
577 isRuntimeArg :: CoreExpr -> Bool
578 isRuntimeArg | opt_RuntimeTypes = \e -> True
579 | otherwise = \e -> isValArg e
583 isValArg (Type _) = False
584 isValArg other = True
586 isTypeArg (Type _) = True
587 isTypeArg other = False
589 valBndrCount :: [CoreBndr] -> Int
591 valBndrCount (b : bs) | isId b = 1 + valBndrCount bs
592 | otherwise = valBndrCount bs
594 valArgCount :: [Arg b] -> Int
596 valArgCount (Type _ : args) = valArgCount args
597 valArgCount (other : args) = 1 + valArgCount args
601 %************************************************************************
603 \subsection{Seq stuff}
605 %************************************************************************
608 seqExpr :: CoreExpr -> ()
609 seqExpr (Var v) = v `seq` ()
610 seqExpr (Lit lit) = lit `seq` ()
611 seqExpr (App f a) = seqExpr f `seq` seqExpr a
612 seqExpr (Lam b e) = seqBndr b `seq` seqExpr e
613 seqExpr (Let b e) = seqBind b `seq` seqExpr e
614 seqExpr (Case e b t as) = seqExpr e `seq` seqBndr b `seq` seqType t `seq` seqAlts as
615 seqExpr (Cast e co) = seqExpr e `seq` seqType co
616 seqExpr (Note n e) = seqNote n `seq` seqExpr e
617 seqExpr (Type t) = seqType t
620 seqExprs (e:es) = seqExpr e `seq` seqExprs es
622 seqNote (CoreNote s) = s `seq` ()
625 seqBndr b = b `seq` ()
628 seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
630 seqBind (NonRec b e) = seqBndr b `seq` seqExpr e
631 seqBind (Rec prs) = seqPairs prs
634 seqPairs ((b,e):prs) = seqBndr b `seq` seqExpr e `seq` seqPairs prs
637 seqAlts ((c,bs,e):alts) = seqBndrs bs `seq` seqExpr e `seq` seqAlts alts
640 seqRules (Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs } : rules)
641 = seqBndrs bndrs `seq` seqExprs (rhs:args) `seq` seqRules rules
642 seqRules (BuiltinRule {} : rules) = seqRules rules
647 %************************************************************************
649 \subsection{Annotated core; annotation at every node in the tree}
651 %************************************************************************
654 type AnnExpr bndr annot = (annot, AnnExpr' bndr annot)
656 data AnnExpr' bndr annot
659 | AnnLam bndr (AnnExpr bndr annot)
660 | AnnApp (AnnExpr bndr annot) (AnnExpr bndr annot)
661 | AnnCase (AnnExpr bndr annot) bndr Type [AnnAlt bndr annot]
662 | AnnLet (AnnBind bndr annot) (AnnExpr bndr annot)
663 | AnnCast (AnnExpr bndr annot) Coercion
664 | AnnNote Note (AnnExpr bndr annot)
667 type AnnAlt bndr annot = (AltCon, [bndr], AnnExpr bndr annot)
669 data AnnBind bndr annot
670 = AnnNonRec bndr (AnnExpr bndr annot)
671 | AnnRec [(bndr, AnnExpr bndr annot)]
675 deAnnotate :: AnnExpr bndr annot -> Expr bndr
676 deAnnotate (_, e) = deAnnotate' e
678 deAnnotate' (AnnType t) = Type t
679 deAnnotate' (AnnVar v) = Var v
680 deAnnotate' (AnnLit lit) = Lit lit
681 deAnnotate' (AnnLam binder body) = Lam binder (deAnnotate body)
682 deAnnotate' (AnnApp fun arg) = App (deAnnotate fun) (deAnnotate arg)
683 deAnnotate' (AnnCast e co) = Cast (deAnnotate e) co
684 deAnnotate' (AnnNote note body) = Note note (deAnnotate body)
686 deAnnotate' (AnnLet bind body)
687 = Let (deAnnBind bind) (deAnnotate body)
689 deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs)
690 deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs]
692 deAnnotate' (AnnCase scrut v t alts)
693 = Case (deAnnotate scrut) v t (map deAnnAlt alts)
695 deAnnAlt :: AnnAlt bndr annot -> Alt bndr
696 deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs)
700 collectAnnBndrs :: AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot)
704 collect bs (_, AnnLam b body) = collect (b:bs) body
705 collect bs body = (reverse bs, body)