Replace calls to `ptext . sLit` with `text`
[ghc.git] / compiler / coreSyn / CoreSyn.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 -}
5
6 {-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-}
7
8 -- | CoreSyn holds all the main data types for use by for the Glasgow Haskell Compiler midsection
9 module CoreSyn (
10 -- * Main data types
11 Expr(..), Alt, Bind(..), AltCon(..), Arg,
12 Tickish(..), TickishScoping(..), TickishPlacement(..),
13 CoreProgram, CoreExpr, CoreAlt, CoreBind, CoreArg, CoreBndr,
14 TaggedExpr, TaggedAlt, TaggedBind, TaggedArg, TaggedBndr(..), deTagExpr,
15
16 -- ** 'Expr' construction
17 mkLets, mkLams,
18 mkApps, mkTyApps, mkCoApps, mkVarApps,
19
20 mkIntLit, mkIntLitInt,
21 mkWordLit, mkWordLitWord,
22 mkWord64LitWord64, mkInt64LitInt64,
23 mkCharLit, mkStringLit,
24 mkFloatLit, mkFloatLitFloat,
25 mkDoubleLit, mkDoubleLitDouble,
26
27 mkConApp, mkConApp2, mkTyBind, mkCoBind,
28 varToCoreExpr, varsToCoreExprs,
29
30 isId, cmpAltCon, cmpAlt, ltAlt,
31
32 -- ** Simple 'Expr' access functions and predicates
33 bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts,
34 collectBinders, collectTyAndValBinders,
35 collectArgs, collectArgsTicks, flattenBinds,
36
37 exprToType, exprToCoercion_maybe,
38 applyTypeToArg,
39
40 isValArg, isTypeArg, isTyCoArg, valArgCount, valBndrCount,
41 isRuntimeArg, isRuntimeVar,
42
43 tickishCounts, tickishScoped, tickishScopesLike, tickishFloatable,
44 tickishCanSplit, mkNoCount, mkNoScope,
45 tickishIsCode, tickishPlace,
46 tickishContains,
47
48 -- * Unfolding data types
49 Unfolding(..), UnfoldingGuidance(..), UnfoldingSource(..),
50
51 -- ** Constructing 'Unfolding's
52 noUnfolding, evaldUnfolding, mkOtherCon,
53 unSaturatedOk, needSaturated, boringCxtOk, boringCxtNotOk,
54
55 -- ** Predicates and deconstruction on 'Unfolding'
56 unfoldingTemplate, expandUnfolding_maybe,
57 maybeUnfoldingTemplate, otherCons,
58 isValueUnfolding, isEvaldUnfolding, isCheapUnfolding,
59 isExpandableUnfolding, isConLikeUnfolding, isCompulsoryUnfolding,
60 isStableUnfolding, hasStableCoreUnfolding_maybe,
61 isClosedUnfolding, hasSomeUnfolding,
62 canUnfold, neverUnfoldGuidance, isStableSource,
63
64 -- * Annotated expression data types
65 AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt,
66
67 -- ** Operations on annotated expressions
68 collectAnnArgs, collectAnnArgsTicks,
69
70 -- ** Operations on annotations
71 deAnnotate, deAnnotate', deAnnAlt, collectAnnBndrs,
72
73 -- * Orphanhood
74 IsOrphan(..), isOrphan, notOrphan, chooseOrphanAnchor,
75
76 -- * Core rule data types
77 CoreRule(..), RuleBase,
78 RuleName, RuleFun, IdUnfoldingFun, InScopeEnv,
79 RuleEnv(..), mkRuleEnv, emptyRuleEnv,
80
81 -- ** Operations on 'CoreRule's
82 ruleArity, ruleName, ruleIdName, ruleActivation,
83 setRuleIdName,
84 isBuiltinRule, isLocalRule, isAutoRule,
85
86 -- * Core vectorisation declarations data type
87 CoreVect(..)
88 ) where
89
90 #include "HsVersions.h"
91
92 import CostCentre
93 import VarEnv( InScopeSet )
94 import Var
95 import Type
96 import Coercion
97 import Name
98 import NameEnv( NameEnv, emptyNameEnv )
99 import Literal
100 import DataCon
101 import Module
102 import TyCon
103 import BasicTypes
104 import DynFlags
105 import Outputable
106 import Util
107 import SrcLoc ( RealSrcSpan, containsSpan )
108 import Binary
109
110 import Data.Data hiding (TyCon)
111 import Data.Int
112 import Data.Word
113
114 infixl 4 `mkApps`, `mkTyApps`, `mkVarApps`, `App`, `mkCoApps`
115 -- Left associative, so that we can say (f `mkTyApps` xs `mkVarApps` ys)
116
117 {-
118 ************************************************************************
119 * *
120 \subsection{The main data types}
121 * *
122 ************************************************************************
123
124 These data types are the heart of the compiler
125 -}
126
127 -- | This is the data type that represents GHCs core intermediate language. Currently
128 -- GHC uses System FC <http://research.microsoft.com/~simonpj/papers/ext-f/> for this purpose,
129 -- which is closely related to the simpler and better known System F <http://en.wikipedia.org/wiki/System_F>.
130 --
131 -- We get from Haskell source to this Core language in a number of stages:
132 --
133 -- 1. The source code is parsed into an abstract syntax tree, which is represented
134 -- by the data type 'HsExpr.HsExpr' with the names being 'RdrName.RdrNames'
135 --
136 -- 2. This syntax tree is /renamed/, which attaches a 'Unique.Unique' to every 'RdrName.RdrName'
137 -- (yielding a 'Name.Name') to disambiguate identifiers which are lexically identical.
138 -- For example, this program:
139 --
140 -- @
141 -- f x = let f x = x + 1
142 -- in f (x - 2)
143 -- @
144 --
145 -- Would be renamed by having 'Unique's attached so it looked something like this:
146 --
147 -- @
148 -- f_1 x_2 = let f_3 x_4 = x_4 + 1
149 -- in f_3 (x_2 - 2)
150 -- @
151 -- But see Note [Shadowing] below.
152 --
153 -- 3. The resulting syntax tree undergoes type checking (which also deals with instantiating
154 -- type class arguments) to yield a 'HsExpr.HsExpr' type that has 'Id.Id' as it's names.
155 --
156 -- 4. Finally the syntax tree is /desugared/ from the expressive 'HsExpr.HsExpr' type into
157 -- this 'Expr' type, which has far fewer constructors and hence is easier to perform
158 -- optimization, analysis and code generation on.
159 --
160 -- The type parameter @b@ is for the type of binders in the expression tree.
161 --
162 -- The language consists of the following elements:
163 --
164 -- * Variables
165 --
166 -- * Primitive literals
167 --
168 -- * Applications: note that the argument may be a 'Type'.
169 --
170 -- See "CoreSyn#let_app_invariant" for another invariant
171 --
172 -- * Lambda abstraction
173 --
174 -- * Recursive and non recursive @let@s. Operationally
175 -- this corresponds to allocating a thunk for the things
176 -- bound and then executing the sub-expression.
177 --
178 -- #top_level_invariant#
179 -- #letrec_invariant#
180 --
181 -- The right hand sides of all top-level and recursive @let@s
182 -- /must/ be of lifted type (see "Type#type_classification" for
183 -- the meaning of /lifted/ vs. /unlifted/).
184 --
185 -- See Note [CoreSyn let/app invariant]
186 --
187 -- #type_let#
188 -- We allow a /non-recursive/ let to bind a type variable, thus:
189 --
190 -- > Let (NonRec tv (Type ty)) body
191 --
192 -- This can be very convenient for postponing type substitutions until
193 -- the next run of the simplifier.
194 --
195 -- At the moment, the rest of the compiler only deals with type-let
196 -- in a Let expression, rather than at top level. We may want to revist
197 -- this choice.
198 --
199 -- * Case split. Operationally this corresponds to evaluating
200 -- the scrutinee (expression examined) to weak head normal form
201 -- and then examining at most one level of resulting constructor (i.e. you
202 -- cannot do nested pattern matching directly with this).
203 --
204 -- The binder gets bound to the value of the scrutinee,
205 -- and the 'Type' must be that of all the case alternatives
206 --
207 -- #case_invariants#
208 -- This is one of the more complicated elements of the Core language,
209 -- and comes with a number of restrictions:
210 --
211 -- 1. The list of alternatives may be empty;
212 -- See Note [Empty case alternatives]
213 --
214 -- 2. The 'DEFAULT' case alternative must be first in the list,
215 -- if it occurs at all.
216 --
217 -- 3. The remaining cases are in order of increasing
218 -- tag (for 'DataAlts') or
219 -- lit (for 'LitAlts').
220 -- This makes finding the relevant constructor easy,
221 -- and makes comparison easier too.
222 --
223 -- 4. The list of alternatives must be exhaustive. An /exhaustive/ case
224 -- does not necessarily mention all constructors:
225 --
226 -- @
227 -- data Foo = Red | Green | Blue
228 -- ... case x of
229 -- Red -> True
230 -- other -> f (case x of
231 -- Green -> ...
232 -- Blue -> ... ) ...
233 -- @
234 --
235 -- The inner case does not need a @Red@ alternative, because @x@
236 -- can't be @Red@ at that program point.
237 --
238 -- 5. Floating-point values must not be scrutinised against literals.
239 -- See Trac #9238 and Note [Rules for floating-point comparisons]
240 -- in PrelRules for rationale.
241 --
242 -- * Cast an expression to a particular type.
243 -- This is used to implement @newtype@s (a @newtype@ constructor or
244 -- destructor just becomes a 'Cast' in Core) and GADTs.
245 --
246 -- * Notes. These allow general information to be added to expressions
247 -- in the syntax tree
248 --
249 -- * A type: this should only show up at the top level of an Arg
250 --
251 -- * A coercion
252
253 -- If you edit this type, you may need to update the GHC formalism
254 -- See Note [GHC Formalism] in coreSyn/CoreLint.hs
255 data Expr b
256 = Var Id
257 | Lit Literal
258 | App (Expr b) (Arg b)
259 | Lam b (Expr b)
260 | Let (Bind b) (Expr b)
261 | Case (Expr b) b Type [Alt b] -- See #case_invariant#
262 | Cast (Expr b) Coercion
263 | Tick (Tickish Id) (Expr b)
264 | Type Type
265 | Coercion Coercion
266 deriving (Data, Typeable)
267
268 -- | Type synonym for expressions that occur in function argument positions.
269 -- Only 'Arg' should contain a 'Type' at top level, general 'Expr' should not
270 type Arg b = Expr b
271
272 -- | A case split alternative. Consists of the constructor leading to the alternative,
273 -- the variables bound from the constructor, and the expression to be executed given that binding.
274 -- The default alternative is @(DEFAULT, [], rhs)@
275
276 -- If you edit this type, you may need to update the GHC formalism
277 -- See Note [GHC Formalism] in coreSyn/CoreLint.hs
278 type Alt b = (AltCon, [b], Expr b)
279
280 -- | A case alternative constructor (i.e. pattern match)
281
282 -- If you edit this type, you may need to update the GHC formalism
283 -- See Note [GHC Formalism] in coreSyn/CoreLint.hs
284 data AltCon
285 = DataAlt DataCon -- ^ A plain data constructor: @case e of { Foo x -> ... }@.
286 -- Invariant: the 'DataCon' is always from a @data@ type, and never from a @newtype@
287
288 | LitAlt Literal -- ^ A literal: @case e of { 1 -> ... }@
289 -- Invariant: always an *unlifted* literal
290 -- See Note [Literal alternatives]
291
292 | DEFAULT -- ^ Trivial alternative: @case e of { _ -> ... }@
293 deriving (Eq, Ord, Data, Typeable)
294
295 -- | Binding, used for top level bindings in a module and local bindings in a @let@.
296
297 -- If you edit this type, you may need to update the GHC formalism
298 -- See Note [GHC Formalism] in coreSyn/CoreLint.hs
299 data Bind b = NonRec b (Expr b)
300 | Rec [(b, (Expr b))]
301 deriving (Data, Typeable)
302
303 {-
304 Note [Shadowing]
305 ~~~~~~~~~~~~~~~~
306 While various passes attempt to rename on-the-fly in a manner that
307 avoids "shadowing" (thereby simplifying downstream optimizations),
308 neither the simplifier nor any other pass GUARANTEES that shadowing is
309 avoided. Thus, all passes SHOULD work fine even in the presence of
310 arbitrary shadowing in their inputs.
311
312 In particular, scrutinee variables `x` in expressions of the form
313 `Case e x t` are often renamed to variables with a prefix
314 "wild_". These "wild" variables may appear in the body of the
315 case-expression, and further, may be shadowed within the body.
316
317 So the Unique in an Var is not really unique at all. Still, it's very
318 useful to give a constant-time equality/ordering for Vars, and to give
319 a key that can be used to make sets of Vars (VarSet), or mappings from
320 Vars to other things (VarEnv). Moreover, if you do want to eliminate
321 shadowing, you can give a new Unique to an Id without changing its
322 printable name, which makes debugging easier.
323
324 Note [Literal alternatives]
325 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
326 Literal alternatives (LitAlt lit) are always for *un-lifted* literals.
327 We have one literal, a literal Integer, that is lifted, and we don't
328 allow in a LitAlt, because LitAlt cases don't do any evaluation. Also
329 (see Trac #5603) if you say
330 case 3 of
331 S# x -> ...
332 J# _ _ -> ...
333 (where S#, J# are the constructors for Integer) we don't want the
334 simplifier calling findAlt with argument (LitAlt 3). No no. Integer
335 literals are an opaque encoding of an algebraic data type, not of
336 an unlifted literal, like all the others.
337
338 Also, we do not permit case analysis with literal patterns on floating-point
339 types. See Trac #9238 and Note [Rules for floating-point comparisons] in
340 PrelRules for the rationale for this restriction.
341
342 -------------------------- CoreSyn INVARIANTS ---------------------------
343
344 Note [CoreSyn top-level invariant]
345 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
346 See #toplevel_invariant#
347
348 Note [CoreSyn letrec invariant]
349 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
350 See #letrec_invariant#
351
352 Note [CoreSyn let/app invariant]
353 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
354 The let/app invariant
355 the right hand side of a non-recursive 'Let', and
356 the argument of an 'App',
357 /may/ be of unlifted type, but only if
358 the expression is ok-for-speculation.
359
360 This means that the let can be floated around
361 without difficulty. For example, this is OK:
362
363 y::Int# = x +# 1#
364
365 But this is not, as it may affect termination if the
366 expression is floated out:
367
368 y::Int# = fac 4#
369
370 In this situation you should use @case@ rather than a @let@. The function
371 'CoreUtils.needsCaseBinding' can help you determine which to generate, or
372 alternatively use 'MkCore.mkCoreLet' rather than this constructor directly,
373 which will generate a @case@ if necessary
374
375 Th let/app invariant is initially enforced by DsUtils.mkCoreLet and mkCoreApp
376
377 Note [CoreSyn case invariants]
378 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
379 See #case_invariants#
380
381 Note [CoreSyn let goal]
382 ~~~~~~~~~~~~~~~~~~~~~~~
383 * The simplifier tries to ensure that if the RHS of a let is a constructor
384 application, its arguments are trivial, so that the constructor can be
385 inlined vigorously.
386
387 Note [Type let]
388 ~~~~~~~~~~~~~~~
389 See #type_let#
390
391 Note [Empty case alternatives]
392 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
393 The alternatives of a case expression should be exhaustive. But
394 this exhaustive list can be empty!
395
396 * A case expression can have empty alternatives if (and only if) the
397 scrutinee is bound to raise an exception or diverge. When do we know
398 this? See Note [Bottoming expressions] in CoreUtils.
399
400 * The possiblity of empty alternatives is one reason we need a type on
401 the case expression: if the alternatives are empty we can't get the
402 type from the alternatives!
403
404 * In the case of empty types (see Note [Bottoming expressions]), say
405 data T
406 we do NOT want to replace
407 case (x::T) of Bool {} --> error Bool "Inaccessible case"
408 because x might raise an exception, and *that*'s what we want to see!
409 (Trac #6067 is an example.) To preserve semantics we'd have to say
410 x `seq` error Bool "Inaccessible case"
411 but the 'seq' is just a case, so we are back to square 1. Or I suppose
412 we could say
413 x |> UnsafeCoerce T Bool
414 but that loses all trace of the fact that this originated with an empty
415 set of alternatives.
416
417 * We can use the empty-alternative construct to coerce error values from
418 one type to another. For example
419
420 f :: Int -> Int
421 f n = error "urk"
422
423 g :: Int -> (# Char, Bool #)
424 g x = case f x of { 0 -> ..., n -> ... }
425
426 Then if we inline f in g's RHS we get
427 case (error Int "urk") of (# Char, Bool #) { ... }
428 and we can discard the alternatives since the scrutinee is bottom to give
429 case (error Int "urk") of (# Char, Bool #) {}
430
431 This is nicer than using an unsafe coerce between Int ~ (# Char,Bool #),
432 if for no other reason that we don't need to instantiate the (~) at an
433 unboxed type.
434
435 * We treat a case expression with empty alternatives as trivial iff
436 its scrutinee is (see CoreUtils.exprIsTrivial). This is actually
437 important; see Note [Empty case is trivial] in CoreUtils
438
439 * An empty case is replaced by its scrutinee during the CoreToStg
440 conversion; remember STG is un-typed, so there is no need for
441 the empty case to do the type conversion.
442
443
444 ************************************************************************
445 * *
446 Ticks
447 * *
448 ************************************************************************
449 -}
450
451 -- | Allows attaching extra information to points in expressions
452
453 -- If you edit this type, you may need to update the GHC formalism
454 -- See Note [GHC Formalism] in coreSyn/CoreLint.hs
455 data Tickish id =
456 -- | An @{-# SCC #-}@ profiling annotation, either automatically
457 -- added by the desugarer as a result of -auto-all, or added by
458 -- the user.
459 ProfNote {
460 profNoteCC :: CostCentre, -- ^ the cost centre
461 profNoteCount :: !Bool, -- ^ bump the entry count?
462 profNoteScope :: !Bool -- ^ scopes over the enclosed expression
463 -- (i.e. not just a tick)
464 }
465
466 -- | A "tick" used by HPC to track the execution of each
467 -- subexpression in the original source code.
468 | HpcTick {
469 tickModule :: Module,
470 tickId :: !Int
471 }
472
473 -- | A breakpoint for the GHCi debugger. This behaves like an HPC
474 -- tick, but has a list of free variables which will be available
475 -- for inspection in GHCi when the program stops at the breakpoint.
476 --
477 -- NB. we must take account of these Ids when (a) counting free variables,
478 -- and (b) substituting (don't substitute for them)
479 | Breakpoint
480 { breakpointId :: !Int
481 , breakpointFVs :: [id] -- ^ the order of this list is important:
482 -- it matches the order of the lists in the
483 -- appropriate entry in HscTypes.ModBreaks.
484 --
485 -- Careful about substitution! See
486 -- Note [substTickish] in CoreSubst.
487 }
488
489 -- | A source note.
490 --
491 -- Source notes are pure annotations: Their presence should neither
492 -- influence compilation nor execution. The semantics are given by
493 -- causality: The presence of a source note means that a local
494 -- change in the referenced source code span will possibly provoke
495 -- the generated code to change. On the flip-side, the functionality
496 -- of annotated code *must* be invariant against changes to all
497 -- source code *except* the spans referenced in the source notes
498 -- (see "Causality of optimized Haskell" paper for details).
499 --
500 -- Therefore extending the scope of any given source note is always
501 -- valid. Note that it is still undesirable though, as this reduces
502 -- their usefulness for debugging and profiling. Therefore we will
503 -- generally try only to make use of this property where it is
504 -- neccessary to enable optimizations.
505 | SourceNote
506 { sourceSpan :: RealSrcSpan -- ^ Source covered
507 , sourceName :: String -- ^ Name for source location
508 -- (uses same names as CCs)
509 }
510
511 deriving (Eq, Ord, Data, Typeable)
512
513 -- | A "counting tick" (where tickishCounts is True) is one that
514 -- counts evaluations in some way. We cannot discard a counting tick,
515 -- and the compiler should preserve the number of counting ticks as
516 -- far as possible.
517 --
518 -- However, we still allow the simplifier to increase or decrease
519 -- sharing, so in practice the actual number of ticks may vary, except
520 -- that we never change the value from zero to non-zero or vice versa.
521 tickishCounts :: Tickish id -> Bool
522 tickishCounts n@ProfNote{} = profNoteCount n
523 tickishCounts HpcTick{} = True
524 tickishCounts Breakpoint{} = True
525 tickishCounts _ = False
526
527
528 -- | Specifies the scoping behaviour of ticks. This governs the
529 -- behaviour of ticks that care about the covered code and the cost
530 -- associated with it. Important for ticks relating to profiling.
531 data TickishScoping =
532 -- | No scoping: The tick does not care about what code it
533 -- covers. Transformations can freely move code inside as well as
534 -- outside without any additional annotation obligations
535 NoScope
536
537 -- | Soft scoping: We want all code that is covered to stay
538 -- covered. Note that this scope type does not forbid
539 -- transformations from happening, as as long as all results of
540 -- the transformations are still covered by this tick or a copy of
541 -- it. For example
542 --
543 -- let x = tick<...> (let y = foo in bar) in baz
544 -- ===>
545 -- let x = tick<...> bar; y = tick<...> foo in baz
546 --
547 -- Is a valid transformation as far as "bar" and "foo" is
548 -- concerned, because both still are scoped over by the tick.
549 --
550 -- Note though that one might object to the "let" not being
551 -- covered by the tick any more. However, we are generally lax
552 -- with this - constant costs don't matter too much, and given
553 -- that the "let" was effectively merged we can view it as having
554 -- lost its identity anyway.
555 --
556 -- Also note that this scoping behaviour allows floating a tick
557 -- "upwards" in pretty much any situation. For example:
558 --
559 -- case foo of x -> tick<...> bar
560 -- ==>
561 -- tick<...> case foo of x -> bar
562 --
563 -- While this is always leagl, we want to make a best effort to
564 -- only make us of this where it exposes transformation
565 -- opportunities.
566 | SoftScope
567
568 -- | Cost centre scoping: We don't want any costs to move to other
569 -- cost-centre stacks. This means we not only want no code or cost
570 -- to get moved out of their cost centres, but we also object to
571 -- code getting associated with new cost-centre ticks - or
572 -- changing the order in which they get applied.
573 --
574 -- A rule of thumb is that we don't want any code to gain new
575 -- annotations. However, there are notable exceptions, for
576 -- example:
577 --
578 -- let f = \y -> foo in tick<...> ... (f x) ...
579 -- ==>
580 -- tick<...> ... foo[x/y] ...
581 --
582 -- In-lining lambdas like this is always legal, because inlining a
583 -- function does not change the cost-centre stack when the
584 -- function is called.
585 | CostCentreScope
586
587 deriving (Eq)
588
589 -- | Returns the intended scoping rule for a Tickish
590 tickishScoped :: Tickish id -> TickishScoping
591 tickishScoped n@ProfNote{}
592 | profNoteScope n = CostCentreScope
593 | otherwise = NoScope
594 tickishScoped HpcTick{} = NoScope
595 tickishScoped Breakpoint{} = CostCentreScope
596 -- Breakpoints are scoped: eventually we're going to do call
597 -- stacks, but also this helps prevent the simplifier from moving
598 -- breakpoints around and changing their result type (see #1531).
599 tickishScoped SourceNote{} = SoftScope
600
601 -- | Returns whether the tick scoping rule is at least as permissive
602 -- as the given scoping rule.
603 tickishScopesLike :: Tickish id -> TickishScoping -> Bool
604 tickishScopesLike t scope = tickishScoped t `like` scope
605 where NoScope `like` _ = True
606 _ `like` NoScope = False
607 SoftScope `like` _ = True
608 _ `like` SoftScope = False
609 CostCentreScope `like` _ = True
610
611 -- | Returns @True@ for ticks that can be floated upwards easily even
612 -- where it might change execution counts, such as:
613 --
614 -- Just (tick<...> foo)
615 -- ==>
616 -- tick<...> (Just foo)
617 --
618 -- This is a combination of @tickishSoftScope@ and
619 -- @tickishCounts@. Note that in principle splittable ticks can become
620 -- floatable using @mkNoTick@ -- even though there's currently no
621 -- tickish for which that is the case.
622 tickishFloatable :: Tickish id -> Bool
623 tickishFloatable t = t `tickishScopesLike` SoftScope && not (tickishCounts t)
624
625 -- | Returns @True@ for a tick that is both counting /and/ scoping and
626 -- can be split into its (tick, scope) parts using 'mkNoScope' and
627 -- 'mkNoTick' respectively.
628 tickishCanSplit :: Tickish id -> Bool
629 tickishCanSplit ProfNote{profNoteScope = True, profNoteCount = True}
630 = True
631 tickishCanSplit _ = False
632
633 mkNoCount :: Tickish id -> Tickish id
634 mkNoCount n | not (tickishCounts n) = n
635 | not (tickishCanSplit n) = panic "mkNoCount: Cannot split!"
636 mkNoCount n@ProfNote{} = n {profNoteCount = False}
637 mkNoCount _ = panic "mkNoCount: Undefined split!"
638
639 mkNoScope :: Tickish id -> Tickish id
640 mkNoScope n | tickishScoped n == NoScope = n
641 | not (tickishCanSplit n) = panic "mkNoScope: Cannot split!"
642 mkNoScope n@ProfNote{} = n {profNoteScope = False}
643 mkNoScope _ = panic "mkNoScope: Undefined split!"
644
645 -- | Return @True@ if this source annotation compiles to some backend
646 -- code. Without this flag, the tickish is seen as a simple annotation
647 -- that does not have any associated evaluation code.
648 --
649 -- What this means that we are allowed to disregard the tick if doing
650 -- so means that we can skip generating any code in the first place. A
651 -- typical example is top-level bindings:
652 --
653 -- foo = tick<...> \y -> ...
654 -- ==>
655 -- foo = \y -> tick<...> ...
656 --
657 -- Here there is just no operational difference between the first and
658 -- the second version. Therefore code generation should simply
659 -- translate the code as if it found the latter.
660 tickishIsCode :: Tickish id -> Bool
661 tickishIsCode SourceNote{} = False
662 tickishIsCode _tickish = True -- all the rest for now
663
664
665 -- | Governs the kind of expression that the tick gets placed on when
666 -- annotating for example using @mkTick@. If we find that we want to
667 -- put a tickish on an expression ruled out here, we try to float it
668 -- inwards until we find a suitable expression.
669 data TickishPlacement =
670
671 -- | Place ticks exactly on run-time expressions. We can still
672 -- move the tick through pure compile-time constructs such as
673 -- other ticks, casts or type lambdas. This is the most
674 -- restrictive placement rule for ticks, as all tickishs have in
675 -- common that they want to track runtime processes. The only
676 -- legal placement rule for counting ticks.
677 PlaceRuntime
678
679 -- | As @PlaceRuntime@, but we float the tick through all
680 -- lambdas. This makes sense where there is little difference
681 -- between annotating the lambda and annotating the lambda's code.
682 | PlaceNonLam
683
684 -- | In addition to floating through lambdas, cost-centre style
685 -- tickishs can also be moved from constructors, non-function
686 -- variables and literals. For example:
687 --
688 -- let x = scc<...> C (scc<...> y) (scc<...> 3) in ...
689 --
690 -- Neither the constructor application, the variable or the
691 -- literal are likely to have any cost worth mentioning. And even
692 -- if y names a thunk, the call would not care about the
693 -- evaluation context. Therefore removing all annotations in the
694 -- above example is safe.
695 | PlaceCostCentre
696
697 deriving (Eq)
698
699 -- | Placement behaviour we want for the ticks
700 tickishPlace :: Tickish id -> TickishPlacement
701 tickishPlace n@ProfNote{}
702 | profNoteCount n = PlaceRuntime
703 | otherwise = PlaceCostCentre
704 tickishPlace HpcTick{} = PlaceRuntime
705 tickishPlace Breakpoint{} = PlaceRuntime
706 tickishPlace SourceNote{} = PlaceNonLam
707
708 -- | Returns whether one tick "contains" the other one, therefore
709 -- making the second tick redundant.
710 tickishContains :: Eq b => Tickish b -> Tickish b -> Bool
711 tickishContains (SourceNote sp1 n1) (SourceNote sp2 n2)
712 = n1 == n2 && containsSpan sp1 sp2
713 tickishContains t1 t2
714 = t1 == t2
715
716 {-
717 ************************************************************************
718 * *
719 Orphans
720 * *
721 ************************************************************************
722 -}
723
724 -- | Is this instance an orphan? If it is not an orphan, contains an 'OccName'
725 -- witnessing the instance's non-orphanhood.
726 -- See Note [Orphans]
727 data IsOrphan
728 = IsOrphan
729 | NotOrphan OccName -- The OccName 'n' witnesses the instance's non-orphanhood
730 -- In that case, the instance is fingerprinted as part
731 -- of the definition of 'n's definition
732 deriving (Data, Typeable)
733
734 -- | Returns true if 'IsOrphan' is orphan.
735 isOrphan :: IsOrphan -> Bool
736 isOrphan IsOrphan = True
737 isOrphan _ = False
738
739 -- | Returns true if 'IsOrphan' is not an orphan.
740 notOrphan :: IsOrphan -> Bool
741 notOrphan NotOrphan{} = True
742 notOrphan _ = False
743
744 chooseOrphanAnchor :: [Name] -> IsOrphan
745 -- Something (rule, instance) is relate to all the Names in this
746 -- list. Choose one of them to be an "anchor" for the orphan. We make
747 -- the choice deterministic to avoid gratuitious changes in the ABI
748 -- hash (Trac #4012). Specficially, use lexicographic comparison of
749 -- OccName rather than comparing Uniques
750 --
751 -- NB: 'minimum' use Ord, and (Ord OccName) works lexicographically
752 --
753 chooseOrphanAnchor local_names
754 | null local_names = IsOrphan
755 | otherwise = NotOrphan (minimum occs)
756 where
757 occs = map nameOccName local_names
758
759 instance Binary IsOrphan where
760 put_ bh IsOrphan = putByte bh 0
761 put_ bh (NotOrphan n) = do
762 putByte bh 1
763 put_ bh n
764 get bh = do
765 h <- getByte bh
766 case h of
767 0 -> return IsOrphan
768 _ -> do
769 n <- get bh
770 return $ NotOrphan n
771
772 {-
773 Note [Orphans]
774 ~~~~~~~~~~~~~~
775 Class instances, rules, and family instances are divided into orphans
776 and non-orphans. Roughly speaking, an instance/rule is an orphan if
777 its left hand side mentions nothing defined in this module. Orphan-hood
778 has two major consequences
779
780 * A module that contains orphans is called an "orphan module". If
781 the module being compiled depends (transitively) on an oprhan
782 module M, then M.hi is read in regardless of whether M is oherwise
783 needed. This is to ensure that we don't miss any instance decls in
784 M. But it's painful, because it means we need to keep track of all
785 the orphan modules below us.
786
787 * A non-orphan is not finger-printed separately. Instead, for
788 fingerprinting purposes it is treated as part of the entity it
789 mentions on the LHS. For example
790 data T = T1 | T2
791 instance Eq T where ....
792 The instance (Eq T) is incorprated as part of T's fingerprint.
793
794 In constrast, orphans are all fingerprinted together in the
795 mi_orph_hash field of the ModIface.
796
797 See MkIface.addFingerprints.
798
799 Orphan-hood is computed
800 * For class instances:
801 when we make a ClsInst
802 (because it is needed during instance lookup)
803
804 * For rules and family instances:
805 when we generate an IfaceRule (MkIface.coreRuleToIfaceRule)
806 or IfaceFamInst (MkIface.instanceToIfaceInst)
807 -}
808
809 {-
810 ************************************************************************
811 * *
812 \subsection{Transformation rules}
813 * *
814 ************************************************************************
815
816 The CoreRule type and its friends are dealt with mainly in CoreRules,
817 but CoreFVs, Subst, PprCore, CoreTidy also inspect the representation.
818 -}
819
820 -- | Gathers a collection of 'CoreRule's. Maps (the name of) an 'Id' to its rules
821 type RuleBase = NameEnv [CoreRule]
822 -- The rules are unordered;
823 -- we sort out any overlaps on lookup
824
825 -- | A full rule environment which we can apply rules from. Like a 'RuleBase',
826 -- but it also includes the set of visible orphans we use to filter out orphan
827 -- rules which are not visible (even though we can see them...)
828 data RuleEnv
829 = RuleEnv { re_base :: RuleBase
830 , re_visible_orphs :: ModuleSet
831 }
832
833 mkRuleEnv :: RuleBase -> [Module] -> RuleEnv
834 mkRuleEnv rules vis_orphs = RuleEnv rules (mkModuleSet vis_orphs)
835
836 emptyRuleEnv :: RuleEnv
837 emptyRuleEnv = RuleEnv emptyNameEnv emptyModuleSet
838
839 -- | A 'CoreRule' is:
840 --
841 -- * \"Local\" if the function it is a rule for is defined in the
842 -- same module as the rule itself.
843 --
844 -- * \"Orphan\" if nothing on the LHS is defined in the same module
845 -- as the rule itself
846 data CoreRule
847 = Rule {
848 ru_name :: RuleName, -- ^ Name of the rule, for communication with the user
849 ru_act :: Activation, -- ^ When the rule is active
850
851 -- Rough-matching stuff
852 -- see comments with InstEnv.ClsInst( is_cls, is_rough )
853 ru_fn :: Name, -- ^ Name of the 'Id.Id' at the head of this rule
854 ru_rough :: [Maybe Name], -- ^ Name at the head of each argument to the left hand side
855
856 -- Proper-matching stuff
857 -- see comments with InstEnv.ClsInst( is_tvs, is_tys )
858 ru_bndrs :: [CoreBndr], -- ^ Variables quantified over
859 ru_args :: [CoreExpr], -- ^ Left hand side arguments
860
861 -- And the right-hand side
862 ru_rhs :: CoreExpr, -- ^ Right hand side of the rule
863 -- Occurrence info is guaranteed correct
864 -- See Note [OccInfo in unfoldings and rules]
865
866 -- Locality
867 ru_auto :: Bool, -- ^ @True@ <=> this rule is auto-generated
868 -- @False@ <=> generated at the users behest
869 -- Main effect: reporting of orphan-hood
870
871 ru_origin :: !Module, -- ^ 'Module' the rule was defined in, used
872 -- to test if we should see an orphan rule.
873
874 ru_orphan :: !IsOrphan,
875 -- ^ Whether or not the rule is an orphan.
876
877 ru_local :: Bool -- ^ @True@ iff the fn at the head of the rule is
878 -- defined in the same module as the rule
879 -- and is not an implicit 'Id' (like a record selector,
880 -- class operation, or data constructor). This
881 -- is different from 'ru_orphan', where a rule
882 -- can avoid being an orphan if *any* Name in
883 -- LHS of the rule was defined in the same
884 -- module as the rule.
885 }
886
887 -- | Built-in rules are used for constant folding
888 -- and suchlike. They have no free variables.
889 -- A built-in rule is always visible (there is no such thing as
890 -- an orphan built-in rule.)
891 | BuiltinRule {
892 ru_name :: RuleName, -- ^ As above
893 ru_fn :: Name, -- ^ As above
894 ru_nargs :: Int, -- ^ Number of arguments that 'ru_try' consumes,
895 -- if it fires, including type arguments
896 ru_try :: RuleFun
897 -- ^ This function does the rewrite. It given too many
898 -- arguments, it simply discards them; the returned 'CoreExpr'
899 -- is just the rewrite of 'ru_fn' applied to the first 'ru_nargs' args
900 }
901 -- See Note [Extra args in rule matching] in Rules.hs
902
903 type RuleFun = DynFlags -> InScopeEnv -> Id -> [CoreExpr] -> Maybe CoreExpr
904 type InScopeEnv = (InScopeSet, IdUnfoldingFun)
905
906 type IdUnfoldingFun = Id -> Unfolding
907 -- A function that embodies how to unfold an Id if you need
908 -- to do that in the Rule. The reason we need to pass this info in
909 -- is that whether an Id is unfoldable depends on the simplifier phase
910
911 isBuiltinRule :: CoreRule -> Bool
912 isBuiltinRule (BuiltinRule {}) = True
913 isBuiltinRule _ = False
914
915 isAutoRule :: CoreRule -> Bool
916 isAutoRule (BuiltinRule {}) = False
917 isAutoRule (Rule { ru_auto = is_auto }) = is_auto
918
919 -- | The number of arguments the 'ru_fn' must be applied
920 -- to before the rule can match on it
921 ruleArity :: CoreRule -> Int
922 ruleArity (BuiltinRule {ru_nargs = n}) = n
923 ruleArity (Rule {ru_args = args}) = length args
924
925 ruleName :: CoreRule -> RuleName
926 ruleName = ru_name
927
928 ruleActivation :: CoreRule -> Activation
929 ruleActivation (BuiltinRule { }) = AlwaysActive
930 ruleActivation (Rule { ru_act = act }) = act
931
932 -- | The 'Name' of the 'Id.Id' at the head of the rule left hand side
933 ruleIdName :: CoreRule -> Name
934 ruleIdName = ru_fn
935
936 isLocalRule :: CoreRule -> Bool
937 isLocalRule = ru_local
938
939 -- | Set the 'Name' of the 'Id.Id' at the head of the rule left hand side
940 setRuleIdName :: Name -> CoreRule -> CoreRule
941 setRuleIdName nm ru = ru { ru_fn = nm }
942
943 {-
944 ************************************************************************
945 * *
946 \subsection{Vectorisation declarations}
947 * *
948 ************************************************************************
949
950 Representation of desugared vectorisation declarations that are fed to the vectoriser (via
951 'ModGuts').
952 -}
953
954 data CoreVect = Vect Id CoreExpr
955 | NoVect Id
956 | VectType Bool TyCon (Maybe TyCon)
957 | VectClass TyCon -- class tycon
958 | VectInst Id -- instance dfun (always SCALAR) !!!FIXME: should be superfluous now
959
960 {-
961 ************************************************************************
962 * *
963 Unfoldings
964 * *
965 ************************************************************************
966
967 The @Unfolding@ type is declared here to avoid numerous loops
968 -}
969
970 -- | Records the /unfolding/ of an identifier, which is approximately the form the
971 -- identifier would have if we substituted its definition in for the identifier.
972 -- This type should be treated as abstract everywhere except in "CoreUnfold"
973 data Unfolding
974 = NoUnfolding -- ^ We have no information about the unfolding
975
976 | OtherCon [AltCon] -- ^ It ain't one of these constructors.
977 -- @OtherCon xs@ also indicates that something has been evaluated
978 -- and hence there's no point in re-evaluating it.
979 -- @OtherCon []@ is used even for non-data-type values
980 -- to indicated evaluated-ness. Notably:
981 --
982 -- > data C = C !(Int -> Int)
983 -- > case x of { C f -> ... }
984 --
985 -- Here, @f@ gets an @OtherCon []@ unfolding.
986
987 | DFunUnfolding { -- The Unfolding of a DFunId
988 -- See Note [DFun unfoldings]
989 -- df = /\a1..am. \d1..dn. MkD t1 .. tk
990 -- (op1 a1..am d1..dn)
991 -- (op2 a1..am d1..dn)
992 df_bndrs :: [Var], -- The bound variables [a1..m],[d1..dn]
993 df_con :: DataCon, -- The dictionary data constructor (never a newtype datacon)
994 df_args :: [CoreExpr] -- Args of the data con: types, superclasses and methods,
995 } -- in positional order
996
997 | CoreUnfolding { -- An unfolding for an Id with no pragma,
998 -- or perhaps a NOINLINE pragma
999 -- (For NOINLINE, the phase, if any, is in the
1000 -- InlinePragInfo for this Id.)
1001 uf_tmpl :: CoreExpr, -- Template; occurrence info is correct
1002 uf_src :: UnfoldingSource, -- Where the unfolding came from
1003 uf_is_top :: Bool, -- True <=> top level binding
1004 uf_is_value :: Bool, -- exprIsHNF template (cached); it is ok to discard
1005 -- a `seq` on this variable
1006 uf_is_conlike :: Bool, -- True <=> applicn of constructor or CONLIKE function
1007 -- Cached version of exprIsConLike
1008 uf_is_work_free :: Bool, -- True <=> doesn't waste (much) work to expand
1009 -- inside an inlining
1010 -- Cached version of exprIsCheap
1011 uf_expandable :: Bool, -- True <=> can expand in RULE matching
1012 -- Cached version of exprIsExpandable
1013 uf_guidance :: UnfoldingGuidance -- Tells about the *size* of the template.
1014 }
1015 -- ^ An unfolding with redundant cached information. Parameters:
1016 --
1017 -- uf_tmpl: Template used to perform unfolding;
1018 -- NB: Occurrence info is guaranteed correct:
1019 -- see Note [OccInfo in unfoldings and rules]
1020 --
1021 -- uf_is_top: Is this a top level binding?
1022 --
1023 -- uf_is_value: 'exprIsHNF' template (cached); it is ok to discard a 'seq' on
1024 -- this variable
1025 --
1026 -- uf_is_work_free: Does this waste only a little work if we expand it inside an inlining?
1027 -- Basically this is a cached version of 'exprIsWorkFree'
1028 --
1029 -- uf_guidance: Tells us about the /size/ of the unfolding template
1030
1031
1032 ------------------------------------------------
1033 data UnfoldingSource
1034 = -- See also Note [Historical note: unfoldings for wrappers]
1035
1036 InlineRhs -- The current rhs of the function
1037 -- Replace uf_tmpl each time around
1038
1039 | InlineStable -- From an INLINE or INLINABLE pragma
1040 -- INLINE if guidance is UnfWhen
1041 -- INLINABLE if guidance is UnfIfGoodArgs/UnfoldNever
1042 -- (well, technically an INLINABLE might be made
1043 -- UnfWhen if it was small enough, and then
1044 -- it will behave like INLINE outside the current
1045 -- module, but that is the way automatic unfoldings
1046 -- work so it is consistent with the intended
1047 -- meaning of INLINABLE).
1048 --
1049 -- uf_tmpl may change, but only as a result of
1050 -- gentle simplification, it doesn't get updated
1051 -- to the current RHS during compilation as with
1052 -- InlineRhs.
1053 --
1054 -- See Note [InlineRules]
1055
1056 | InlineCompulsory -- Something that *has* no binding, so you *must* inline it
1057 -- Only a few primop-like things have this property
1058 -- (see MkId.hs, calls to mkCompulsoryUnfolding).
1059 -- Inline absolutely always, however boring the context.
1060
1061
1062
1063 -- | 'UnfoldingGuidance' says when unfolding should take place
1064 data UnfoldingGuidance
1065 = UnfWhen { -- Inline without thinking about the *size* of the uf_tmpl
1066 -- Used (a) for small *and* cheap unfoldings
1067 -- (b) for INLINE functions
1068 -- See Note [INLINE for small functions] in CoreUnfold
1069 ug_arity :: Arity, -- Number of value arguments expected
1070
1071 ug_unsat_ok :: Bool, -- True <=> ok to inline even if unsaturated
1072 ug_boring_ok :: Bool -- True <=> ok to inline even if the context is boring
1073 -- So True,True means "always"
1074 }
1075
1076 | UnfIfGoodArgs { -- Arose from a normal Id; the info here is the
1077 -- result of a simple analysis of the RHS
1078
1079 ug_args :: [Int], -- Discount if the argument is evaluated.
1080 -- (i.e., a simplification will definitely
1081 -- be possible). One elt of the list per *value* arg.
1082
1083 ug_size :: Int, -- The "size" of the unfolding.
1084
1085 ug_res :: Int -- Scrutinee discount: the discount to substract if the thing is in
1086 } -- a context (case (thing args) of ...),
1087 -- (where there are the right number of arguments.)
1088
1089 | UnfNever -- The RHS is big, so don't inline it
1090 deriving (Eq)
1091
1092 {-
1093 Note [Historical note: unfoldings for wrappers]
1094 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1095 We used to have a nice clever scheme in interface files for
1096 wrappers. A wrapper's unfolding can be reconstructed from its worker's
1097 id and its strictness. This decreased .hi file size (sometimes
1098 significantly, for modules like GHC.Classes with many high-arity w/w
1099 splits) and had a slight corresponding effect on compile times.
1100
1101 However, when we added the second demand analysis, this scheme lead to
1102 some Core lint errors. The second analysis could change the strictness
1103 signatures, which sometimes resulted in a wrapper's regenerated
1104 unfolding applying the wrapper to too many arguments.
1105
1106 Instead of repairing the clever .hi scheme, we abandoned it in favor
1107 of simplicity. The .hi sizes are usually insignificant (excluding the
1108 +1M for base libraries), and compile time barely increases (~+1% for
1109 nofib). The nicer upshot is that the UnfoldingSource no longer mentions
1110 an Id, so, eg, substitutions need not traverse them.
1111
1112
1113 Note [DFun unfoldings]
1114 ~~~~~~~~~~~~~~~~~~~~~~
1115 The Arity in a DFunUnfolding is total number of args (type and value)
1116 that the DFun needs to produce a dictionary. That's not necessarily
1117 related to the ordinary arity of the dfun Id, esp if the class has
1118 one method, so the dictionary is represented by a newtype. Example
1119
1120 class C a where { op :: a -> Int }
1121 instance C a -> C [a] where op xs = op (head xs)
1122
1123 The instance translates to
1124
1125 $dfCList :: forall a. C a => C [a] -- Arity 2!
1126 $dfCList = /\a.\d. $copList {a} d |> co
1127
1128 $copList :: forall a. C a => [a] -> Int -- Arity 2!
1129 $copList = /\a.\d.\xs. op {a} d (head xs)
1130
1131 Now we might encounter (op (dfCList {ty} d) a1 a2)
1132 and we want the (op (dfList {ty} d)) rule to fire, because $dfCList
1133 has all its arguments, even though its (value) arity is 2. That's
1134 why we record the number of expected arguments in the DFunUnfolding.
1135
1136 Note that although it's an Arity, it's most convenient for it to give
1137 the *total* number of arguments, both type and value. See the use
1138 site in exprIsConApp_maybe.
1139 -}
1140
1141 -- Constants for the UnfWhen constructor
1142 needSaturated, unSaturatedOk :: Bool
1143 needSaturated = False
1144 unSaturatedOk = True
1145
1146 boringCxtNotOk, boringCxtOk :: Bool
1147 boringCxtOk = True
1148 boringCxtNotOk = False
1149
1150 ------------------------------------------------
1151 noUnfolding :: Unfolding
1152 -- ^ There is no known 'Unfolding'
1153 evaldUnfolding :: Unfolding
1154 -- ^ This unfolding marks the associated thing as being evaluated
1155
1156 noUnfolding = NoUnfolding
1157 evaldUnfolding = OtherCon []
1158
1159 mkOtherCon :: [AltCon] -> Unfolding
1160 mkOtherCon = OtherCon
1161
1162 isStableSource :: UnfoldingSource -> Bool
1163 -- Keep the unfolding template
1164 isStableSource InlineCompulsory = True
1165 isStableSource InlineStable = True
1166 isStableSource InlineRhs = False
1167
1168 -- | Retrieves the template of an unfolding: panics if none is known
1169 unfoldingTemplate :: Unfolding -> CoreExpr
1170 unfoldingTemplate = uf_tmpl
1171
1172 -- | Retrieves the template of an unfolding if possible
1173 -- maybeUnfoldingTemplate is used mainly wnen specialising, and we do
1174 -- want to specialise DFuns, so it's important to return a template
1175 -- for DFunUnfoldings
1176 maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr
1177 maybeUnfoldingTemplate (CoreUnfolding { uf_tmpl = expr })
1178 = Just expr
1179 maybeUnfoldingTemplate (DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args })
1180 = Just (mkLams bndrs (mkApps (Var (dataConWorkId con)) args))
1181 maybeUnfoldingTemplate _
1182 = Nothing
1183
1184 -- | The constructors that the unfolding could never be:
1185 -- returns @[]@ if no information is available
1186 otherCons :: Unfolding -> [AltCon]
1187 otherCons (OtherCon cons) = cons
1188 otherCons _ = []
1189
1190 -- | Determines if it is certainly the case that the unfolding will
1191 -- yield a value (something in HNF): returns @False@ if unsure
1192 isValueUnfolding :: Unfolding -> Bool
1193 -- Returns False for OtherCon
1194 isValueUnfolding (CoreUnfolding { uf_is_value = is_evald }) = is_evald
1195 isValueUnfolding _ = False
1196
1197 -- | Determines if it possibly the case that the unfolding will
1198 -- yield a value. Unlike 'isValueUnfolding' it returns @True@
1199 -- for 'OtherCon'
1200 isEvaldUnfolding :: Unfolding -> Bool
1201 -- Returns True for OtherCon
1202 isEvaldUnfolding (OtherCon _) = True
1203 isEvaldUnfolding (CoreUnfolding { uf_is_value = is_evald }) = is_evald
1204 isEvaldUnfolding _ = False
1205
1206 -- | @True@ if the unfolding is a constructor application, the application
1207 -- of a CONLIKE function or 'OtherCon'
1208 isConLikeUnfolding :: Unfolding -> Bool
1209 isConLikeUnfolding (OtherCon _) = True
1210 isConLikeUnfolding (CoreUnfolding { uf_is_conlike = con }) = con
1211 isConLikeUnfolding _ = False
1212
1213 -- | Is the thing we will unfold into certainly cheap?
1214 isCheapUnfolding :: Unfolding -> Bool
1215 isCheapUnfolding (CoreUnfolding { uf_is_work_free = is_wf }) = is_wf
1216 isCheapUnfolding _ = False
1217
1218 isExpandableUnfolding :: Unfolding -> Bool
1219 isExpandableUnfolding (CoreUnfolding { uf_expandable = is_expable }) = is_expable
1220 isExpandableUnfolding _ = False
1221
1222 expandUnfolding_maybe :: Unfolding -> Maybe CoreExpr
1223 -- Expand an expandable unfolding; this is used in rule matching
1224 -- See Note [Expanding variables] in Rules.hs
1225 -- The key point here is that CONLIKE things can be expanded
1226 expandUnfolding_maybe (CoreUnfolding { uf_expandable = True, uf_tmpl = rhs }) = Just rhs
1227 expandUnfolding_maybe _ = Nothing
1228
1229 hasStableCoreUnfolding_maybe :: Unfolding -> Maybe Bool
1230 -- Just True <=> has stable inlining, very keen to inline (eg. INLINE pragma)
1231 -- Just False <=> has stable inlining, open to inlining it (eg. INLINEABLE pragma)
1232 -- Nothing <=> not stable, or cannot inline it anyway
1233 hasStableCoreUnfolding_maybe (CoreUnfolding { uf_src = src, uf_guidance = guide })
1234 | isStableSource src
1235 = case guide of
1236 UnfWhen {} -> Just True
1237 UnfIfGoodArgs {} -> Just False
1238 UnfNever -> Nothing
1239 hasStableCoreUnfolding_maybe _ = Nothing
1240
1241 isCompulsoryUnfolding :: Unfolding -> Bool
1242 isCompulsoryUnfolding (CoreUnfolding { uf_src = InlineCompulsory }) = True
1243 isCompulsoryUnfolding _ = False
1244
1245 isStableUnfolding :: Unfolding -> Bool
1246 -- True of unfoldings that should not be overwritten
1247 -- by a CoreUnfolding for the RHS of a let-binding
1248 isStableUnfolding (CoreUnfolding { uf_src = src }) = isStableSource src
1249 isStableUnfolding (DFunUnfolding {}) = True
1250 isStableUnfolding _ = False
1251
1252 isClosedUnfolding :: Unfolding -> Bool -- No free variables
1253 isClosedUnfolding (CoreUnfolding {}) = False
1254 isClosedUnfolding (DFunUnfolding {}) = False
1255 isClosedUnfolding _ = True
1256
1257 -- | Only returns False if there is no unfolding information available at all
1258 hasSomeUnfolding :: Unfolding -> Bool
1259 hasSomeUnfolding NoUnfolding = False
1260 hasSomeUnfolding _ = True
1261
1262 neverUnfoldGuidance :: UnfoldingGuidance -> Bool
1263 neverUnfoldGuidance UnfNever = True
1264 neverUnfoldGuidance _ = False
1265
1266 canUnfold :: Unfolding -> Bool
1267 canUnfold (CoreUnfolding { uf_guidance = g }) = not (neverUnfoldGuidance g)
1268 canUnfold _ = False
1269
1270 {-
1271 Note [InlineRules]
1272 ~~~~~~~~~~~~~~~~~
1273 When you say
1274 {-# INLINE f #-}
1275 f x = <rhs>
1276 you intend that calls (f e) are replaced by <rhs>[e/x] So we
1277 should capture (\x.<rhs>) in the Unfolding of 'f', and never meddle
1278 with it. Meanwhile, we can optimise <rhs> to our heart's content,
1279 leaving the original unfolding intact in Unfolding of 'f'. For example
1280 all xs = foldr (&&) True xs
1281 any p = all . map p {-# INLINE any #-}
1282 We optimise any's RHS fully, but leave the InlineRule saying "all . map p",
1283 which deforests well at the call site.
1284
1285 So INLINE pragma gives rise to an InlineRule, which captures the original RHS.
1286
1287 Moreover, it's only used when 'f' is applied to the
1288 specified number of arguments; that is, the number of argument on
1289 the LHS of the '=' sign in the original source definition.
1290 For example, (.) is now defined in the libraries like this
1291 {-# INLINE (.) #-}
1292 (.) f g = \x -> f (g x)
1293 so that it'll inline when applied to two arguments. If 'x' appeared
1294 on the left, thus
1295 (.) f g x = f (g x)
1296 it'd only inline when applied to three arguments. This slightly-experimental
1297 change was requested by Roman, but it seems to make sense.
1298
1299 See also Note [Inlining an InlineRule] in CoreUnfold.
1300
1301
1302 Note [OccInfo in unfoldings and rules]
1303 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1304 In unfoldings and rules, we guarantee that the template is occ-analysed,
1305 so that the occurrence info on the binders is correct. This is important,
1306 because the Simplifier does not re-analyse the template when using it. If
1307 the occurrence info is wrong
1308 - We may get more simpifier iterations than necessary, because
1309 once-occ info isn't there
1310 - More seriously, we may get an infinite loop if there's a Rec
1311 without a loop breaker marked
1312
1313
1314 ************************************************************************
1315 * *
1316 AltCon
1317 * *
1318 ************************************************************************
1319 -}
1320
1321 -- The Ord is needed for the FiniteMap used in the lookForConstructor
1322 -- in SimplEnv. If you declared that lookForConstructor *ignores*
1323 -- constructor-applications with LitArg args, then you could get
1324 -- rid of this Ord.
1325
1326 instance Outputable AltCon where
1327 ppr (DataAlt dc) = ppr dc
1328 ppr (LitAlt lit) = ppr lit
1329 ppr DEFAULT = text "__DEFAULT"
1330
1331 cmpAlt :: (AltCon, a, b) -> (AltCon, a, b) -> Ordering
1332 cmpAlt (con1, _, _) (con2, _, _) = con1 `cmpAltCon` con2
1333
1334 ltAlt :: (AltCon, a, b) -> (AltCon, a, b) -> Bool
1335 ltAlt a1 a2 = (a1 `cmpAlt` a2) == LT
1336
1337 cmpAltCon :: AltCon -> AltCon -> Ordering
1338 -- ^ Compares 'AltCon's within a single list of alternatives
1339 cmpAltCon DEFAULT DEFAULT = EQ
1340 cmpAltCon DEFAULT _ = LT
1341
1342 cmpAltCon (DataAlt d1) (DataAlt d2) = dataConTag d1 `compare` dataConTag d2
1343 cmpAltCon (DataAlt _) DEFAULT = GT
1344 cmpAltCon (LitAlt l1) (LitAlt l2) = l1 `compare` l2
1345 cmpAltCon (LitAlt _) DEFAULT = GT
1346
1347 cmpAltCon con1 con2 = WARN( True, text "Comparing incomparable AltCons" <+>
1348 ppr con1 <+> ppr con2 )
1349 LT
1350
1351 {-
1352 ************************************************************************
1353 * *
1354 \subsection{Useful synonyms}
1355 * *
1356 ************************************************************************
1357
1358 Note [CoreProgram]
1359 ~~~~~~~~~~~~~~~~~~
1360 The top level bindings of a program, a CoreProgram, are represented as
1361 a list of CoreBind
1362
1363 * Later bindings in the list can refer to earlier ones, but not vice
1364 versa. So this is OK
1365 NonRec { x = 4 }
1366 Rec { p = ...q...x...
1367 ; q = ...p...x }
1368 Rec { f = ...p..x..f.. }
1369 NonRec { g = ..f..q...x.. }
1370 But it would NOT be ok for 'f' to refer to 'g'.
1371
1372 * The occurrence analyser does strongly-connected component analysis
1373 on each Rec binding, and splits it into a sequence of smaller
1374 bindings where possible. So the program typically starts life as a
1375 single giant Rec, which is then dependency-analysed into smaller
1376 chunks.
1377 -}
1378
1379 -- If you edit this type, you may need to update the GHC formalism
1380 -- See Note [GHC Formalism] in coreSyn/CoreLint.hs
1381 type CoreProgram = [CoreBind] -- See Note [CoreProgram]
1382
1383 -- | The common case for the type of binders and variables when
1384 -- we are manipulating the Core language within GHC
1385 type CoreBndr = Var
1386 -- | Expressions where binders are 'CoreBndr's
1387 type CoreExpr = Expr CoreBndr
1388 -- | Argument expressions where binders are 'CoreBndr's
1389 type CoreArg = Arg CoreBndr
1390 -- | Binding groups where binders are 'CoreBndr's
1391 type CoreBind = Bind CoreBndr
1392 -- | Case alternatives where binders are 'CoreBndr's
1393 type CoreAlt = Alt CoreBndr
1394
1395 {-
1396 ************************************************************************
1397 * *
1398 \subsection{Tagging}
1399 * *
1400 ************************************************************************
1401 -}
1402
1403 -- | Binders are /tagged/ with a t
1404 data TaggedBndr t = TB CoreBndr t -- TB for "tagged binder"
1405
1406 type TaggedBind t = Bind (TaggedBndr t)
1407 type TaggedExpr t = Expr (TaggedBndr t)
1408 type TaggedArg t = Arg (TaggedBndr t)
1409 type TaggedAlt t = Alt (TaggedBndr t)
1410
1411 instance Outputable b => Outputable (TaggedBndr b) where
1412 ppr (TB b l) = char '<' <> ppr b <> comma <> ppr l <> char '>'
1413
1414 instance Outputable b => OutputableBndr (TaggedBndr b) where
1415 pprBndr _ b = ppr b -- Simple
1416 pprInfixOcc b = ppr b
1417 pprPrefixOcc b = ppr b
1418
1419 deTagExpr :: TaggedExpr t -> CoreExpr
1420 deTagExpr (Var v) = Var v
1421 deTagExpr (Lit l) = Lit l
1422 deTagExpr (Type ty) = Type ty
1423 deTagExpr (Coercion co) = Coercion co
1424 deTagExpr (App e1 e2) = App (deTagExpr e1) (deTagExpr e2)
1425 deTagExpr (Lam (TB b _) e) = Lam b (deTagExpr e)
1426 deTagExpr (Let bind body) = Let (deTagBind bind) (deTagExpr body)
1427 deTagExpr (Case e (TB b _) ty alts) = Case (deTagExpr e) b ty (map deTagAlt alts)
1428 deTagExpr (Tick t e) = Tick t (deTagExpr e)
1429 deTagExpr (Cast e co) = Cast (deTagExpr e) co
1430
1431 deTagBind :: TaggedBind t -> CoreBind
1432 deTagBind (NonRec (TB b _) rhs) = NonRec b (deTagExpr rhs)
1433 deTagBind (Rec prs) = Rec [(b, deTagExpr rhs) | (TB b _, rhs) <- prs]
1434
1435 deTagAlt :: TaggedAlt t -> CoreAlt
1436 deTagAlt (con, bndrs, rhs) = (con, [b | TB b _ <- bndrs], deTagExpr rhs)
1437
1438 {-
1439 ************************************************************************
1440 * *
1441 \subsection{Core-constructing functions with checking}
1442 * *
1443 ************************************************************************
1444 -}
1445
1446 -- | Apply a list of argument expressions to a function expression in a nested fashion. Prefer to
1447 -- use 'MkCore.mkCoreApps' if possible
1448 mkApps :: Expr b -> [Arg b] -> Expr b
1449 -- | Apply a list of type argument expressions to a function expression in a nested fashion
1450 mkTyApps :: Expr b -> [Type] -> Expr b
1451 -- | Apply a list of coercion argument expressions to a function expression in a nested fashion
1452 mkCoApps :: Expr b -> [Coercion] -> Expr b
1453 -- | Apply a list of type or value variables to a function expression in a nested fashion
1454 mkVarApps :: Expr b -> [Var] -> Expr b
1455 -- | Apply a list of argument expressions to a data constructor in a nested fashion. Prefer to
1456 -- use 'MkCore.mkCoreConApps' if possible
1457 mkConApp :: DataCon -> [Arg b] -> Expr b
1458
1459 mkApps f args = foldl App f args
1460 mkCoApps f args = foldl (\ e a -> App e (Coercion a)) f args
1461 mkVarApps f vars = foldl (\ e a -> App e (varToCoreExpr a)) f vars
1462 mkConApp con args = mkApps (Var (dataConWorkId con)) args
1463
1464 mkTyApps f args = foldl (\ e a -> App e (typeOrCoercion a)) f args
1465 where
1466 typeOrCoercion ty
1467 | Just co <- isCoercionTy_maybe ty = Coercion co
1468 | otherwise = Type ty
1469
1470 mkConApp2 :: DataCon -> [Type] -> [Var] -> Expr b
1471 mkConApp2 con tys arg_ids = Var (dataConWorkId con)
1472 `mkApps` map Type tys
1473 `mkApps` map varToCoreExpr arg_ids
1474
1475
1476 -- | Create a machine integer literal expression of type @Int#@ from an @Integer@.
1477 -- If you want an expression of type @Int@ use 'MkCore.mkIntExpr'
1478 mkIntLit :: DynFlags -> Integer -> Expr b
1479 -- | Create a machine integer literal expression of type @Int#@ from an @Int@.
1480 -- If you want an expression of type @Int@ use 'MkCore.mkIntExpr'
1481 mkIntLitInt :: DynFlags -> Int -> Expr b
1482
1483 mkIntLit dflags n = Lit (mkMachInt dflags n)
1484 mkIntLitInt dflags n = Lit (mkMachInt dflags (toInteger n))
1485
1486 -- | Create a machine word literal expression of type @Word#@ from an @Integer@.
1487 -- If you want an expression of type @Word@ use 'MkCore.mkWordExpr'
1488 mkWordLit :: DynFlags -> Integer -> Expr b
1489 -- | Create a machine word literal expression of type @Word#@ from a @Word@.
1490 -- If you want an expression of type @Word@ use 'MkCore.mkWordExpr'
1491 mkWordLitWord :: DynFlags -> Word -> Expr b
1492
1493 mkWordLit dflags w = Lit (mkMachWord dflags w)
1494 mkWordLitWord dflags w = Lit (mkMachWord dflags (toInteger w))
1495
1496 mkWord64LitWord64 :: Word64 -> Expr b
1497 mkWord64LitWord64 w = Lit (mkMachWord64 (toInteger w))
1498
1499 mkInt64LitInt64 :: Int64 -> Expr b
1500 mkInt64LitInt64 w = Lit (mkMachInt64 (toInteger w))
1501
1502 -- | Create a machine character literal expression of type @Char#@.
1503 -- If you want an expression of type @Char@ use 'MkCore.mkCharExpr'
1504 mkCharLit :: Char -> Expr b
1505 -- | Create a machine string literal expression of type @Addr#@.
1506 -- If you want an expression of type @String@ use 'MkCore.mkStringExpr'
1507 mkStringLit :: String -> Expr b
1508
1509 mkCharLit c = Lit (mkMachChar c)
1510 mkStringLit s = Lit (mkMachString s)
1511
1512 -- | Create a machine single precision literal expression of type @Float#@ from a @Rational@.
1513 -- If you want an expression of type @Float@ use 'MkCore.mkFloatExpr'
1514 mkFloatLit :: Rational -> Expr b
1515 -- | Create a machine single precision literal expression of type @Float#@ from a @Float@.
1516 -- If you want an expression of type @Float@ use 'MkCore.mkFloatExpr'
1517 mkFloatLitFloat :: Float -> Expr b
1518
1519 mkFloatLit f = Lit (mkMachFloat f)
1520 mkFloatLitFloat f = Lit (mkMachFloat (toRational f))
1521
1522 -- | Create a machine double precision literal expression of type @Double#@ from a @Rational@.
1523 -- If you want an expression of type @Double@ use 'MkCore.mkDoubleExpr'
1524 mkDoubleLit :: Rational -> Expr b
1525 -- | Create a machine double precision literal expression of type @Double#@ from a @Double@.
1526 -- If you want an expression of type @Double@ use 'MkCore.mkDoubleExpr'
1527 mkDoubleLitDouble :: Double -> Expr b
1528
1529 mkDoubleLit d = Lit (mkMachDouble d)
1530 mkDoubleLitDouble d = Lit (mkMachDouble (toRational d))
1531
1532 -- | Bind all supplied binding groups over an expression in a nested let expression. Assumes
1533 -- that the rhs satisfies the let/app invariant. Prefer to use 'MkCore.mkCoreLets' if
1534 -- possible, which does guarantee the invariant
1535 mkLets :: [Bind b] -> Expr b -> Expr b
1536 -- | Bind all supplied binders over an expression in a nested lambda expression. Prefer to
1537 -- use 'MkCore.mkCoreLams' if possible
1538 mkLams :: [b] -> Expr b -> Expr b
1539
1540 mkLams binders body = foldr Lam body binders
1541 mkLets binds body = foldr Let body binds
1542
1543
1544 -- | Create a binding group where a type variable is bound to a type. Per "CoreSyn#type_let",
1545 -- this can only be used to bind something in a non-recursive @let@ expression
1546 mkTyBind :: TyVar -> Type -> CoreBind
1547 mkTyBind tv ty = NonRec tv (Type ty)
1548
1549 -- | Create a binding group where a type variable is bound to a type. Per "CoreSyn#type_let",
1550 -- this can only be used to bind something in a non-recursive @let@ expression
1551 mkCoBind :: CoVar -> Coercion -> CoreBind
1552 mkCoBind cv co = NonRec cv (Coercion co)
1553
1554 -- | Convert a binder into either a 'Var' or 'Type' 'Expr' appropriately
1555 varToCoreExpr :: CoreBndr -> Expr b
1556 varToCoreExpr v | isTyVar v = Type (mkTyVarTy v)
1557 | isCoVar v = Coercion (mkCoVarCo v)
1558 | otherwise = ASSERT( isId v ) Var v
1559
1560 varsToCoreExprs :: [CoreBndr] -> [Expr b]
1561 varsToCoreExprs vs = map varToCoreExpr vs
1562
1563 {-
1564 ************************************************************************
1565 * *
1566 Getting a result type
1567 * *
1568 ************************************************************************
1569
1570 These are defined here to avoid a module loop between CoreUtils and CoreFVs
1571
1572 -}
1573
1574 applyTypeToArg :: Type -> CoreExpr -> Type
1575 -- ^ Determines the type resulting from applying an expression with given type
1576 -- to a given argument expression
1577 applyTypeToArg fun_ty arg = piResultTy fun_ty (exprToType arg)
1578
1579 -- | If the expression is a 'Type', converts. Otherwise,
1580 -- panics. NB: This does /not/ convert 'Coercion' to 'CoercionTy'.
1581 exprToType :: CoreExpr -> Type
1582 exprToType (Type ty) = ty
1583 exprToType _bad = pprPanic "exprToType" empty
1584
1585 -- | If the expression is a 'Coercion', converts.
1586 exprToCoercion_maybe :: CoreExpr -> Maybe Coercion
1587 exprToCoercion_maybe (Coercion co) = Just co
1588 exprToCoercion_maybe _ = Nothing
1589
1590 {-
1591 ************************************************************************
1592 * *
1593 \subsection{Simple access functions}
1594 * *
1595 ************************************************************************
1596 -}
1597
1598 -- | Extract every variable by this group
1599 bindersOf :: Bind b -> [b]
1600 -- If you edit this function, you may need to update the GHC formalism
1601 -- See Note [GHC Formalism] in coreSyn/CoreLint.hs
1602 bindersOf (NonRec binder _) = [binder]
1603 bindersOf (Rec pairs) = [binder | (binder, _) <- pairs]
1604
1605 -- | 'bindersOf' applied to a list of binding groups
1606 bindersOfBinds :: [Bind b] -> [b]
1607 bindersOfBinds binds = foldr ((++) . bindersOf) [] binds
1608
1609 rhssOfBind :: Bind b -> [Expr b]
1610 rhssOfBind (NonRec _ rhs) = [rhs]
1611 rhssOfBind (Rec pairs) = [rhs | (_,rhs) <- pairs]
1612
1613 rhssOfAlts :: [Alt b] -> [Expr b]
1614 rhssOfAlts alts = [e | (_,_,e) <- alts]
1615
1616 -- | Collapse all the bindings in the supplied groups into a single
1617 -- list of lhs\/rhs pairs suitable for binding in a 'Rec' binding group
1618 flattenBinds :: [Bind b] -> [(b, Expr b)]
1619 flattenBinds (NonRec b r : binds) = (b,r) : flattenBinds binds
1620 flattenBinds (Rec prs1 : binds) = prs1 ++ flattenBinds binds
1621 flattenBinds [] = []
1622
1623 -- | We often want to strip off leading lambdas before getting down to
1624 -- business. This function is your friend.
1625 collectBinders :: Expr b -> ([b], Expr b)
1626 -- | Collect type and value binders from nested lambdas, stopping
1627 -- right before any "forall"s within a non-forall. For example,
1628 -- forall (a :: *) (b :: Foo ~ Bar) (c :: *). Baz -> forall (d :: *). Blob
1629 -- will pull out the binders for a, b, c, and Baz, but not for d or anything
1630 -- within Blob. This is to coordinate with tcSplitSigmaTy.
1631 collectTyAndValBinders :: CoreExpr -> ([TyVar], [Id], CoreExpr)
1632
1633 collectBinders expr
1634 = go [] expr
1635 where
1636 go bs (Lam b e) = go (b:bs) e
1637 go bs e = (reverse bs, e)
1638
1639 collectTyAndValBinders expr
1640 = go_forall [] [] expr
1641 where go_forall tvs ids (Lam b e)
1642 | isTyVar b = go_forall (b:tvs) ids e
1643 | isCoVar b = go_forall tvs (b:ids) e
1644 go_forall tvs ids e = go_fun tvs ids e
1645
1646 go_fun tvs ids (Lam b e)
1647 | isId b = go_fun tvs (b:ids) e
1648 go_fun tvs ids e = (reverse tvs, reverse ids, e)
1649
1650 -- | Takes a nested application expression and returns the the function
1651 -- being applied and the arguments to which it is applied
1652 collectArgs :: Expr b -> (Expr b, [Arg b])
1653 collectArgs expr
1654 = go expr []
1655 where
1656 go (App f a) as = go f (a:as)
1657 go e as = (e, as)
1658
1659 -- | Like @collectArgs@, but also collects looks through floatable
1660 -- ticks if it means that we can find more arguments.
1661 collectArgsTicks :: (Tickish Id -> Bool) -> Expr b
1662 -> (Expr b, [Arg b], [Tickish Id])
1663 collectArgsTicks skipTick expr
1664 = go expr [] []
1665 where
1666 go (App f a) as ts = go f (a:as) ts
1667 go (Tick t e) as ts
1668 | skipTick t = go e as (t:ts)
1669 go e as ts = (e, as, reverse ts)
1670
1671
1672 {-
1673 ************************************************************************
1674 * *
1675 \subsection{Predicates}
1676 * *
1677 ************************************************************************
1678
1679 At one time we optionally carried type arguments through to runtime.
1680 @isRuntimeVar v@ returns if (Lam v _) really becomes a lambda at runtime,
1681 i.e. if type applications are actual lambdas because types are kept around
1682 at runtime. Similarly isRuntimeArg.
1683 -}
1684
1685 -- | Will this variable exist at runtime?
1686 isRuntimeVar :: Var -> Bool
1687 isRuntimeVar = isId
1688
1689 -- | Will this argument expression exist at runtime?
1690 isRuntimeArg :: CoreExpr -> Bool
1691 isRuntimeArg = isValArg
1692
1693 -- | Returns @True@ for value arguments, false for type args
1694 -- NB: coercions are value arguments (zero width, to be sure,
1695 -- like State#, but still value args).
1696 isValArg :: Expr b -> Bool
1697 isValArg e = not (isTypeArg e)
1698
1699 -- | Returns @True@ iff the expression is a 'Type' or 'Coercion'
1700 -- expression at its top level
1701 isTyCoArg :: Expr b -> Bool
1702 isTyCoArg (Type {}) = True
1703 isTyCoArg (Coercion {}) = True
1704 isTyCoArg _ = False
1705
1706 -- | Returns @True@ iff the expression is a 'Type' expression at its
1707 -- top level. Note this does NOT include 'Coercion's.
1708 isTypeArg :: Expr b -> Bool
1709 isTypeArg (Type {}) = True
1710 isTypeArg _ = False
1711
1712 -- | The number of binders that bind values rather than types
1713 valBndrCount :: [CoreBndr] -> Int
1714 valBndrCount = count isId
1715
1716 -- | The number of argument expressions that are values rather than types at their top level
1717 valArgCount :: [Arg b] -> Int
1718 valArgCount = count isValArg
1719
1720 {-
1721 ************************************************************************
1722 * *
1723 \subsection{Annotated core}
1724 * *
1725 ************************************************************************
1726 -}
1727
1728 -- | Annotated core: allows annotation at every node in the tree
1729 type AnnExpr bndr annot = (annot, AnnExpr' bndr annot)
1730
1731 -- | A clone of the 'Expr' type but allowing annotation at every tree node
1732 data AnnExpr' bndr annot
1733 = AnnVar Id
1734 | AnnLit Literal
1735 | AnnLam bndr (AnnExpr bndr annot)
1736 | AnnApp (AnnExpr bndr annot) (AnnExpr bndr annot)
1737 | AnnCase (AnnExpr bndr annot) bndr Type [AnnAlt bndr annot]
1738 | AnnLet (AnnBind bndr annot) (AnnExpr bndr annot)
1739 | AnnCast (AnnExpr bndr annot) (annot, Coercion)
1740 -- Put an annotation on the (root of) the coercion
1741 | AnnTick (Tickish Id) (AnnExpr bndr annot)
1742 | AnnType Type
1743 | AnnCoercion Coercion
1744
1745 -- | A clone of the 'Alt' type but allowing annotation at every tree node
1746 type AnnAlt bndr annot = (AltCon, [bndr], AnnExpr bndr annot)
1747
1748 -- | A clone of the 'Bind' type but allowing annotation at every tree node
1749 data AnnBind bndr annot
1750 = AnnNonRec bndr (AnnExpr bndr annot)
1751 | AnnRec [(bndr, AnnExpr bndr annot)]
1752
1753 -- | Takes a nested application expression and returns the the function
1754 -- being applied and the arguments to which it is applied
1755 collectAnnArgs :: AnnExpr b a -> (AnnExpr b a, [AnnExpr b a])
1756 collectAnnArgs expr
1757 = go expr []
1758 where
1759 go (_, AnnApp f a) as = go f (a:as)
1760 go e as = (e, as)
1761
1762 collectAnnArgsTicks :: (Tickish Var -> Bool) -> AnnExpr b a
1763 -> (AnnExpr b a, [AnnExpr b a], [Tickish Var])
1764 collectAnnArgsTicks tickishOk expr
1765 = go expr [] []
1766 where
1767 go (_, AnnApp f a) as ts = go f (a:as) ts
1768 go (_, AnnTick t e) as ts | tickishOk t
1769 = go e as (t:ts)
1770 go e as ts = (e, as, reverse ts)
1771
1772 deAnnotate :: AnnExpr bndr annot -> Expr bndr
1773 deAnnotate (_, e) = deAnnotate' e
1774
1775 deAnnotate' :: AnnExpr' bndr annot -> Expr bndr
1776 deAnnotate' (AnnType t) = Type t
1777 deAnnotate' (AnnCoercion co) = Coercion co
1778 deAnnotate' (AnnVar v) = Var v
1779 deAnnotate' (AnnLit lit) = Lit lit
1780 deAnnotate' (AnnLam binder body) = Lam binder (deAnnotate body)
1781 deAnnotate' (AnnApp fun arg) = App (deAnnotate fun) (deAnnotate arg)
1782 deAnnotate' (AnnCast e (_,co)) = Cast (deAnnotate e) co
1783 deAnnotate' (AnnTick tick body) = Tick tick (deAnnotate body)
1784
1785 deAnnotate' (AnnLet bind body)
1786 = Let (deAnnBind bind) (deAnnotate body)
1787 where
1788 deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs)
1789 deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs]
1790
1791 deAnnotate' (AnnCase scrut v t alts)
1792 = Case (deAnnotate scrut) v t (map deAnnAlt alts)
1793
1794 deAnnAlt :: AnnAlt bndr annot -> Alt bndr
1795 deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs)
1796
1797 -- | As 'collectBinders' but for 'AnnExpr' rather than 'Expr'
1798 collectAnnBndrs :: AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot)
1799 collectAnnBndrs e
1800 = collect [] e
1801 where
1802 collect bs (_, AnnLam b body) = collect (b:bs) body
1803 collect bs body = (reverse bs, body)