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,
13 mkApps, mkTyApps, mkValApps, mkVarApps,
14 mkLit, mkIntLitInt, mkIntLit,
18 isTyVar, isId, isLocalVar, mustHaveLocalBinding,
19 bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts,
20 collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders,
21 collectArgs, collectBindersIgnoringNotes,
25 isValArg, isTypeArg, valArgCount, valBndrCount,
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, deAnnotate, deAnnotate',
41 CoreRules(..), -- Representation needed by friends
42 CoreRule(..), -- CoreSubst, CoreTidy, CoreFVs, PprCore only
45 emptyCoreRules, isEmptyCoreRules, rulesRhsFreeVars, rulesRules,
49 #include "HsVersions.h"
51 import CostCentre ( CostCentre, noCostCentre )
52 import Var ( Var, Id, TyVar, isTyVar, isId )
53 import Type ( Type, mkTyVarTy, seqType )
54 import Literal ( Literal, mkMachInt )
55 import DataCon ( DataCon, dataConId )
60 %************************************************************************
62 \subsection{The main data types}
64 %************************************************************************
66 These data types are the heart of the compiler
69 infixl 8 `App` -- App brackets to the left
71 data Expr b -- "b" for the type of binders,
74 | App (Expr b) (Arg b)
76 | Let (Bind b) (Expr b)
77 | Case (Expr b) b [Alt b] -- Binder gets bound to value of scrutinee
78 -- DEFAULT case must be last, if it occurs at all
80 | Type Type -- This should only show up at the top
83 type Arg b = Expr b -- Can be a Type
85 type Alt b = (AltCon, [b], Expr b) -- (DEFAULT, [], rhs) is the default alternative
87 data AltCon = DataAlt DataCon
92 data Bind b = NonRec b (Expr b)
99 Type -- The to-type: type of whole coerce expression
100 Type -- The from-type: type of enclosed expression
102 | InlineCall -- Instructs simplifier to inline
105 | InlineMe -- Instructs simplifer to treat the enclosed expression
106 -- as very small, and inline it at its call sites
110 %************************************************************************
112 \subsection{isLocalVar}
114 %************************************************************************
116 @isLocalVar@ returns True of all TyVars, and of Ids that are defined in
117 this module and are not constants like data constructors and record selectors.
118 These are the variables that we need to pay attention to when finding free
119 variables, or doing dependency analysis.
122 isLocalVar :: Var -> Bool
123 isLocalVar v = isTyVar v || isLocalId v
127 mustHaveLocalBinding :: Var -> Bool
128 -- True <=> the variable must have a binding in this module
129 mustHaveLocalBinding v = isTyVar v || (isLocalId v && not (hasNoBinding v))
133 %************************************************************************
135 \subsection{Transformation rules}
137 %************************************************************************
139 The CoreRule type and its friends are dealt with mainly in CoreRules,
140 but CoreFVs, Subst, PprCore, CoreTidy also inspect the representation.
145 VarSet -- Locally-defined free vars of RHSs
147 emptyCoreRules :: CoreRules
148 emptyCoreRules = Rules [] emptyVarSet
150 isEmptyCoreRules :: CoreRules -> Bool
151 isEmptyCoreRules (Rules rs _) = null rs
153 rulesRhsFreeVars :: CoreRules -> VarSet
154 rulesRhsFreeVars (Rules _ fvs) = fvs
156 rulesRules :: CoreRules -> [CoreRule]
157 rulesRules (Rules rules _) = rules
161 type RuleName = FAST_STRING
162 type IdCoreRule = (Id,CoreRule) -- Rules don't have their leading Id inside them
166 [CoreBndr] -- Forall'd variables
167 [CoreExpr] -- LHS args
170 | BuiltinRule -- Built-in rules are used for constant folding
171 -- and suchlike. It has no free variables.
172 ([CoreExpr] -> Maybe (RuleName, CoreExpr))
174 isBuiltinRule (BuiltinRule _) = True
175 isBuiltinRule _ = False
179 %************************************************************************
181 \subsection{@Unfolding@ type}
183 %************************************************************************
185 The @Unfolding@ type is declared here to avoid numerous loops, but it
186 should be abstract everywhere except in CoreUnfold.lhs
192 | OtherCon [AltCon] -- It ain't one of these
193 -- (OtherCon xs) also indicates that something has been evaluated
194 -- and hence there's no point in re-evaluating it.
195 -- OtherCon [] is used even for non-data-type values
196 -- to indicated evaluated-ness. Notably:
197 -- data C = C !(Int -> Int)
198 -- case x of { C f -> ... }
199 -- Here, f gets an OtherCon [] unfolding.
201 | CompulsoryUnfolding CoreExpr -- There is no "original" definition,
202 -- so you'd better unfold.
204 | CoreUnfolding -- An unfolding with redundant cached information
205 CoreExpr -- Template; binder-info is correct
206 Bool -- True <=> top level binding
207 Bool -- exprIsValue template (cached); it is ok to discard a `seq` on
209 Bool -- True <=> doesn't waste (much) work to expand inside an inlining
210 -- Basically it's exprIsCheap
211 UnfoldingGuidance -- Tells about the *size* of the template.
214 data UnfoldingGuidance
216 | UnfoldIfGoodArgs Int -- and "n" value args
218 [Int] -- Discount if the argument is evaluated.
219 -- (i.e., a simplification will definitely
220 -- be possible). One elt of the list per *value* arg.
222 Int -- The "size" of the unfolding; to be elaborated
225 Int -- Scrutinee discount: the discount to substract if the thing is in
226 -- a context (case (thing args) of ...),
227 -- (where there are the right number of arguments.)
229 noUnfolding = NoUnfolding
230 mkOtherCon = OtherCon
232 seqUnfolding :: Unfolding -> ()
233 seqUnfolding (CoreUnfolding e top b1 b2 g)
234 = seqExpr e `seq` top `seq` b1 `seq` b2 `seq` seqGuidance g
235 seqUnfolding other = ()
237 seqGuidance (UnfoldIfGoodArgs n ns a b) = n `seq` sum ns `seq` a `seq` b `seq` ()
238 seqGuidance other = ()
242 unfoldingTemplate :: Unfolding -> CoreExpr
243 unfoldingTemplate (CoreUnfolding expr _ _ _ _) = expr
244 unfoldingTemplate (CompulsoryUnfolding expr) = expr
245 unfoldingTemplate other = panic "getUnfoldingTemplate"
247 maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr
248 maybeUnfoldingTemplate (CoreUnfolding expr _ _ _ _) = Just expr
249 maybeUnfoldingTemplate (CompulsoryUnfolding expr) = Just expr
250 maybeUnfoldingTemplate other = Nothing
252 otherCons :: Unfolding -> [AltCon]
253 otherCons (OtherCon cons) = cons
256 isValueUnfolding :: Unfolding -> Bool
257 -- Returns False for OtherCon
258 isValueUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald
259 isValueUnfolding other = False
261 isEvaldUnfolding :: Unfolding -> Bool
262 -- Returns True for OtherCon
263 isEvaldUnfolding (OtherCon _) = True
264 isEvaldUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald
265 isEvaldUnfolding other = False
267 isCheapUnfolding :: Unfolding -> Bool
268 isCheapUnfolding (CoreUnfolding _ _ _ is_cheap _) = is_cheap
269 isCheapUnfolding other = False
271 isCompulsoryUnfolding :: Unfolding -> Bool
272 isCompulsoryUnfolding (CompulsoryUnfolding _) = True
273 isCompulsoryUnfolding other = False
275 hasUnfolding :: Unfolding -> Bool
276 hasUnfolding (CoreUnfolding _ _ _ _ _) = True
277 hasUnfolding (CompulsoryUnfolding _) = True
278 hasUnfolding other = False
280 hasSomeUnfolding :: Unfolding -> Bool
281 hasSomeUnfolding NoUnfolding = False
282 hasSomeUnfolding other = True
284 neverUnfold :: Unfolding -> Bool
285 neverUnfold NoUnfolding = True
286 neverUnfold (OtherCon _) = True
287 neverUnfold (CoreUnfolding _ _ _ _ UnfoldNever) = True
288 neverUnfold other = False
292 %************************************************************************
294 \subsection{The main data type}
296 %************************************************************************
299 -- The Ord is needed for the FiniteMap used in the lookForConstructor
300 -- in SimplEnv. If you declared that lookForConstructor *ignores*
301 -- constructor-applications with LitArg args, then you could get
304 instance Outputable AltCon where
305 ppr (DataAlt dc) = ppr dc
306 ppr (LitAlt lit) = ppr lit
307 ppr DEFAULT = ptext SLIT("__DEFAULT")
309 instance Show AltCon where
310 showsPrec p con = showsPrecSDoc p (ppr con)
314 %************************************************************************
316 \subsection{Useful synonyms}
318 %************************************************************************
324 type CoreExpr = Expr CoreBndr
325 type CoreArg = Arg CoreBndr
326 type CoreBind = Bind CoreBndr
327 type CoreAlt = Alt CoreBndr
330 Binders are ``tagged'' with a \tr{t}:
333 type Tagged t = (CoreBndr, t)
335 type TaggedBind t = Bind (Tagged t)
336 type TaggedExpr t = Expr (Tagged t)
337 type TaggedArg t = Arg (Tagged t)
338 type TaggedAlt t = Alt (Tagged t)
342 %************************************************************************
344 \subsection{Core-constructing functions with checking}
346 %************************************************************************
349 mkApps :: Expr b -> [Arg b] -> Expr b
350 mkTyApps :: Expr b -> [Type] -> Expr b
351 mkValApps :: Expr b -> [Expr b] -> Expr b
352 mkVarApps :: Expr b -> [Var] -> Expr b
354 mkApps f args = foldl App f args
355 mkTyApps f args = foldl (\ e a -> App e (Type a)) f args
356 mkValApps f args = foldl (\ e a -> App e a) f args
357 mkVarApps f vars = foldl (\ e a -> App e (varToCoreExpr a)) f vars
359 mkLit :: Literal -> Expr b
360 mkIntLit :: Integer -> Expr b
361 mkIntLitInt :: Int -> Expr b
362 mkConApp :: DataCon -> [Arg b] -> Expr b
363 mkLets :: [Bind b] -> Expr b -> Expr b
364 mkLams :: [b] -> Expr b -> Expr b
367 mkConApp con args = mkApps (Var (dataConId con)) args
369 mkLams binders body = foldr Lam body binders
370 mkLets binds body = foldr Let body binds
372 mkIntLit n = Lit (mkMachInt n)
373 mkIntLitInt n = Lit (mkMachInt (toInteger n))
375 varToCoreExpr :: CoreBndr -> Expr b
376 varToCoreExpr v | isId v = Var v
377 | otherwise = Type (mkTyVarTy v)
381 %************************************************************************
383 \subsection{Simple access functions}
385 %************************************************************************
388 bindersOf :: Bind b -> [b]
389 bindersOf (NonRec binder _) = [binder]
390 bindersOf (Rec pairs) = [binder | (binder, _) <- pairs]
392 bindersOfBinds :: [Bind b] -> [b]
393 bindersOfBinds binds = foldr ((++) . bindersOf) [] binds
395 rhssOfBind :: Bind b -> [Expr b]
396 rhssOfBind (NonRec _ rhs) = [rhs]
397 rhssOfBind (Rec pairs) = [rhs | (_,rhs) <- pairs]
399 rhssOfAlts :: [Alt b] -> [Expr b]
400 rhssOfAlts alts = [e | (_,_,e) <- alts]
402 flattenBinds :: [Bind b] -> [(b, Expr b)] -- Get all the lhs/rhs pairs
403 flattenBinds (NonRec b r : binds) = (b,r) : flattenBinds binds
404 flattenBinds (Rec prs1 : binds) = prs1 ++ flattenBinds binds
408 We often want to strip off leading lambdas before getting down to
409 business. @collectBinders@ is your friend.
411 We expect (by convention) type-, and value- lambdas in that
415 collectBinders :: Expr b -> ([b], Expr b)
416 collectBindersIgnoringNotes :: Expr b -> ([b], Expr b)
417 collectTyBinders :: CoreExpr -> ([TyVar], CoreExpr)
418 collectValBinders :: CoreExpr -> ([Id], CoreExpr)
419 collectTyAndValBinders :: CoreExpr -> ([TyVar], [Id], CoreExpr)
424 go bs (Lam b e) = go (b:bs) e
425 go bs e = (reverse bs, e)
427 -- This one ignores notes. It's used in CoreUnfold and StrAnal
428 -- when we aren't going to put the expression back together from
429 -- the pieces, so we don't mind losing the Notes
430 collectBindersIgnoringNotes expr
433 go bs (Lam b e) = go (b:bs) e
434 go bs (Note _ e) = go bs e
435 go bs e = (reverse bs, e)
437 collectTyAndValBinders expr
440 (tvs, body1) = collectTyBinders expr
441 (ids, body) = collectValBinders body1
443 collectTyBinders expr
446 go tvs (Lam b e) | isTyVar b = go (b:tvs) e
447 go tvs e = (reverse tvs, e)
449 collectValBinders expr
452 go ids (Lam b e) | isId b = go (b:ids) e
453 go ids body = (reverse ids, body)
457 @collectArgs@ takes an application expression, returning the function
458 and the arguments to which it is applied.
461 collectArgs :: Expr b -> (Expr b, [Arg b])
465 go (App f a) as = go f (a:as)
469 coreExprCc gets the cost centre enclosing an expression, if any.
470 It looks inside lambdas because (scc "foo" \x.e) = \x.scc "foo" e
473 coreExprCc :: Expr b -> CostCentre
474 coreExprCc (Note (SCC cc) e) = cc
475 coreExprCc (Note other_note e) = coreExprCc e
476 coreExprCc (Lam _ e) = coreExprCc e
477 coreExprCc other = noCostCentre
481 %************************************************************************
483 \subsection{Predicates}
485 %************************************************************************
488 isValArg (Type _) = False
489 isValArg other = True
491 isTypeArg (Type _) = True
492 isTypeArg other = False
494 valBndrCount :: [CoreBndr] -> Int
496 valBndrCount (b : bs) | isId b = 1 + valBndrCount bs
497 | otherwise = valBndrCount bs
499 valArgCount :: [Arg b] -> Int
501 valArgCount (Type _ : args) = valArgCount args
502 valArgCount (other : args) = 1 + valArgCount args
506 %************************************************************************
508 \subsection{Seq stuff}
510 %************************************************************************
513 seqExpr :: CoreExpr -> ()
514 seqExpr (Var v) = v `seq` ()
515 seqExpr (Lit lit) = lit `seq` ()
516 seqExpr (App f a) = seqExpr f `seq` seqExpr a
517 seqExpr (Lam b e) = seqBndr b `seq` seqExpr e
518 seqExpr (Let b e) = seqBind b `seq` seqExpr e
519 seqExpr (Case e b as) = seqExpr e `seq` seqBndr b `seq` seqAlts as
520 seqExpr (Note n e) = seqNote n `seq` seqExpr e
521 seqExpr (Type t) = seqType t
524 seqExprs (e:es) = seqExpr e `seq` seqExprs es
526 seqNote (Coerce t1 t2) = seqType t1 `seq` seqType t2
529 seqBndr b = b `seq` ()
532 seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
534 seqBind (NonRec b e) = seqBndr b `seq` seqExpr e
535 seqBind (Rec prs) = seqPairs prs
538 seqPairs ((b,e):prs) = seqBndr b `seq` seqExpr e `seq` seqPairs prs
541 seqAlts ((c,bs,e):alts) = seqBndrs bs `seq` seqExpr e `seq` seqAlts alts
543 seqRules :: CoreRules -> ()
544 seqRules (Rules rules fvs) = seq_rules rules `seq` seqVarSet fvs
547 seq_rules (Rule fs bs es e : rules) = seqBndrs bs `seq` seqExprs (e:es) `seq` seq_rules rules
548 seq_rules (BuiltinRule _ : rules) = seq_rules rules
553 %************************************************************************
555 \subsection{Annotated core; annotation at every node in the tree}
557 %************************************************************************
560 type AnnExpr bndr annot = (annot, AnnExpr' bndr annot)
562 data AnnExpr' bndr annot
565 | AnnLam bndr (AnnExpr bndr annot)
566 | AnnApp (AnnExpr bndr annot) (AnnExpr bndr annot)
567 | AnnCase (AnnExpr bndr annot) bndr [AnnAlt bndr annot]
568 | AnnLet (AnnBind bndr annot) (AnnExpr bndr annot)
569 | AnnNote Note (AnnExpr bndr annot)
572 type AnnAlt bndr annot = (AltCon, [bndr], AnnExpr bndr annot)
574 data AnnBind bndr annot
575 = AnnNonRec bndr (AnnExpr bndr annot)
576 | AnnRec [(bndr, AnnExpr bndr annot)]
580 deAnnotate :: AnnExpr bndr annot -> Expr bndr
581 deAnnotate (_, e) = deAnnotate' e
583 deAnnotate' (AnnType t) = Type t
584 deAnnotate' (AnnVar v) = Var v
585 deAnnotate' (AnnLit lit) = Lit lit
586 deAnnotate' (AnnLam binder body) = Lam binder (deAnnotate body)
587 deAnnotate' (AnnApp fun arg) = App (deAnnotate fun) (deAnnotate arg)
588 deAnnotate' (AnnNote note body) = Note note (deAnnotate body)
590 deAnnotate' (AnnLet bind body)
591 = Let (deAnnBind bind) (deAnnotate body)
593 deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs)
594 deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs]
596 deAnnotate' (AnnCase scrut v alts)
597 = Case (deAnnotate scrut) v (map deAnnAlt alts)
599 deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs)