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"
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_try :: [CoreExpr] -> Maybe CoreExpr }
215 isBuiltinRule (BuiltinRule {}) = True
216 isBuiltinRule _ = False
218 ruleName :: CoreRule -> RuleName
221 ruleIdName :: CoreRule -> Name
224 isLocalRule :: CoreRule -> Bool
225 isLocalRule = ru_local
229 %************************************************************************
233 %************************************************************************
235 The @Unfolding@ type is declared here to avoid numerous loops, but it
236 should be abstract everywhere except in CoreUnfold.lhs
242 | OtherCon [AltCon] -- It ain't one of these
243 -- (OtherCon xs) also indicates that something has been evaluated
244 -- and hence there's no point in re-evaluating it.
245 -- OtherCon [] is used even for non-data-type values
246 -- to indicated evaluated-ness. Notably:
247 -- data C = C !(Int -> Int)
248 -- case x of { C f -> ... }
249 -- Here, f gets an OtherCon [] unfolding.
251 | CompulsoryUnfolding CoreExpr -- There is no "original" definition,
252 -- so you'd better unfold.
254 | CoreUnfolding -- An unfolding with redundant cached information
255 CoreExpr -- Template; binder-info is correct
256 Bool -- True <=> top level binding
257 Bool -- exprIsHNF template (cached); it is ok to discard a `seq` on
259 Bool -- True <=> doesn't waste (much) work to expand inside an inlining
260 -- Basically it's exprIsCheap
261 UnfoldingGuidance -- Tells about the *size* of the template.
264 data UnfoldingGuidance
266 | UnfoldIfGoodArgs Int -- and "n" value args
268 [Int] -- Discount if the argument is evaluated.
269 -- (i.e., a simplification will definitely
270 -- be possible). One elt of the list per *value* arg.
272 Int -- The "size" of the unfolding; to be elaborated
275 Int -- Scrutinee discount: the discount to substract if the thing is in
276 -- a context (case (thing args) of ...),
277 -- (where there are the right number of arguments.)
279 noUnfolding = NoUnfolding
280 evaldUnfolding = OtherCon []
282 mkOtherCon = OtherCon
284 seqUnfolding :: Unfolding -> ()
285 seqUnfolding (CoreUnfolding e top b1 b2 g)
286 = seqExpr e `seq` top `seq` b1 `seq` b2 `seq` seqGuidance g
287 seqUnfolding other = ()
289 seqGuidance (UnfoldIfGoodArgs n ns a b) = n `seq` sum ns `seq` a `seq` b `seq` ()
290 seqGuidance other = ()
294 unfoldingTemplate :: Unfolding -> CoreExpr
295 unfoldingTemplate (CoreUnfolding expr _ _ _ _) = expr
296 unfoldingTemplate (CompulsoryUnfolding expr) = expr
297 unfoldingTemplate other = panic "getUnfoldingTemplate"
299 maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr
300 maybeUnfoldingTemplate (CoreUnfolding expr _ _ _ _) = Just expr
301 maybeUnfoldingTemplate (CompulsoryUnfolding expr) = Just expr
302 maybeUnfoldingTemplate other = Nothing
304 otherCons :: Unfolding -> [AltCon]
305 otherCons (OtherCon cons) = cons
308 isValueUnfolding :: Unfolding -> Bool
309 -- Returns False for OtherCon
310 isValueUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald
311 isValueUnfolding other = False
313 isEvaldUnfolding :: Unfolding -> Bool
314 -- Returns True for OtherCon
315 isEvaldUnfolding (OtherCon _) = True
316 isEvaldUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald
317 isEvaldUnfolding other = False
319 isCheapUnfolding :: Unfolding -> Bool
320 isCheapUnfolding (CoreUnfolding _ _ _ is_cheap _) = is_cheap
321 isCheapUnfolding other = False
323 isCompulsoryUnfolding :: Unfolding -> Bool
324 isCompulsoryUnfolding (CompulsoryUnfolding _) = True
325 isCompulsoryUnfolding other = False
327 hasUnfolding :: Unfolding -> Bool
328 hasUnfolding (CoreUnfolding _ _ _ _ _) = True
329 hasUnfolding (CompulsoryUnfolding _) = True
330 hasUnfolding other = False
332 hasSomeUnfolding :: Unfolding -> Bool
333 hasSomeUnfolding NoUnfolding = False
334 hasSomeUnfolding other = True
336 neverUnfold :: Unfolding -> Bool
337 neverUnfold NoUnfolding = True
338 neverUnfold (OtherCon _) = True
339 neverUnfold (CoreUnfolding _ _ _ _ UnfoldNever) = True
340 neverUnfold other = False
344 %************************************************************************
346 \subsection{The main data type}
348 %************************************************************************
351 -- The Ord is needed for the FiniteMap used in the lookForConstructor
352 -- in SimplEnv. If you declared that lookForConstructor *ignores*
353 -- constructor-applications with LitArg args, then you could get
356 instance Outputable AltCon where
357 ppr (DataAlt dc) = ppr dc
358 ppr (LitAlt lit) = ppr lit
359 ppr DEFAULT = ptext SLIT("__DEFAULT")
361 instance Show AltCon where
362 showsPrec p con = showsPrecSDoc p (ppr con)
364 cmpAlt :: Alt b -> Alt b -> Ordering
365 cmpAlt (con1, _, _) (con2, _, _) = con1 `cmpAltCon` con2
367 ltAlt :: Alt b -> Alt b -> Bool
368 ltAlt a1 a2 = case a1 `cmpAlt` a2 of { LT -> True; other -> False }
370 cmpAltCon :: AltCon -> AltCon -> Ordering
371 -- Compares AltCons within a single list of alternatives
372 cmpAltCon DEFAULT DEFAULT = EQ
373 cmpAltCon DEFAULT con = LT
375 cmpAltCon (DataAlt d1) (DataAlt d2) = dataConTag d1 `compare` dataConTag d2
376 cmpAltCon (DataAlt _) DEFAULT = GT
377 cmpAltCon (LitAlt l1) (LitAlt l2) = l1 `compare` l2
378 cmpAltCon (LitAlt _) DEFAULT = GT
380 cmpAltCon con1 con2 = WARN( True, text "Comparing incomparable AltCons" <+>
381 ppr con1 <+> ppr con2 )
386 %************************************************************************
388 \subsection{Useful synonyms}
390 %************************************************************************
396 type CoreExpr = Expr CoreBndr
397 type CoreArg = Arg CoreBndr
398 type CoreBind = Bind CoreBndr
399 type CoreAlt = Alt CoreBndr
402 Binders are ``tagged'' with a \tr{t}:
405 data TaggedBndr t = TB CoreBndr t -- TB for "tagged binder"
407 type TaggedBind t = Bind (TaggedBndr t)
408 type TaggedExpr t = Expr (TaggedBndr t)
409 type TaggedArg t = Arg (TaggedBndr t)
410 type TaggedAlt t = Alt (TaggedBndr t)
412 instance Outputable b => Outputable (TaggedBndr b) where
413 ppr (TB b l) = char '<' <> ppr b <> comma <> ppr l <> char '>'
415 instance Outputable b => OutputableBndr (TaggedBndr b) where
416 pprBndr _ b = ppr b -- Simple
420 %************************************************************************
422 \subsection{Core-constructing functions with checking}
424 %************************************************************************
427 mkApps :: Expr b -> [Arg b] -> Expr b
428 mkTyApps :: Expr b -> [Type] -> Expr b
429 mkValApps :: Expr b -> [Expr b] -> Expr b
430 mkVarApps :: Expr b -> [Var] -> Expr b
432 mkApps f args = foldl App f args
433 mkTyApps f args = foldl (\ e a -> App e (Type a)) f args
434 mkValApps f args = foldl (\ e a -> App e a) f args
435 mkVarApps f vars = foldl (\ e a -> App e (varToCoreExpr a)) f vars
437 mkLit :: Literal -> Expr b
438 mkIntLit :: Integer -> Expr b
439 mkIntLitInt :: Int -> Expr b
440 mkConApp :: DataCon -> [Arg b] -> Expr b
441 mkLets :: [Bind b] -> Expr b -> Expr b
442 mkLams :: [b] -> Expr b -> Expr b
445 mkConApp con args = mkApps (Var (dataConWorkId con)) args
447 mkLams binders body = foldr Lam body binders
448 mkLets binds body = foldr Let body binds
450 mkIntLit n = Lit (mkMachInt n)
451 mkIntLitInt n = Lit (mkMachInt (toInteger n))
453 varToCoreExpr :: CoreBndr -> Expr b
454 varToCoreExpr v | isId v = Var v
455 | otherwise = Type (mkTyVarTy v)
457 varsToCoreExprs :: [CoreBndr] -> [Expr b]
458 varsToCoreExprs vs = map varToCoreExpr vs
460 mkCast :: Expr b -> Coercion -> Expr b
461 mkCast e co = Cast e co
465 %************************************************************************
467 \subsection{Simple access functions}
469 %************************************************************************
472 bindersOf :: Bind b -> [b]
473 bindersOf (NonRec binder _) = [binder]
474 bindersOf (Rec pairs) = [binder | (binder, _) <- pairs]
476 bindersOfBinds :: [Bind b] -> [b]
477 bindersOfBinds binds = foldr ((++) . bindersOf) [] binds
479 rhssOfBind :: Bind b -> [Expr b]
480 rhssOfBind (NonRec _ rhs) = [rhs]
481 rhssOfBind (Rec pairs) = [rhs | (_,rhs) <- pairs]
483 rhssOfAlts :: [Alt b] -> [Expr b]
484 rhssOfAlts alts = [e | (_,_,e) <- alts]
486 flattenBinds :: [Bind b] -> [(b, Expr b)] -- Get all the lhs/rhs pairs
487 flattenBinds (NonRec b r : binds) = (b,r) : flattenBinds binds
488 flattenBinds (Rec prs1 : binds) = prs1 ++ flattenBinds binds
492 We often want to strip off leading lambdas before getting down to
493 business. @collectBinders@ is your friend.
495 We expect (by convention) type-, and value- lambdas in that
499 collectBinders :: Expr b -> ([b], Expr b)
500 collectTyBinders :: CoreExpr -> ([TyVar], CoreExpr)
501 collectValBinders :: CoreExpr -> ([Id], CoreExpr)
502 collectTyAndValBinders :: CoreExpr -> ([TyVar], [Id], CoreExpr)
507 go bs (Lam b e) = go (b:bs) e
508 go bs e = (reverse bs, e)
510 collectTyAndValBinders expr
513 (tvs, body1) = collectTyBinders expr
514 (ids, body) = collectValBinders body1
516 collectTyBinders expr
519 go tvs (Lam b e) | isTyVar b = go (b:tvs) e
520 go tvs e = (reverse tvs, e)
522 collectValBinders expr
525 go ids (Lam b e) | isId b = go (b:ids) e
526 go ids body = (reverse ids, body)
530 @collectArgs@ takes an application expression, returning the function
531 and the arguments to which it is applied.
534 collectArgs :: Expr b -> (Expr b, [Arg b])
538 go (App f a) as = go f (a:as)
542 coreExprCc gets the cost centre enclosing an expression, if any.
543 It looks inside lambdas because (scc "foo" \x.e) = \x.scc "foo" e
546 coreExprCc :: Expr b -> CostCentre
547 coreExprCc (Note (SCC cc) e) = cc
548 coreExprCc (Note other_note e) = coreExprCc e
549 coreExprCc (Lam _ e) = coreExprCc e
550 coreExprCc other = noCostCentre
555 %************************************************************************
557 \subsection{Predicates}
559 %************************************************************************
561 @isRuntimeVar v@ returns if (Lam v _) really becomes a lambda at runtime,
562 i.e. if type applications are actual lambdas because types are kept around
565 Similarly isRuntimeArg.
568 isRuntimeVar :: Var -> Bool
569 isRuntimeVar | opt_RuntimeTypes = \v -> True
570 | otherwise = \v -> isId v
572 isRuntimeArg :: CoreExpr -> Bool
573 isRuntimeArg | opt_RuntimeTypes = \e -> True
574 | otherwise = \e -> isValArg e
578 isValArg (Type _) = False
579 isValArg other = True
581 isTypeArg (Type _) = True
582 isTypeArg other = False
584 valBndrCount :: [CoreBndr] -> Int
586 valBndrCount (b : bs) | isId b = 1 + valBndrCount bs
587 | otherwise = valBndrCount bs
589 valArgCount :: [Arg b] -> Int
591 valArgCount (Type _ : args) = valArgCount args
592 valArgCount (other : args) = 1 + valArgCount args
596 %************************************************************************
598 \subsection{Seq stuff}
600 %************************************************************************
603 seqExpr :: CoreExpr -> ()
604 seqExpr (Var v) = v `seq` ()
605 seqExpr (Lit lit) = lit `seq` ()
606 seqExpr (App f a) = seqExpr f `seq` seqExpr a
607 seqExpr (Lam b e) = seqBndr b `seq` seqExpr e
608 seqExpr (Let b e) = seqBind b `seq` seqExpr e
609 seqExpr (Case e b t as) = seqExpr e `seq` seqBndr b `seq` seqType t `seq` seqAlts as
610 seqExpr (Cast e co) = seqExpr e `seq` seqType co
611 seqExpr (Note n e) = seqNote n `seq` seqExpr e
612 seqExpr (Type t) = seqType t
615 seqExprs (e:es) = seqExpr e `seq` seqExprs es
617 seqNote (CoreNote s) = s `seq` ()
620 seqBndr b = b `seq` ()
623 seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
625 seqBind (NonRec b e) = seqBndr b `seq` seqExpr e
626 seqBind (Rec prs) = seqPairs prs
629 seqPairs ((b,e):prs) = seqBndr b `seq` seqExpr e `seq` seqPairs prs
632 seqAlts ((c,bs,e):alts) = seqBndrs bs `seq` seqExpr e `seq` seqAlts alts
635 seqRules (Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs } : rules)
636 = seqBndrs bndrs `seq` seqExprs (rhs:args) `seq` seqRules rules
637 seqRules (BuiltinRule {} : rules) = seqRules rules
642 %************************************************************************
644 \subsection{Annotated core; annotation at every node in the tree}
646 %************************************************************************
649 type AnnExpr bndr annot = (annot, AnnExpr' bndr annot)
651 data AnnExpr' bndr annot
654 | AnnLam bndr (AnnExpr bndr annot)
655 | AnnApp (AnnExpr bndr annot) (AnnExpr bndr annot)
656 | AnnCase (AnnExpr bndr annot) bndr Type [AnnAlt bndr annot]
657 | AnnLet (AnnBind bndr annot) (AnnExpr bndr annot)
658 | AnnCast (AnnExpr bndr annot) Coercion
659 | AnnNote Note (AnnExpr bndr annot)
662 type AnnAlt bndr annot = (AltCon, [bndr], AnnExpr bndr annot)
664 data AnnBind bndr annot
665 = AnnNonRec bndr (AnnExpr bndr annot)
666 | AnnRec [(bndr, AnnExpr bndr annot)]
670 deAnnotate :: AnnExpr bndr annot -> Expr bndr
671 deAnnotate (_, e) = deAnnotate' e
673 deAnnotate' (AnnType t) = Type t
674 deAnnotate' (AnnVar v) = Var v
675 deAnnotate' (AnnLit lit) = Lit lit
676 deAnnotate' (AnnLam binder body) = Lam binder (deAnnotate body)
677 deAnnotate' (AnnApp fun arg) = App (deAnnotate fun) (deAnnotate arg)
678 deAnnotate' (AnnCast e co) = Cast (deAnnotate e) co
679 deAnnotate' (AnnNote note body) = Note note (deAnnotate body)
681 deAnnotate' (AnnLet bind body)
682 = Let (deAnnBind bind) (deAnnotate body)
684 deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs)
685 deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs]
687 deAnnotate' (AnnCase scrut v t alts)
688 = Case (deAnnotate scrut) v t (map deAnnAlt alts)
690 deAnnAlt :: AnnAlt bndr annot -> Alt bndr
691 deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs)
695 collectAnnBndrs :: AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot)
699 collect bs (_, AnnLam b body) = collect (b:bs) body
700 collect bs body = (reverse bs, body)