2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[CoreSyn]{A data type for the Haskell compiler midsection}
8 Expr(..), Alt, Bind(..), AltCon(..), Arg, Note(..),
9 CoreExpr, CoreAlt, CoreBind, CoreArg, CoreBndr,
10 TaggedExpr, TaggedAlt, TaggedBind, TaggedArg, TaggedBndr(..),
13 mkApps, mkTyApps, mkValApps, mkVarApps,
14 mkLit, mkIntLitInt, mkIntLit,
16 varToCoreExpr, varsToCoreExprs,
18 isTyVar, isId, cmpAltCon, cmpAlt, ltAlt,
19 bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts,
20 collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders,
25 isValArg, isTypeArg, valArgCount, valBndrCount, isRuntimeArg, isRuntimeVar,
28 Unfolding(..), UnfoldingGuidance(..), -- Both abstract everywhere but in CoreUnfold.lhs
29 noUnfolding, evaldUnfolding, mkOtherCon,
30 unfoldingTemplate, maybeUnfoldingTemplate, otherCons,
31 isValueUnfolding, isEvaldUnfolding, isCheapUnfolding, isCompulsoryUnfolding,
32 hasUnfolding, hasSomeUnfolding, neverUnfold,
35 seqExpr, seqExprs, seqUnfolding,
37 -- Annotated expressions
38 AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt,
39 deAnnotate, deAnnotate', deAnnAlt, collectAnnBndrs,
42 CoreRule(..), -- CoreSubst, CoreTidy, CoreFVs, PprCore only
44 isBuiltinRule, ruleName, isLocalRule, ruleIdName
47 #include "HsVersions.h"
49 import StaticFlags ( opt_RuntimeTypes )
50 import CostCentre ( CostCentre, noCostCentre )
51 import Var ( Var, Id, TyVar, isTyVar, isId )
52 import Type ( Type, mkTyVarTy, seqType )
53 import Coercion ( Coercion )
55 import OccName ( OccName )
56 import Literal ( Literal, mkMachInt )
57 import DataCon ( DataCon, dataConWorkId, dataConTag )
58 import BasicTypes ( Activation )
62 infixl 4 `mkApps`, `mkValApps`, `mkTyApps`, `mkVarApps`
63 -- Left associative, so that we can say (f `mkTyApps` xs `mkVarApps` ys)
66 %************************************************************************
68 \subsection{The main data types}
70 %************************************************************************
72 These data types are the heart of the compiler
75 infixl 8 `App` -- App brackets to the left
77 data Expr b -- "b" for the type of binders,
80 | App (Expr b) (Arg b)
82 | Let (Bind b) (Expr b)
83 | Case (Expr b) b Type [Alt b] -- Binder gets bound to value of scrutinee
84 -- Invariant: The list of alternatives is ALWAYS EXHAUSTIVE,
85 -- meaning that it covers all cases that can occur
86 -- See the example below
88 -- Invariant: The DEFAULT case must be *first*, if it occurs at all
89 -- Invariant: The remaining cases are in order of increasing
92 -- This makes finding the relevant constructor easy,
93 -- and makes comparison easier too
94 | Cast (Expr b) Coercion
96 | Type Type -- This should only show up at the top
99 -- An "exhausive" case does not necessarily mention all constructors:
100 -- data Foo = Red | Green | Blue
104 -- other -> f (case x of
107 -- The inner case does not need a Red alternative, because x can't be Red at
108 -- that program point.
111 type Arg b = Expr b -- Can be a Type
113 type Alt b = (AltCon, [b], Expr b) -- (DEFAULT, [], rhs) is the default alternative
115 data AltCon = DataAlt DataCon -- Invariant: the DataCon is always from
116 -- a *data* type, and never from a *newtype*
122 data Bind b = NonRec b (Expr b)
123 | Rec [(b, (Expr b))]
128 | InlineMe -- Instructs simplifer to treat the enclosed expression
129 -- as very small, and inline it at its call sites
131 | CoreNote String -- A generic core annotation, propagated but not used by GHC
133 -- NOTE: we also treat expressions wrapped in InlineMe as
134 -- 'cheap' and 'dupable' (in the sense of exprIsCheap, exprIsDupable)
135 -- What this means is that we obediently inline even things that don't
136 -- look like valuse. This is sometimes important:
139 -- Here, f looks like a redex, and we aren't going to inline (.) because it's
140 -- inside an INLINE, so it'll stay looking like a redex. Nevertheless, we
141 -- should inline f even inside lambdas. In effect, we should trust the programmer.
146 * The RHS of a letrec, and the RHSs of all top-level lets,
147 must be of LIFTED type.
149 * The RHS of a let, may be of UNLIFTED type, but only if the expression
150 is ok-for-speculation. This means that the let can be floated around
151 without difficulty. e.g.
153 y::Int# = fac 4# not ok [use case instead]
155 * The argument of an App can be of any type.
157 * The simplifier tries to ensure that if the RHS of a let is a constructor
158 application, its arguments are trivial, so that the constructor can be
162 %************************************************************************
164 \subsection{Transformation rules}
166 %************************************************************************
168 The CoreRule type and its friends are dealt with mainly in CoreRules,
169 but CoreFVs, Subst, PprCore, CoreTidy also inspect the representation.
173 "local" if the function it is a rule for is defined in the
174 same module as the rule itself.
176 "orphan" if nothing on the LHS is defined in the same module
180 type RuleName = FastString
185 ru_act :: Activation, -- When the rule is active
187 -- Rough-matching stuff
188 -- see comments with InstEnv.Instance( is_cls, is_rough )
189 ru_fn :: Name, -- Name of the Id at the head of this rule
190 ru_rough :: [Maybe Name], -- Name at the head of each argument
192 -- Proper-matching stuff
193 -- see comments with InstEnv.Instance( is_tvs, is_tys )
194 ru_bndrs :: [CoreBndr], -- Forall'd variables
195 ru_args :: [CoreExpr], -- LHS args
197 -- And the right-hand side
201 ru_local :: Bool, -- The fn at the head of the rule is
202 -- defined in the same module as the rule
204 -- Orphan-hood; see comments is InstEnv.Instance( is_orph )
205 ru_orph :: Maybe OccName }
207 | BuiltinRule { -- Built-in rules are used for constant folding
208 ru_name :: RuleName, -- and suchlike. It has no free variables.
209 ru_fn :: Name, -- Name of the Id at
210 -- the head of this rule
211 ru_try :: [CoreExpr] -> Maybe CoreExpr }
213 isBuiltinRule (BuiltinRule {}) = True
214 isBuiltinRule _ = False
216 ruleName :: CoreRule -> RuleName
219 ruleIdName :: CoreRule -> Name
222 isLocalRule :: CoreRule -> Bool
223 isLocalRule = ru_local
227 %************************************************************************
231 %************************************************************************
233 The @Unfolding@ type is declared here to avoid numerous loops, but it
234 should be abstract everywhere except in CoreUnfold.lhs
240 | OtherCon [AltCon] -- It ain't one of these
241 -- (OtherCon xs) also indicates that something has been evaluated
242 -- and hence there's no point in re-evaluating it.
243 -- OtherCon [] is used even for non-data-type values
244 -- to indicated evaluated-ness. Notably:
245 -- data C = C !(Int -> Int)
246 -- case x of { C f -> ... }
247 -- Here, f gets an OtherCon [] unfolding.
249 | CompulsoryUnfolding CoreExpr -- There is no "original" definition,
250 -- so you'd better unfold.
252 | CoreUnfolding -- An unfolding with redundant cached information
253 CoreExpr -- Template; binder-info is correct
254 Bool -- True <=> top level binding
255 Bool -- exprIsHNF template (cached); it is ok to discard a `seq` on
257 Bool -- True <=> doesn't waste (much) work to expand inside an inlining
258 -- Basically it's exprIsCheap
259 UnfoldingGuidance -- Tells about the *size* of the template.
262 data UnfoldingGuidance
264 | UnfoldIfGoodArgs Int -- and "n" value args
266 [Int] -- Discount if the argument is evaluated.
267 -- (i.e., a simplification will definitely
268 -- be possible). One elt of the list per *value* arg.
270 Int -- The "size" of the unfolding; to be elaborated
273 Int -- Scrutinee discount: the discount to substract if the thing is in
274 -- a context (case (thing args) of ...),
275 -- (where there are the right number of arguments.)
277 noUnfolding = NoUnfolding
278 evaldUnfolding = OtherCon []
280 mkOtherCon = OtherCon
282 seqUnfolding :: Unfolding -> ()
283 seqUnfolding (CoreUnfolding e top b1 b2 g)
284 = seqExpr e `seq` top `seq` b1 `seq` b2 `seq` seqGuidance g
285 seqUnfolding other = ()
287 seqGuidance (UnfoldIfGoodArgs n ns a b) = n `seq` sum ns `seq` a `seq` b `seq` ()
288 seqGuidance other = ()
292 unfoldingTemplate :: Unfolding -> CoreExpr
293 unfoldingTemplate (CoreUnfolding expr _ _ _ _) = expr
294 unfoldingTemplate (CompulsoryUnfolding expr) = expr
295 unfoldingTemplate other = panic "getUnfoldingTemplate"
297 maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr
298 maybeUnfoldingTemplate (CoreUnfolding expr _ _ _ _) = Just expr
299 maybeUnfoldingTemplate (CompulsoryUnfolding expr) = Just expr
300 maybeUnfoldingTemplate other = Nothing
302 otherCons :: Unfolding -> [AltCon]
303 otherCons (OtherCon cons) = cons
306 isValueUnfolding :: Unfolding -> Bool
307 -- Returns False for OtherCon
308 isValueUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald
309 isValueUnfolding other = False
311 isEvaldUnfolding :: Unfolding -> Bool
312 -- Returns True for OtherCon
313 isEvaldUnfolding (OtherCon _) = True
314 isEvaldUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald
315 isEvaldUnfolding other = False
317 isCheapUnfolding :: Unfolding -> Bool
318 isCheapUnfolding (CoreUnfolding _ _ _ is_cheap _) = is_cheap
319 isCheapUnfolding other = False
321 isCompulsoryUnfolding :: Unfolding -> Bool
322 isCompulsoryUnfolding (CompulsoryUnfolding _) = True
323 isCompulsoryUnfolding other = False
325 hasUnfolding :: Unfolding -> Bool
326 hasUnfolding (CoreUnfolding _ _ _ _ _) = True
327 hasUnfolding (CompulsoryUnfolding _) = True
328 hasUnfolding other = False
330 hasSomeUnfolding :: Unfolding -> Bool
331 hasSomeUnfolding NoUnfolding = False
332 hasSomeUnfolding other = True
334 neverUnfold :: Unfolding -> Bool
335 neverUnfold NoUnfolding = True
336 neverUnfold (OtherCon _) = True
337 neverUnfold (CoreUnfolding _ _ _ _ UnfoldNever) = True
338 neverUnfold other = False
342 %************************************************************************
344 \subsection{The main data type}
346 %************************************************************************
349 -- The Ord is needed for the FiniteMap used in the lookForConstructor
350 -- in SimplEnv. If you declared that lookForConstructor *ignores*
351 -- constructor-applications with LitArg args, then you could get
354 instance Outputable AltCon where
355 ppr (DataAlt dc) = ppr dc
356 ppr (LitAlt lit) = ppr lit
357 ppr DEFAULT = ptext SLIT("__DEFAULT")
359 instance Show AltCon where
360 showsPrec p con = showsPrecSDoc p (ppr con)
362 cmpAlt :: Alt b -> Alt b -> Ordering
363 cmpAlt (con1, _, _) (con2, _, _) = con1 `cmpAltCon` con2
365 ltAlt :: Alt b -> Alt b -> Bool
366 ltAlt a1 a2 = case a1 `cmpAlt` a2 of { LT -> True; other -> False }
368 cmpAltCon :: AltCon -> AltCon -> Ordering
369 -- Compares AltCons within a single list of alternatives
370 cmpAltCon DEFAULT DEFAULT = EQ
371 cmpAltCon DEFAULT con = LT
373 cmpAltCon (DataAlt d1) (DataAlt d2) = dataConTag d1 `compare` dataConTag d2
374 cmpAltCon (DataAlt _) DEFAULT = GT
375 cmpAltCon (LitAlt l1) (LitAlt l2) = l1 `compare` l2
376 cmpAltCon (LitAlt _) DEFAULT = GT
378 cmpAltCon con1 con2 = WARN( True, text "Comparing incomparable AltCons" <+>
379 ppr con1 <+> ppr con2 )
384 %************************************************************************
386 \subsection{Useful synonyms}
388 %************************************************************************
394 type CoreExpr = Expr CoreBndr
395 type CoreArg = Arg CoreBndr
396 type CoreBind = Bind CoreBndr
397 type CoreAlt = Alt CoreBndr
400 Binders are ``tagged'' with a \tr{t}:
403 data TaggedBndr t = TB CoreBndr t -- TB for "tagged binder"
405 type TaggedBind t = Bind (TaggedBndr t)
406 type TaggedExpr t = Expr (TaggedBndr t)
407 type TaggedArg t = Arg (TaggedBndr t)
408 type TaggedAlt t = Alt (TaggedBndr t)
410 instance Outputable b => Outputable (TaggedBndr b) where
411 ppr (TB b l) = char '<' <> ppr b <> comma <> ppr l <> char '>'
413 instance Outputable b => OutputableBndr (TaggedBndr b) where
414 pprBndr _ b = ppr b -- Simple
418 %************************************************************************
420 \subsection{Core-constructing functions with checking}
422 %************************************************************************
425 mkApps :: Expr b -> [Arg b] -> Expr b
426 mkTyApps :: Expr b -> [Type] -> Expr b
427 mkValApps :: Expr b -> [Expr b] -> Expr b
428 mkVarApps :: Expr b -> [Var] -> Expr b
430 mkApps f args = foldl App f args
431 mkTyApps f args = foldl (\ e a -> App e (Type a)) f args
432 mkValApps f args = foldl (\ e a -> App e a) f args
433 mkVarApps f vars = foldl (\ e a -> App e (varToCoreExpr a)) f vars
435 mkLit :: Literal -> Expr b
436 mkIntLit :: Integer -> Expr b
437 mkIntLitInt :: Int -> Expr b
438 mkConApp :: DataCon -> [Arg b] -> Expr b
439 mkLets :: [Bind b] -> Expr b -> Expr b
440 mkLams :: [b] -> Expr b -> Expr b
443 mkConApp con args = mkApps (Var (dataConWorkId con)) args
445 mkLams binders body = foldr Lam body binders
446 mkLets binds body = foldr Let body binds
448 mkIntLit n = Lit (mkMachInt n)
449 mkIntLitInt n = Lit (mkMachInt (toInteger n))
451 varToCoreExpr :: CoreBndr -> Expr b
452 varToCoreExpr v | isId v = Var v
453 | otherwise = Type (mkTyVarTy v)
455 varsToCoreExprs :: [CoreBndr] -> [Expr b]
456 varsToCoreExprs vs = map varToCoreExpr vs
458 mkCast :: Expr b -> Coercion -> Expr b
459 mkCast e co = Cast e co
463 %************************************************************************
465 \subsection{Simple access functions}
467 %************************************************************************
470 bindersOf :: Bind b -> [b]
471 bindersOf (NonRec binder _) = [binder]
472 bindersOf (Rec pairs) = [binder | (binder, _) <- pairs]
474 bindersOfBinds :: [Bind b] -> [b]
475 bindersOfBinds binds = foldr ((++) . bindersOf) [] binds
477 rhssOfBind :: Bind b -> [Expr b]
478 rhssOfBind (NonRec _ rhs) = [rhs]
479 rhssOfBind (Rec pairs) = [rhs | (_,rhs) <- pairs]
481 rhssOfAlts :: [Alt b] -> [Expr b]
482 rhssOfAlts alts = [e | (_,_,e) <- alts]
484 flattenBinds :: [Bind b] -> [(b, Expr b)] -- Get all the lhs/rhs pairs
485 flattenBinds (NonRec b r : binds) = (b,r) : flattenBinds binds
486 flattenBinds (Rec prs1 : binds) = prs1 ++ flattenBinds binds
490 We often want to strip off leading lambdas before getting down to
491 business. @collectBinders@ is your friend.
493 We expect (by convention) type-, and value- lambdas in that
497 collectBinders :: Expr b -> ([b], Expr b)
498 collectTyBinders :: CoreExpr -> ([TyVar], CoreExpr)
499 collectValBinders :: CoreExpr -> ([Id], CoreExpr)
500 collectTyAndValBinders :: CoreExpr -> ([TyVar], [Id], CoreExpr)
505 go bs (Lam b e) = go (b:bs) e
506 go bs e = (reverse bs, e)
508 collectTyAndValBinders expr
511 (tvs, body1) = collectTyBinders expr
512 (ids, body) = collectValBinders body1
514 collectTyBinders expr
517 go tvs (Lam b e) | isTyVar b = go (b:tvs) e
518 go tvs e = (reverse tvs, e)
520 collectValBinders expr
523 go ids (Lam b e) | isId b = go (b:ids) e
524 go ids body = (reverse ids, body)
528 @collectArgs@ takes an application expression, returning the function
529 and the arguments to which it is applied.
532 collectArgs :: Expr b -> (Expr b, [Arg b])
536 go (App f a) as = go f (a:as)
540 coreExprCc gets the cost centre enclosing an expression, if any.
541 It looks inside lambdas because (scc "foo" \x.e) = \x.scc "foo" e
544 coreExprCc :: Expr b -> CostCentre
545 coreExprCc (Note (SCC cc) e) = cc
546 coreExprCc (Note other_note e) = coreExprCc e
547 coreExprCc (Lam _ e) = coreExprCc e
548 coreExprCc other = noCostCentre
553 %************************************************************************
555 \subsection{Predicates}
557 %************************************************************************
559 @isRuntimeVar v@ returns if (Lam v _) really becomes a lambda at runtime,
560 i.e. if type applications are actual lambdas because types are kept around
563 Similarly isRuntimeArg.
566 isRuntimeVar :: Var -> Bool
567 isRuntimeVar | opt_RuntimeTypes = \v -> True
568 | otherwise = \v -> isId v
570 isRuntimeArg :: CoreExpr -> Bool
571 isRuntimeArg | opt_RuntimeTypes = \e -> True
572 | otherwise = \e -> isValArg e
576 isValArg (Type _) = False
577 isValArg other = True
579 isTypeArg (Type _) = True
580 isTypeArg other = False
582 valBndrCount :: [CoreBndr] -> Int
584 valBndrCount (b : bs) | isId b = 1 + valBndrCount bs
585 | otherwise = valBndrCount bs
587 valArgCount :: [Arg b] -> Int
589 valArgCount (Type _ : args) = valArgCount args
590 valArgCount (other : args) = 1 + valArgCount args
594 %************************************************************************
596 \subsection{Seq stuff}
598 %************************************************************************
601 seqExpr :: CoreExpr -> ()
602 seqExpr (Var v) = v `seq` ()
603 seqExpr (Lit lit) = lit `seq` ()
604 seqExpr (App f a) = seqExpr f `seq` seqExpr a
605 seqExpr (Lam b e) = seqBndr b `seq` seqExpr e
606 seqExpr (Let b e) = seqBind b `seq` seqExpr e
608 seqExpr (Case e b t as) = seqExpr e `seq` seqBndr b `seq` seqType t `seq` seqAlts as
609 seqExpr (Cast e co) = seqExpr e `seq` seqType co
610 seqExpr (Note n e) = seqNote n `seq` seqExpr e
611 seqExpr (Type t) = seqType t
614 seqExprs (e:es) = seqExpr e `seq` seqExprs es
616 seqNote (CoreNote s) = s `seq` ()
619 seqBndr b = b `seq` ()
622 seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
624 seqBind (NonRec b e) = seqBndr b `seq` seqExpr e
625 seqBind (Rec prs) = seqPairs prs
628 seqPairs ((b,e):prs) = seqBndr b `seq` seqExpr e `seq` seqPairs prs
631 seqAlts ((c,bs,e):alts) = seqBndrs bs `seq` seqExpr e `seq` seqAlts alts
634 seqRules (Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs } : rules)
635 = seqBndrs bndrs `seq` seqExprs (rhs:args) `seq` seqRules rules
636 seqRules (BuiltinRule {} : rules) = seqRules rules
641 %************************************************************************
643 \subsection{Annotated core; annotation at every node in the tree}
645 %************************************************************************
648 type AnnExpr bndr annot = (annot, AnnExpr' bndr annot)
650 data AnnExpr' bndr annot
653 | AnnLam bndr (AnnExpr bndr annot)
654 | 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]
688 deAnnotate' (AnnCase scrut v t alts)
689 = Case (deAnnotate scrut) v t (map deAnnAlt alts)
691 deAnnAlt :: AnnAlt bndr annot -> Alt bndr
692 deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs)
696 collectAnnBndrs :: AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot)
700 collect bs (_, AnnLam b body) = collect (b:bs) body
701 collect bs body = (reverse bs, body)