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,
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 )
54 import OccName ( OccName )
55 import Literal ( Literal, mkMachInt )
56 import DataCon ( DataCon, dataConWorkId, dataConTag )
57 import BasicTypes ( Activation )
62 %************************************************************************
64 \subsection{The main data types}
66 %************************************************************************
68 These data types are the heart of the compiler
71 infixl 8 `App` -- App brackets to the left
73 data Expr b -- "b" for the type of binders,
76 | App (Expr b) (Arg b)
78 | Let (Bind b) (Expr b)
79 | Case (Expr b) b Type [Alt b] -- Binder gets bound to value of scrutinee
80 -- Invariant: The list of alternatives is ALWAYS EXHAUSTIVE,
81 -- meaning that it covers all cases that can occur
82 -- See the example below
84 -- Invariant: The DEFAULT case must be *first*, if it occurs at all
85 -- Invariant: The remaining cases are in order of increasing
88 -- This makes finding the relevant constructor easy,
89 -- and makes comparison easier too
91 | Type Type -- This should only show up at the top
94 -- An "exhausive" case does not necessarily mention all constructors:
95 -- data Foo = Red | Green | Blue
99 -- other -> f (case x of
102 -- The inner case does not need a Red alternative, because x can't be Red at
103 -- that program point.
106 type Arg b = Expr b -- Can be a Type
108 type Alt b = (AltCon, [b], Expr b) -- (DEFAULT, [], rhs) is the default alternative
110 data AltCon = DataAlt DataCon
116 data Bind b = NonRec b (Expr b)
117 | Rec [(b, (Expr b))]
123 Type -- The to-type: type of whole coerce expression
124 Type -- The from-type: type of enclosed expression
126 | InlineMe -- Instructs simplifer to treat the enclosed expression
127 -- as very small, and inline it at its call sites
129 | CoreNote String -- A generic core annotation, propagated but not used by GHC
131 -- NOTE: we also treat expressions wrapped in InlineMe as
132 -- 'cheap' and 'dupable' (in the sense of exprIsCheap, exprIsDupable)
133 -- What this means is that we obediently inline even things that don't
134 -- look like valuse. This is sometimes important:
137 -- Here, f looks like a redex, and we aren't going to inline (.) because it's
138 -- inside an INLINE, so it'll stay looking like a redex. Nevertheless, we
139 -- should inline f even inside lambdas. In effect, we should trust the programmer.
144 * The RHS of a letrec, and the RHSs of all top-level lets,
145 must be of LIFTED type.
147 * The RHS of a let, may be of UNLIFTED type, but only if the expression
148 is ok-for-speculation. This means that the let can be floated around
149 without difficulty. e.g.
151 y::Int# = fac 4# not ok [use case instead]
153 * The argument of an App can be of any type.
155 * The simplifier tries to ensure that if the RHS of a let is a constructor
156 application, its arguments are trivial, so that the constructor can be
160 %************************************************************************
162 \subsection{Transformation rules}
164 %************************************************************************
166 The CoreRule type and its friends are dealt with mainly in CoreRules,
167 but CoreFVs, Subst, PprCore, CoreTidy also inspect the representation.
171 "local" if the function it is a rule for is defined in the
172 same module as the rule itself.
174 "orphan" if nothing on the LHS is defined in the same module
178 type RuleName = FastString
183 ru_act :: Activation, -- When the rule is active
185 -- Rough-matching stuff
186 -- see comments with InstEnv.Instance( is_cls, is_rough )
187 ru_fn :: Name, -- Name of the Id at the head of this rule
188 ru_rough :: [Maybe Name], -- Name at the head of each argument
190 -- Proper-matching stuff
191 -- see comments with InstEnv.Instance( is_tvs, is_tys )
192 ru_bndrs :: [CoreBndr], -- Forall'd variables
193 ru_args :: [CoreExpr], -- LHS args
195 -- And the right-hand side
199 ru_local :: Bool, -- The fn at the head of the rule is
200 -- defined in the same module as the rule
202 -- Orphan-hood; see comments is InstEnv.Instance( is_orph )
203 ru_orph :: Maybe OccName }
205 | BuiltinRule { -- Built-in rules are used for constant folding
206 ru_name :: RuleName, -- and suchlike. It has no free variables.
207 ru_fn :: Name, -- Name of the Id at
208 -- the head of this rule
209 ru_try :: [CoreExpr] -> Maybe CoreExpr }
211 isBuiltinRule (BuiltinRule {}) = True
212 isBuiltinRule _ = False
214 ruleName :: CoreRule -> RuleName
217 ruleIdName :: CoreRule -> Name
220 isLocalRule :: CoreRule -> Bool
221 isLocalRule = ru_local
225 %************************************************************************
229 %************************************************************************
231 The @Unfolding@ type is declared here to avoid numerous loops, but it
232 should be abstract everywhere except in CoreUnfold.lhs
238 | OtherCon [AltCon] -- It ain't one of these
239 -- (OtherCon xs) also indicates that something has been evaluated
240 -- and hence there's no point in re-evaluating it.
241 -- OtherCon [] is used even for non-data-type values
242 -- to indicated evaluated-ness. Notably:
243 -- data C = C !(Int -> Int)
244 -- case x of { C f -> ... }
245 -- Here, f gets an OtherCon [] unfolding.
247 | CompulsoryUnfolding CoreExpr -- There is no "original" definition,
248 -- so you'd better unfold.
250 | CoreUnfolding -- An unfolding with redundant cached information
251 CoreExpr -- Template; binder-info is correct
252 Bool -- True <=> top level binding
253 Bool -- exprIsHNF template (cached); it is ok to discard a `seq` on
255 Bool -- True <=> doesn't waste (much) work to expand inside an inlining
256 -- Basically it's exprIsCheap
257 UnfoldingGuidance -- Tells about the *size* of the template.
260 data UnfoldingGuidance
262 | UnfoldIfGoodArgs Int -- and "n" value args
264 [Int] -- Discount if the argument is evaluated.
265 -- (i.e., a simplification will definitely
266 -- be possible). One elt of the list per *value* arg.
268 Int -- The "size" of the unfolding; to be elaborated
271 Int -- Scrutinee discount: the discount to substract if the thing is in
272 -- a context (case (thing args) of ...),
273 -- (where there are the right number of arguments.)
275 noUnfolding = NoUnfolding
276 evaldUnfolding = OtherCon []
278 mkOtherCon = OtherCon
280 seqUnfolding :: Unfolding -> ()
281 seqUnfolding (CoreUnfolding e top b1 b2 g)
282 = seqExpr e `seq` top `seq` b1 `seq` b2 `seq` seqGuidance g
283 seqUnfolding other = ()
285 seqGuidance (UnfoldIfGoodArgs n ns a b) = n `seq` sum ns `seq` a `seq` b `seq` ()
286 seqGuidance other = ()
290 unfoldingTemplate :: Unfolding -> CoreExpr
291 unfoldingTemplate (CoreUnfolding expr _ _ _ _) = expr
292 unfoldingTemplate (CompulsoryUnfolding expr) = expr
293 unfoldingTemplate other = panic "getUnfoldingTemplate"
295 maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr
296 maybeUnfoldingTemplate (CoreUnfolding expr _ _ _ _) = Just expr
297 maybeUnfoldingTemplate (CompulsoryUnfolding expr) = Just expr
298 maybeUnfoldingTemplate other = Nothing
300 otherCons :: Unfolding -> [AltCon]
301 otherCons (OtherCon cons) = cons
304 isValueUnfolding :: Unfolding -> Bool
305 -- Returns False for OtherCon
306 isValueUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald
307 isValueUnfolding other = False
309 isEvaldUnfolding :: Unfolding -> Bool
310 -- Returns True for OtherCon
311 isEvaldUnfolding (OtherCon _) = True
312 isEvaldUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald
313 isEvaldUnfolding other = False
315 isCheapUnfolding :: Unfolding -> Bool
316 isCheapUnfolding (CoreUnfolding _ _ _ is_cheap _) = is_cheap
317 isCheapUnfolding other = False
319 isCompulsoryUnfolding :: Unfolding -> Bool
320 isCompulsoryUnfolding (CompulsoryUnfolding _) = True
321 isCompulsoryUnfolding other = False
323 hasUnfolding :: Unfolding -> Bool
324 hasUnfolding (CoreUnfolding _ _ _ _ _) = True
325 hasUnfolding (CompulsoryUnfolding _) = True
326 hasUnfolding other = False
328 hasSomeUnfolding :: Unfolding -> Bool
329 hasSomeUnfolding NoUnfolding = False
330 hasSomeUnfolding other = True
332 neverUnfold :: Unfolding -> Bool
333 neverUnfold NoUnfolding = True
334 neverUnfold (OtherCon _) = True
335 neverUnfold (CoreUnfolding _ _ _ _ UnfoldNever) = True
336 neverUnfold other = False
340 %************************************************************************
342 \subsection{The main data type}
344 %************************************************************************
347 -- The Ord is needed for the FiniteMap used in the lookForConstructor
348 -- in SimplEnv. If you declared that lookForConstructor *ignores*
349 -- constructor-applications with LitArg args, then you could get
352 instance Outputable AltCon where
353 ppr (DataAlt dc) = ppr dc
354 ppr (LitAlt lit) = ppr lit
355 ppr DEFAULT = ptext SLIT("__DEFAULT")
357 instance Show AltCon where
358 showsPrec p con = showsPrecSDoc p (ppr con)
360 cmpAlt :: Alt b -> Alt b -> Ordering
361 cmpAlt (con1, _, _) (con2, _, _) = con1 `cmpAltCon` con2
363 ltAlt :: Alt b -> Alt b -> Bool
364 ltAlt a1 a2 = case a1 `cmpAlt` a2 of { LT -> True; other -> False }
366 cmpAltCon :: AltCon -> AltCon -> Ordering
367 -- Compares AltCons within a single list of alternatives
368 cmpAltCon DEFAULT DEFAULT = EQ
369 cmpAltCon DEFAULT con = LT
371 cmpAltCon (DataAlt d1) (DataAlt d2) = dataConTag d1 `compare` dataConTag d2
372 cmpAltCon (DataAlt _) DEFAULT = GT
373 cmpAltCon (LitAlt l1) (LitAlt l2) = l1 `compare` l2
374 cmpAltCon (LitAlt _) DEFAULT = GT
376 cmpAltCon con1 con2 = WARN( True, text "Comparing incomparable AltCons" <+>
377 ppr con1 <+> ppr con2 )
382 %************************************************************************
384 \subsection{Useful synonyms}
386 %************************************************************************
392 type CoreExpr = Expr CoreBndr
393 type CoreArg = Arg CoreBndr
394 type CoreBind = Bind CoreBndr
395 type CoreAlt = Alt CoreBndr
398 Binders are ``tagged'' with a \tr{t}:
401 data TaggedBndr t = TB CoreBndr t -- TB for "tagged binder"
403 type TaggedBind t = Bind (TaggedBndr t)
404 type TaggedExpr t = Expr (TaggedBndr t)
405 type TaggedArg t = Arg (TaggedBndr t)
406 type TaggedAlt t = Alt (TaggedBndr t)
408 instance Outputable b => Outputable (TaggedBndr b) where
409 ppr (TB b l) = char '<' <> ppr b <> comma <> ppr l <> char '>'
411 instance Outputable b => OutputableBndr (TaggedBndr b) where
412 pprBndr _ b = ppr b -- Simple
416 %************************************************************************
418 \subsection{Core-constructing functions with checking}
420 %************************************************************************
423 mkApps :: Expr b -> [Arg b] -> Expr b
424 mkTyApps :: Expr b -> [Type] -> Expr b
425 mkValApps :: Expr b -> [Expr b] -> Expr b
426 mkVarApps :: Expr b -> [Var] -> Expr b
428 mkApps f args = foldl App f args
429 mkTyApps f args = foldl (\ e a -> App e (Type a)) f args
430 mkValApps f args = foldl (\ e a -> App e a) f args
431 mkVarApps f vars = foldl (\ e a -> App e (varToCoreExpr a)) f vars
433 mkLit :: Literal -> Expr b
434 mkIntLit :: Integer -> Expr b
435 mkIntLitInt :: Int -> Expr b
436 mkConApp :: DataCon -> [Arg b] -> Expr b
437 mkLets :: [Bind b] -> Expr b -> Expr b
438 mkLams :: [b] -> Expr b -> Expr b
441 mkConApp con args = mkApps (Var (dataConWorkId con)) args
443 mkLams binders body = foldr Lam body binders
444 mkLets binds body = foldr Let body binds
446 mkIntLit n = Lit (mkMachInt n)
447 mkIntLitInt n = Lit (mkMachInt (toInteger n))
449 varToCoreExpr :: CoreBndr -> Expr b
450 varToCoreExpr v | isId v = Var v
451 | otherwise = Type (mkTyVarTy v)
455 %************************************************************************
457 \subsection{Simple access functions}
459 %************************************************************************
462 bindersOf :: Bind b -> [b]
463 bindersOf (NonRec binder _) = [binder]
464 bindersOf (Rec pairs) = [binder | (binder, _) <- pairs]
466 bindersOfBinds :: [Bind b] -> [b]
467 bindersOfBinds binds = foldr ((++) . bindersOf) [] binds
469 rhssOfBind :: Bind b -> [Expr b]
470 rhssOfBind (NonRec _ rhs) = [rhs]
471 rhssOfBind (Rec pairs) = [rhs | (_,rhs) <- pairs]
473 rhssOfAlts :: [Alt b] -> [Expr b]
474 rhssOfAlts alts = [e | (_,_,e) <- alts]
476 flattenBinds :: [Bind b] -> [(b, Expr b)] -- Get all the lhs/rhs pairs
477 flattenBinds (NonRec b r : binds) = (b,r) : flattenBinds binds
478 flattenBinds (Rec prs1 : binds) = prs1 ++ flattenBinds binds
482 We often want to strip off leading lambdas before getting down to
483 business. @collectBinders@ is your friend.
485 We expect (by convention) type-, and value- lambdas in that
489 collectBinders :: Expr b -> ([b], Expr b)
490 collectTyBinders :: CoreExpr -> ([TyVar], CoreExpr)
491 collectValBinders :: CoreExpr -> ([Id], CoreExpr)
492 collectTyAndValBinders :: CoreExpr -> ([TyVar], [Id], CoreExpr)
497 go bs (Lam b e) = go (b:bs) e
498 go bs e = (reverse bs, e)
500 collectTyAndValBinders expr
503 (tvs, body1) = collectTyBinders expr
504 (ids, body) = collectValBinders body1
506 collectTyBinders expr
509 go tvs (Lam b e) | isTyVar b = go (b:tvs) e
510 go tvs e = (reverse tvs, e)
512 collectValBinders expr
515 go ids (Lam b e) | isId b = go (b:ids) e
516 go ids body = (reverse ids, body)
520 @collectArgs@ takes an application expression, returning the function
521 and the arguments to which it is applied.
524 collectArgs :: Expr b -> (Expr b, [Arg b])
528 go (App f a) as = go f (a:as)
532 coreExprCc gets the cost centre enclosing an expression, if any.
533 It looks inside lambdas because (scc "foo" \x.e) = \x.scc "foo" e
536 coreExprCc :: Expr b -> CostCentre
537 coreExprCc (Note (SCC cc) e) = cc
538 coreExprCc (Note other_note e) = coreExprCc e
539 coreExprCc (Lam _ e) = coreExprCc e
540 coreExprCc other = noCostCentre
545 %************************************************************************
547 \subsection{Predicates}
549 %************************************************************************
551 @isRuntimeVar v@ returns if (Lam v _) really becomes a lambda at runtime,
552 i.e. if type applications are actual lambdas because types are kept around
555 Similarly isRuntimeArg.
558 isRuntimeVar :: Var -> Bool
559 isRuntimeVar | opt_RuntimeTypes = \v -> True
560 | otherwise = \v -> isId v
562 isRuntimeArg :: CoreExpr -> Bool
563 isRuntimeArg | opt_RuntimeTypes = \e -> True
564 | otherwise = \e -> isValArg e
568 isValArg (Type _) = False
569 isValArg other = True
571 isTypeArg (Type _) = True
572 isTypeArg other = False
574 valBndrCount :: [CoreBndr] -> Int
576 valBndrCount (b : bs) | isId b = 1 + valBndrCount bs
577 | otherwise = valBndrCount bs
579 valArgCount :: [Arg b] -> Int
581 valArgCount (Type _ : args) = valArgCount args
582 valArgCount (other : args) = 1 + valArgCount args
586 %************************************************************************
588 \subsection{Seq stuff}
590 %************************************************************************
593 seqExpr :: CoreExpr -> ()
594 seqExpr (Var v) = v `seq` ()
595 seqExpr (Lit lit) = lit `seq` ()
596 seqExpr (App f a) = seqExpr f `seq` seqExpr a
597 seqExpr (Lam b e) = seqBndr b `seq` seqExpr e
598 seqExpr (Let b e) = seqBind b `seq` seqExpr e
600 seqExpr (Case e b t as) = seqExpr e `seq` seqBndr b `seq` seqType t `seq` seqAlts as
601 seqExpr (Note n e) = seqNote n `seq` seqExpr e
602 seqExpr (Type t) = seqType t
605 seqExprs (e:es) = seqExpr e `seq` seqExprs es
607 seqNote (Coerce t1 t2) = seqType t1 `seq` seqType t2
608 seqNote (CoreNote s) = s `seq` ()
611 seqBndr b = b `seq` ()
614 seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
616 seqBind (NonRec b e) = seqBndr b `seq` seqExpr e
617 seqBind (Rec prs) = seqPairs prs
620 seqPairs ((b,e):prs) = seqBndr b `seq` seqExpr e `seq` seqPairs prs
623 seqAlts ((c,bs,e):alts) = seqBndrs bs `seq` seqExpr e `seq` seqAlts alts
626 seqRules (Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs } : rules)
627 = seqBndrs bndrs `seq` seqExprs (rhs:args) `seq` seqRules rules
628 seqRules (BuiltinRule {} : rules) = seqRules rules
633 %************************************************************************
635 \subsection{Annotated core; annotation at every node in the tree}
637 %************************************************************************
640 type AnnExpr bndr annot = (annot, AnnExpr' bndr annot)
642 data AnnExpr' bndr annot
645 | AnnLam bndr (AnnExpr bndr annot)
646 | AnnApp (AnnExpr bndr annot) (AnnExpr bndr annot)
648 | AnnCase (AnnExpr bndr annot) bndr Type [AnnAlt bndr annot]
649 | AnnLet (AnnBind bndr annot) (AnnExpr bndr annot)
650 | AnnNote Note (AnnExpr bndr annot)
653 type AnnAlt bndr annot = (AltCon, [bndr], AnnExpr bndr annot)
655 data AnnBind bndr annot
656 = AnnNonRec bndr (AnnExpr bndr annot)
657 | AnnRec [(bndr, AnnExpr bndr annot)]
661 deAnnotate :: AnnExpr bndr annot -> Expr bndr
662 deAnnotate (_, e) = deAnnotate' e
664 deAnnotate' (AnnType t) = Type t
665 deAnnotate' (AnnVar v) = Var v
666 deAnnotate' (AnnLit lit) = Lit lit
667 deAnnotate' (AnnLam binder body) = Lam binder (deAnnotate body)
668 deAnnotate' (AnnApp fun arg) = App (deAnnotate fun) (deAnnotate arg)
669 deAnnotate' (AnnNote note body) = Note note (deAnnotate body)
671 deAnnotate' (AnnLet bind body)
672 = Let (deAnnBind bind) (deAnnotate body)
674 deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs)
675 deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs]
678 deAnnotate' (AnnCase scrut v t alts)
679 = Case (deAnnotate scrut) v t (map deAnnAlt alts)
681 deAnnAlt :: AnnAlt bndr annot -> Alt bndr
682 deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs)
686 collectAnnBndrs :: AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot)
690 collect bs (_, AnnLam b body) = collect (b:bs) body
691 collect bs body = (reverse bs, body)