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,
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, mkOtherCon,
30 unfoldingTemplate, maybeUnfoldingTemplate, otherCons,
31 isValueUnfolding, isEvaldUnfolding, isCheapUnfolding, isCompulsoryUnfolding,
32 hasUnfolding, hasSomeUnfolding, neverUnfold,
35 seqRules, seqExpr, seqExprs, seqUnfolding,
37 -- Annotated expressions
38 AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt,
39 deAnnotate, deAnnotate', deAnnAlt, collectAnnBndrs,
42 CoreRules(..), -- Representation needed by friends
43 CoreRule(..), -- CoreSubst, CoreTidy, CoreFVs, PprCore only
46 emptyCoreRules, isEmptyCoreRules, rulesRhsFreeVars, rulesRules,
47 isBuiltinRule, ruleName
50 #include "HsVersions.h"
52 import CmdLineOpts ( opt_RuntimeTypes )
53 import CostCentre ( CostCentre, noCostCentre )
54 import Var ( Var, Id, TyVar, isTyVar, isId )
55 import Type ( Type, mkTyVarTy, seqType )
56 import Literal ( Literal, mkMachInt )
57 import DataCon ( DataCon, dataConWorkId )
58 import BasicTypes ( Activation )
64 %************************************************************************
66 \subsection{The main data types}
68 %************************************************************************
70 These data types are the heart of the compiler
73 infixl 8 `App` -- App brackets to the left
75 data Expr b -- "b" for the type of binders,
78 | App (Expr b) (Arg b)
80 | Let (Bind b) (Expr b)
81 | Case (Expr b) b [Alt b] -- Binder gets bound to value of scrutinee
82 -- Invariant: the list of alternatives is ALWAYS EXHAUSTIVE
83 -- Invariant: the DEFAULT case must be *first*, if it occurs at all
85 | Type Type -- This should only show up at the top
88 type Arg b = Expr b -- Can be a Type
90 type Alt b = (AltCon, [b], Expr b) -- (DEFAULT, [], rhs) is the default alternative
92 data AltCon = DataAlt DataCon
97 data Bind b = NonRec b (Expr b)
104 Type -- The to-type: type of whole coerce expression
105 Type -- The from-type: type of enclosed expression
107 | InlineCall -- Instructs simplifier to inline
110 | InlineMe -- Instructs simplifer to treat the enclosed expression
111 -- as very small, and inline it at its call sites
113 | CoreNote String -- A generic core annotation, propagated but not used by GHC
115 -- NOTE: we also treat expressions wrapped in InlineMe as
116 -- 'cheap' and 'dupable' (in the sense of exprIsCheap, exprIsDupable)
117 -- What this means is that we obediently inline even things that don't
118 -- look like valuse. This is sometimes important:
121 -- Here, f looks like a redex, and we aren't going to inline (.) because it's
122 -- inside an INLINE, so it'll stay looking like a redex. Nevertheless, we
123 -- should inline f even inside lambdas. In effect, we should trust the programmer.
128 * The RHS of a letrec, and the RHSs of all top-level lets,
129 must be of LIFTED type.
131 * The RHS of a let, may be of UNLIFTED type, but only if the expression
132 is ok-for-speculation. This means that the let can be floated around
133 without difficulty. e.g.
135 y::Int# = fac 4# not ok [use case instead]
137 * The argument of an App can be of any type.
139 * The simplifier tries to ensure that if the RHS of a let is a constructor
140 application, its arguments are trivial, so that the constructor can be
144 %************************************************************************
146 \subsection{Transformation rules}
148 %************************************************************************
150 The CoreRule type and its friends are dealt with mainly in CoreRules,
151 but CoreFVs, Subst, PprCore, CoreTidy also inspect the representation.
156 VarSet -- Locally-defined free vars of RHSs
158 emptyCoreRules :: CoreRules
159 emptyCoreRules = Rules [] emptyVarSet
161 isEmptyCoreRules :: CoreRules -> Bool
162 isEmptyCoreRules (Rules rs _) = null rs
164 rulesRhsFreeVars :: CoreRules -> VarSet
165 rulesRhsFreeVars (Rules _ fvs) = fvs
167 rulesRules :: CoreRules -> [CoreRule]
168 rulesRules (Rules rules _) = rules
172 type RuleName = FastString
173 type IdCoreRule = (Id,CoreRule) -- Rules don't have their leading Id inside them
177 Activation -- When the rule is active
178 [CoreBndr] -- Forall'd variables
179 [CoreExpr] -- LHS args
182 | BuiltinRule -- Built-in rules are used for constant folding
183 RuleName -- and suchlike. It has no free variables.
184 ([CoreExpr] -> Maybe CoreExpr)
186 isBuiltinRule (BuiltinRule _ _) = True
187 isBuiltinRule _ = False
189 ruleName :: CoreRule -> RuleName
190 ruleName (Rule n _ _ _ _) = n
191 ruleName (BuiltinRule n _) = n
195 %************************************************************************
197 \subsection{@Unfolding@ type}
199 %************************************************************************
201 The @Unfolding@ type is declared here to avoid numerous loops, but it
202 should be abstract everywhere except in CoreUnfold.lhs
208 | OtherCon [AltCon] -- It ain't one of these
209 -- (OtherCon xs) also indicates that something has been evaluated
210 -- and hence there's no point in re-evaluating it.
211 -- OtherCon [] is used even for non-data-type values
212 -- to indicated evaluated-ness. Notably:
213 -- data C = C !(Int -> Int)
214 -- case x of { C f -> ... }
215 -- Here, f gets an OtherCon [] unfolding.
217 | CompulsoryUnfolding CoreExpr -- There is no "original" definition,
218 -- so you'd better unfold.
220 | CoreUnfolding -- An unfolding with redundant cached information
221 CoreExpr -- Template; binder-info is correct
222 Bool -- True <=> top level binding
223 Bool -- exprIsValue template (cached); it is ok to discard a `seq` on
225 Bool -- True <=> doesn't waste (much) work to expand inside an inlining
226 -- Basically it's exprIsCheap
227 UnfoldingGuidance -- Tells about the *size* of the template.
230 data UnfoldingGuidance
232 | UnfoldIfGoodArgs Int -- and "n" value args
234 [Int] -- Discount if the argument is evaluated.
235 -- (i.e., a simplification will definitely
236 -- be possible). One elt of the list per *value* arg.
238 Int -- The "size" of the unfolding; to be elaborated
241 Int -- Scrutinee discount: the discount to substract if the thing is in
242 -- a context (case (thing args) of ...),
243 -- (where there are the right number of arguments.)
245 noUnfolding = NoUnfolding
246 mkOtherCon = OtherCon
248 seqUnfolding :: Unfolding -> ()
249 seqUnfolding (CoreUnfolding e top b1 b2 g)
250 = seqExpr e `seq` top `seq` b1 `seq` b2 `seq` seqGuidance g
251 seqUnfolding other = ()
253 seqGuidance (UnfoldIfGoodArgs n ns a b) = n `seq` sum ns `seq` a `seq` b `seq` ()
254 seqGuidance other = ()
258 unfoldingTemplate :: Unfolding -> CoreExpr
259 unfoldingTemplate (CoreUnfolding expr _ _ _ _) = expr
260 unfoldingTemplate (CompulsoryUnfolding expr) = expr
261 unfoldingTemplate other = panic "getUnfoldingTemplate"
263 maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr
264 maybeUnfoldingTemplate (CoreUnfolding expr _ _ _ _) = Just expr
265 maybeUnfoldingTemplate (CompulsoryUnfolding expr) = Just expr
266 maybeUnfoldingTemplate other = Nothing
268 otherCons :: Unfolding -> [AltCon]
269 otherCons (OtherCon cons) = cons
272 isValueUnfolding :: Unfolding -> Bool
273 -- Returns False for OtherCon
274 isValueUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald
275 isValueUnfolding other = False
277 isEvaldUnfolding :: Unfolding -> Bool
278 -- Returns True for OtherCon
279 isEvaldUnfolding (OtherCon _) = True
280 isEvaldUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald
281 isEvaldUnfolding other = False
283 isCheapUnfolding :: Unfolding -> Bool
284 isCheapUnfolding (CoreUnfolding _ _ _ is_cheap _) = is_cheap
285 isCheapUnfolding other = False
287 isCompulsoryUnfolding :: Unfolding -> Bool
288 isCompulsoryUnfolding (CompulsoryUnfolding _) = True
289 isCompulsoryUnfolding other = False
291 hasUnfolding :: Unfolding -> Bool
292 hasUnfolding (CoreUnfolding _ _ _ _ _) = True
293 hasUnfolding (CompulsoryUnfolding _) = True
294 hasUnfolding other = False
296 hasSomeUnfolding :: Unfolding -> Bool
297 hasSomeUnfolding NoUnfolding = False
298 hasSomeUnfolding other = True
300 neverUnfold :: Unfolding -> Bool
301 neverUnfold NoUnfolding = True
302 neverUnfold (OtherCon _) = True
303 neverUnfold (CoreUnfolding _ _ _ _ UnfoldNever) = True
304 neverUnfold other = False
308 %************************************************************************
310 \subsection{The main data type}
312 %************************************************************************
315 -- The Ord is needed for the FiniteMap used in the lookForConstructor
316 -- in SimplEnv. If you declared that lookForConstructor *ignores*
317 -- constructor-applications with LitArg args, then you could get
320 instance Outputable AltCon where
321 ppr (DataAlt dc) = ppr dc
322 ppr (LitAlt lit) = ppr lit
323 ppr DEFAULT = ptext SLIT("__DEFAULT")
325 instance Show AltCon where
326 showsPrec p con = showsPrecSDoc p (ppr con)
330 %************************************************************************
332 \subsection{Useful synonyms}
334 %************************************************************************
340 type CoreExpr = Expr CoreBndr
341 type CoreArg = Arg CoreBndr
342 type CoreBind = Bind CoreBndr
343 type CoreAlt = Alt CoreBndr
346 Binders are ``tagged'' with a \tr{t}:
349 data TaggedBndr t = TB CoreBndr t -- TB for "tagged binder"
351 type TaggedBind t = Bind (TaggedBndr t)
352 type TaggedExpr t = Expr (TaggedBndr t)
353 type TaggedArg t = Arg (TaggedBndr t)
354 type TaggedAlt t = Alt (TaggedBndr t)
356 instance Outputable b => Outputable (TaggedBndr b) where
357 ppr (TB b l) = char '<' <> ppr b <> comma <> ppr l <> char '>'
359 instance Outputable b => OutputableBndr (TaggedBndr b) where
360 pprBndr _ b = ppr b -- Simple
364 %************************************************************************
366 \subsection{Core-constructing functions with checking}
368 %************************************************************************
371 mkApps :: Expr b -> [Arg b] -> Expr b
372 mkTyApps :: Expr b -> [Type] -> Expr b
373 mkValApps :: Expr b -> [Expr b] -> Expr b
374 mkVarApps :: Expr b -> [Var] -> Expr b
376 mkApps f args = foldl App f args
377 mkTyApps f args = foldl (\ e a -> App e (Type a)) f args
378 mkValApps f args = foldl (\ e a -> App e a) f args
379 mkVarApps f vars = foldl (\ e a -> App e (varToCoreExpr a)) f vars
381 mkLit :: Literal -> Expr b
382 mkIntLit :: Integer -> Expr b
383 mkIntLitInt :: Int -> Expr b
384 mkConApp :: DataCon -> [Arg b] -> Expr b
385 mkLets :: [Bind b] -> Expr b -> Expr b
386 mkLams :: [b] -> Expr b -> Expr b
389 mkConApp con args = mkApps (Var (dataConWorkId con)) args
391 mkLams binders body = foldr Lam body binders
392 mkLets binds body = foldr Let body binds
394 mkIntLit n = Lit (mkMachInt n)
395 mkIntLitInt n = Lit (mkMachInt (toInteger n))
397 varToCoreExpr :: CoreBndr -> Expr b
398 varToCoreExpr v | isId v = Var v
399 | otherwise = Type (mkTyVarTy v)
403 %************************************************************************
405 \subsection{Simple access functions}
407 %************************************************************************
410 bindersOf :: Bind b -> [b]
411 bindersOf (NonRec binder _) = [binder]
412 bindersOf (Rec pairs) = [binder | (binder, _) <- pairs]
414 bindersOfBinds :: [Bind b] -> [b]
415 bindersOfBinds binds = foldr ((++) . bindersOf) [] binds
417 rhssOfBind :: Bind b -> [Expr b]
418 rhssOfBind (NonRec _ rhs) = [rhs]
419 rhssOfBind (Rec pairs) = [rhs | (_,rhs) <- pairs]
421 rhssOfAlts :: [Alt b] -> [Expr b]
422 rhssOfAlts alts = [e | (_,_,e) <- alts]
424 flattenBinds :: [Bind b] -> [(b, Expr b)] -- Get all the lhs/rhs pairs
425 flattenBinds (NonRec b r : binds) = (b,r) : flattenBinds binds
426 flattenBinds (Rec prs1 : binds) = prs1 ++ flattenBinds binds
430 We often want to strip off leading lambdas before getting down to
431 business. @collectBinders@ is your friend.
433 We expect (by convention) type-, and value- lambdas in that
437 collectBinders :: Expr b -> ([b], Expr b)
438 collectTyBinders :: CoreExpr -> ([TyVar], CoreExpr)
439 collectValBinders :: CoreExpr -> ([Id], CoreExpr)
440 collectTyAndValBinders :: CoreExpr -> ([TyVar], [Id], CoreExpr)
445 go bs (Lam b e) = go (b:bs) e
446 go bs e = (reverse bs, e)
448 collectTyAndValBinders expr
451 (tvs, body1) = collectTyBinders expr
452 (ids, body) = collectValBinders body1
454 collectTyBinders expr
457 go tvs (Lam b e) | isTyVar b = go (b:tvs) e
458 go tvs e = (reverse tvs, e)
460 collectValBinders expr
463 go ids (Lam b e) | isId b = go (b:ids) e
464 go ids body = (reverse ids, body)
468 @collectArgs@ takes an application expression, returning the function
469 and the arguments to which it is applied.
472 collectArgs :: Expr b -> (Expr b, [Arg b])
476 go (App f a) as = go f (a:as)
480 coreExprCc gets the cost centre enclosing an expression, if any.
481 It looks inside lambdas because (scc "foo" \x.e) = \x.scc "foo" e
484 coreExprCc :: Expr b -> CostCentre
485 coreExprCc (Note (SCC cc) e) = cc
486 coreExprCc (Note other_note e) = coreExprCc e
487 coreExprCc (Lam _ e) = coreExprCc e
488 coreExprCc other = noCostCentre
493 %************************************************************************
495 \subsection{Predicates}
497 %************************************************************************
499 @isRuntimeVar v@ returns if (Lam v _) really becomes a lambda at runtime,
500 i.e. if type applications are actual lambdas because types are kept around
503 Similarly isRuntimeArg.
506 isRuntimeVar :: Var -> Bool
507 isRuntimeVar | opt_RuntimeTypes = \v -> True
508 | otherwise = \v -> isId v
510 isRuntimeArg :: CoreExpr -> Bool
511 isRuntimeArg | opt_RuntimeTypes = \e -> True
512 | otherwise = \e -> isValArg e
516 isValArg (Type _) = False
517 isValArg other = True
519 isTypeArg (Type _) = True
520 isTypeArg other = False
522 valBndrCount :: [CoreBndr] -> Int
524 valBndrCount (b : bs) | isId b = 1 + valBndrCount bs
525 | otherwise = valBndrCount bs
527 valArgCount :: [Arg b] -> Int
529 valArgCount (Type _ : args) = valArgCount args
530 valArgCount (other : args) = 1 + valArgCount args
534 %************************************************************************
536 \subsection{Seq stuff}
538 %************************************************************************
541 seqExpr :: CoreExpr -> ()
542 seqExpr (Var v) = v `seq` ()
543 seqExpr (Lit lit) = lit `seq` ()
544 seqExpr (App f a) = seqExpr f `seq` seqExpr a
545 seqExpr (Lam b e) = seqBndr b `seq` seqExpr e
546 seqExpr (Let b e) = seqBind b `seq` seqExpr e
547 seqExpr (Case e b as) = seqExpr e `seq` seqBndr b `seq` seqAlts as
548 seqExpr (Note n e) = seqNote n `seq` seqExpr e
549 seqExpr (Type t) = seqType t
552 seqExprs (e:es) = seqExpr e `seq` seqExprs es
554 seqNote (Coerce t1 t2) = seqType t1 `seq` seqType t2
555 seqNote (CoreNote s) = s `seq` ()
558 seqBndr b = b `seq` ()
561 seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
563 seqBind (NonRec b e) = seqBndr b `seq` seqExpr e
564 seqBind (Rec prs) = seqPairs prs
567 seqPairs ((b,e):prs) = seqBndr b `seq` seqExpr e `seq` seqPairs prs
570 seqAlts ((c,bs,e):alts) = seqBndrs bs `seq` seqExpr e `seq` seqAlts alts
572 seqRules :: CoreRules -> ()
573 seqRules (Rules rules fvs) = seq_rules rules `seq` seqVarSet fvs
576 seq_rules (Rule fs _ bs es e : rules) = seqBndrs bs `seq` seqExprs (e:es) `seq` seq_rules rules
577 seq_rules (BuiltinRule _ _ : rules) = seq_rules rules
582 %************************************************************************
584 \subsection{Annotated core; annotation at every node in the tree}
586 %************************************************************************
589 type AnnExpr bndr annot = (annot, AnnExpr' bndr annot)
591 data AnnExpr' bndr annot
594 | AnnLam bndr (AnnExpr bndr annot)
595 | AnnApp (AnnExpr bndr annot) (AnnExpr bndr annot)
596 | AnnCase (AnnExpr bndr annot) bndr [AnnAlt bndr annot]
597 | AnnLet (AnnBind bndr annot) (AnnExpr bndr annot)
598 | AnnNote Note (AnnExpr bndr annot)
601 type AnnAlt bndr annot = (AltCon, [bndr], AnnExpr bndr annot)
603 data AnnBind bndr annot
604 = AnnNonRec bndr (AnnExpr bndr annot)
605 | AnnRec [(bndr, AnnExpr bndr annot)]
609 deAnnotate :: AnnExpr bndr annot -> Expr bndr
610 deAnnotate (_, e) = deAnnotate' e
612 deAnnotate' (AnnType t) = Type t
613 deAnnotate' (AnnVar v) = Var v
614 deAnnotate' (AnnLit lit) = Lit lit
615 deAnnotate' (AnnLam binder body) = Lam binder (deAnnotate body)
616 deAnnotate' (AnnApp fun arg) = App (deAnnotate fun) (deAnnotate arg)
617 deAnnotate' (AnnNote note body) = Note note (deAnnotate body)
619 deAnnotate' (AnnLet bind body)
620 = Let (deAnnBind bind) (deAnnotate body)
622 deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs)
623 deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs]
625 deAnnotate' (AnnCase scrut v alts)
626 = Case (deAnnotate scrut) v (map deAnnAlt alts)
628 deAnnAlt :: AnnAlt bndr annot -> Alt bndr
629 deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs)
633 collectAnnBndrs :: AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot)
637 collect bs (_, AnnLam b body) = collect (b:bs) body
638 collect bs body = (reverse bs, body)