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