2ddc7a51de992b116fd0a7542cbad74f8cb27e8f
[ghc.git] / compiler / coreSyn / CoreSyn.lhs
1 %
2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 %
5
6 \begin{code}
7 {-# LANGUAGE DeriveDataTypeable #-}
8
9 -- | CoreSyn holds all the main data types for use by for the Glasgow Haskell Compiler midsection
10 module CoreSyn (
11         -- * Main data types
12         Expr(..), Alt, Bind(..), AltCon(..), Arg, Note(..),
13         CoreExpr, CoreAlt, CoreBind, CoreArg, CoreBndr,
14         TaggedExpr, TaggedAlt, TaggedBind, TaggedArg, TaggedBndr(..),
15
16         -- ** 'Expr' construction
17         mkLets, mkLams,
18         mkApps, mkTyApps, mkVarApps,
19         
20         mkIntLit, mkIntLitInt,
21         mkWordLit, mkWordLitWord,
22         mkCharLit, mkStringLit,
23         mkFloatLit, mkFloatLitFloat,
24         mkDoubleLit, mkDoubleLitDouble,
25         
26         mkConApp, mkTyBind,
27         varToCoreExpr, varsToCoreExprs,
28
29         isTyVar, isId, cmpAltCon, cmpAlt, ltAlt,
30         
31         -- ** Simple 'Expr' access functions and predicates
32         bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, 
33         collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders,
34         collectArgs, coreExprCc, flattenBinds, 
35
36         isValArg, isTypeArg, valArgCount, valBndrCount, isRuntimeArg, isRuntimeVar,
37
38         -- * Unfolding data types
39         Unfolding(..),  UnfoldingGuidance(..), UnfoldingSource(..),
40                 -- Abstract everywhere but in CoreUnfold.lhs
41         
42         -- ** Constructing 'Unfolding's
43         noUnfolding, evaldUnfolding, mkOtherCon,
44         unSaturatedOk, needSaturated, boringCxtOk, boringCxtNotOk,
45         
46         -- ** Predicates and deconstruction on 'Unfolding'
47         unfoldingTemplate, setUnfoldingTemplate, expandUnfolding_maybe,
48         maybeUnfoldingTemplate, otherCons, unfoldingArity,
49         isValueUnfolding, isEvaldUnfolding, isCheapUnfolding,
50         isExpandableUnfolding, isConLikeUnfolding, isCompulsoryUnfolding,
51         isInlineRule, isInlineRule_maybe, isClosedUnfolding, hasSomeUnfolding, 
52         isStableUnfolding, canUnfold, neverUnfoldGuidance, isInlineRuleSource,
53
54         -- * Strictness
55         seqExpr, seqExprs, seqUnfolding, 
56
57         -- * Annotated expression data types
58         AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt,
59         
60         -- ** Operations on annotations
61         deAnnotate, deAnnotate', deAnnAlt, collectAnnBndrs,
62
63         -- * Core rule data types
64         CoreRule(..),   -- CoreSubst, CoreTidy, CoreFVs, PprCore only
65         RuleName, IdUnfoldingFun,
66         
67         -- ** Operations on 'CoreRule's 
68         seqRules, ruleArity, ruleName, ruleIdName, ruleActivation_maybe,
69         setRuleIdName,
70         isBuiltinRule, isLocalRule
71     ) where
72
73 #include "HsVersions.h"
74
75 import CostCentre
76 import Var
77 import Type
78 import Coercion
79 import Name
80 import Literal
81 import DataCon
82 import BasicTypes
83 import FastString
84 import Outputable
85 import Util
86
87 import Data.Data
88 import Data.Word
89
90 infixl 4 `mkApps`, `mkTyApps`, `mkVarApps`
91 -- Left associative, so that we can say (f `mkTyApps` xs `mkVarApps` ys)
92 \end{code}
93
94 %************************************************************************
95 %*                                                                      *
96 \subsection{The main data types}
97 %*                                                                      *
98 %************************************************************************
99
100 These data types are the heart of the compiler
101
102 \begin{code}
103 infixl 8 `App`  -- App brackets to the left
104
105 -- | This is the data type that represents GHCs core intermediate language. Currently
106 -- GHC uses System FC <http://research.microsoft.com/~simonpj/papers/ext-f/> for this purpose,
107 -- which is closely related to the simpler and better known System F <http://en.wikipedia.org/wiki/System_F>.
108 --
109 -- We get from Haskell source to this Core language in a number of stages:
110 --
111 -- 1. The source code is parsed into an abstract syntax tree, which is represented
112 --    by the data type 'HsExpr.HsExpr' with the names being 'RdrName.RdrNames'
113 --
114 -- 2. This syntax tree is /renamed/, which attaches a 'Unique.Unique' to every 'RdrName.RdrName'
115 --    (yielding a 'Name.Name') to disambiguate identifiers which are lexically identical. 
116 --    For example, this program:
117 --
118 -- @
119 --      f x = let f x = x + 1
120 --            in f (x - 2)
121 -- @
122 --
123 --    Would be renamed by having 'Unique's attached so it looked something like this:
124 --
125 -- @
126 --      f_1 x_2 = let f_3 x_4 = x_4 + 1
127 --                in f_3 (x_2 - 2)
128 -- @
129 --
130 -- 3. The resulting syntax tree undergoes type checking (which also deals with instantiating
131 --    type class arguments) to yield a 'HsExpr.HsExpr' type that has 'Id.Id' as it's names.
132 --
133 -- 4. Finally the syntax tree is /desugared/ from the expressive 'HsExpr.HsExpr' type into
134 --    this 'Expr' type, which has far fewer constructors and hence is easier to perform
135 --    optimization, analysis and code generation on.
136 --
137 -- The type parameter @b@ is for the type of binders in the expression tree.
138 data Expr b
139   = Var   Id                            -- ^ Variables
140
141   | Lit   Literal                       -- ^ Primitive literals
142
143   | App   (Expr b) (Arg b)              -- ^ Applications: note that the argument may be a 'Type'.
144                                         --
145                                         -- See "CoreSyn#let_app_invariant" for another invariant
146
147   | Lam   b (Expr b)                    -- ^ Lambda abstraction
148
149   | Let   (Bind b) (Expr b)             -- ^ Recursive and non recursive @let@s. Operationally
150                                         -- this corresponds to allocating a thunk for the things
151                                         -- bound and then executing the sub-expression.
152                                         -- 
153                                         -- #top_level_invariant#
154                                         -- #letrec_invariant#
155                                         --
156                                         -- The right hand sides of all top-level and recursive @let@s
157                                         -- /must/ be of lifted type (see "Type#type_classification" for
158                                         -- the meaning of /lifted/ vs. /unlifted/).
159                                         --
160                                         -- #let_app_invariant#
161                                         -- The right hand side of of a non-recursive 'Let' 
162                                         -- _and_ the argument of an 'App',
163                                         -- /may/ be of unlifted type, but only if the expression 
164                                         -- is ok-for-speculation.  This means that the let can be floated 
165                                         -- around without difficulty. For example, this is OK:
166                                         --
167                                         -- > y::Int# = x +# 1#
168                                         --
169                                         -- But this is not, as it may affect termination if the 
170                                         -- expression is floated out:
171                                         --
172                                         -- > y::Int# = fac 4#
173                                         --
174                                         -- In this situation you should use @case@ rather than a @let@. The function
175                                         -- 'CoreUtils.needsCaseBinding' can help you determine which to generate, or
176                                         -- alternatively use 'MkCore.mkCoreLet' rather than this constructor directly,
177                                         -- which will generate a @case@ if necessary
178                                         --
179                                         -- #type_let#
180                                         -- We allow a /non-recursive/ let to bind a type variable, thus:
181                                         --
182                                         -- > Let (NonRec tv (Type ty)) body
183                                         --
184                                         -- This can be very convenient for postponing type substitutions until
185                                         -- the next run of the simplifier.
186                                         --
187                                         -- At the moment, the rest of the compiler only deals with type-let
188                                         -- in a Let expression, rather than at top level.  We may want to revist
189                                         -- this choice.
190
191   | Case  (Expr b) b Type [Alt b]       -- ^ Case split. Operationally this corresponds to evaluating
192                                         -- the scrutinee (expression examined) to weak head normal form
193                                         -- and then examining at most one level of resulting constructor (i.e. you
194                                         -- cannot do nested pattern matching directly with this).
195                                         --
196                                         -- The binder gets bound to the value of the scrutinee,
197                                         -- and the 'Type' must be that of all the case alternatives
198                                         --
199                                         -- #case_invariants#
200                                         -- This is one of the more complicated elements of the Core language, 
201                                         -- and comes with a number of restrictions:
202                                         --
203                                         -- The 'DEFAULT' case alternative must be first in the list, 
204                                         -- if it occurs at all.
205                                         --
206                                         -- The remaining cases are in order of increasing 
207                                         --      tag     (for 'DataAlts') or
208                                         --      lit     (for 'LitAlts').
209                                         -- This makes finding the relevant constructor easy, 
210                                         -- and makes comparison easier too.
211                                         --
212                                         -- The list of alternatives must be exhaustive. An /exhaustive/ case 
213                                         -- does not necessarily mention all constructors:
214                                         --
215                                         -- @
216                                         --      data Foo = Red | Green | Blue
217                                         -- ... case x of 
218                                         --      Red   -> True
219                                         --      other -> f (case x of 
220                                         --                      Green -> ...
221                                         --                      Blue  -> ... ) ...
222                                         -- @
223                                         --
224                                         -- The inner case does not need a @Red@ alternative, because @x@ 
225                                         -- can't be @Red@ at that program point.
226
227   | Cast  (Expr b) Coercion             -- ^ Cast an expression to a particular type. 
228                                         -- This is used to implement @newtype@s (a @newtype@ constructor or 
229                                         -- destructor just becomes a 'Cast' in Core) and GADTs.
230
231   | Note  Note (Expr b)                 -- ^ Notes. These allow general information to be
232                                         -- added to expressions in the syntax tree
233
234   | Type  Type                          -- ^ A type: this should only show up at the top
235                                         -- level of an Arg
236   deriving (Data, Typeable)
237
238 -- | Type synonym for expressions that occur in function argument positions.
239 -- Only 'Arg' should contain a 'Type' at top level, general 'Expr' should not
240 type Arg b = Expr b
241
242 -- | A case split alternative. Consists of the constructor leading to the alternative,
243 -- the variables bound from the constructor, and the expression to be executed given that binding.
244 -- The default alternative is @(DEFAULT, [], rhs)@
245 type Alt b = (AltCon, [b], Expr b)
246
247 -- | A case alternative constructor (i.e. pattern match)
248 data AltCon = DataAlt DataCon   -- ^ A plain data constructor: @case e of { Foo x -> ... }@.
249                                 -- Invariant: the 'DataCon' is always from a @data@ type, and never from a @newtype@
250             | LitAlt  Literal   -- ^ A literal: @case e of { 1 -> ... }@
251             | DEFAULT           -- ^ Trivial alternative: @case e of { _ -> ... }@
252          deriving (Eq, Ord, Data, Typeable)
253
254 -- | Binding, used for top level bindings in a module and local bindings in a @let@.
255 data Bind b = NonRec b (Expr b)
256             | Rec [(b, (Expr b))]
257   deriving (Data, Typeable)
258 \end{code}
259
260 -------------------------- CoreSyn INVARIANTS ---------------------------
261
262 Note [CoreSyn top-level invariant]
263 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
264 See #toplevel_invariant#
265
266 Note [CoreSyn letrec invariant]
267 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
268 See #letrec_invariant#
269
270 Note [CoreSyn let/app invariant]
271 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
272 See #let_app_invariant#
273
274 This is intially enforced by DsUtils.mkCoreLet and mkCoreApp
275
276 Note [CoreSyn case invariants]
277 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
278 See #case_invariants#
279
280 Note [CoreSyn let goal]
281 ~~~~~~~~~~~~~~~~~~~~~~~
282 * The simplifier tries to ensure that if the RHS of a let is a constructor
283   application, its arguments are trivial, so that the constructor can be
284   inlined vigorously.
285
286
287 Note [Type let]
288 ~~~~~~~~~~~~~~~
289 See #type_let#
290
291 \begin{code}
292
293 -- | Allows attaching extra information to points in expressions rather than e.g. identifiers.
294 data Note
295   = SCC CostCentre      -- ^ A cost centre annotation for profiling
296   | CoreNote String     -- ^ A generic core annotation, propagated but not used by GHC
297   deriving (Data, Typeable)
298 \end{code}
299
300
301 %************************************************************************
302 %*                                                                      *
303 \subsection{Transformation rules}
304 %*                                                                      *
305 %************************************************************************
306
307 The CoreRule type and its friends are dealt with mainly in CoreRules,
308 but CoreFVs, Subst, PprCore, CoreTidy also inspect the representation.
309
310 \begin{code}
311 -- | A 'CoreRule' is:
312 --
313 -- * \"Local\" if the function it is a rule for is defined in the
314 --   same module as the rule itself.
315 --
316 -- * \"Orphan\" if nothing on the LHS is defined in the same module
317 --   as the rule itself
318 data CoreRule
319   = Rule { 
320         ru_name :: RuleName,            -- ^ Name of the rule, for communication with the user
321         ru_act  :: Activation,          -- ^ When the rule is active
322         
323         -- Rough-matching stuff
324         -- see comments with InstEnv.Instance( is_cls, is_rough )
325         ru_fn    :: Name,               -- ^ Name of the 'Id.Id' at the head of this rule
326         ru_rough :: [Maybe Name],       -- ^ Name at the head of each argument to the left hand side
327         
328         -- Proper-matching stuff
329         -- see comments with InstEnv.Instance( is_tvs, is_tys )
330         ru_bndrs :: [CoreBndr],         -- ^ Variables quantified over
331         ru_args  :: [CoreExpr],         -- ^ Left hand side arguments
332         
333         -- And the right-hand side
334         ru_rhs   :: CoreExpr,           -- ^ Right hand side of the rule
335                                         -- Occurrence info is guaranteed correct
336                                         -- See Note [OccInfo in unfoldings and rules]
337
338         -- Locality
339         ru_local :: Bool        -- ^ @True@ iff the fn at the head of the rule is
340                                 -- defined in the same module as the rule
341                                 -- and is not an implicit 'Id' (like a record selector,
342                                 -- class operation, or data constructor)
343
344                 -- NB: ru_local is *not* used to decide orphan-hood
345                 --      c.g. MkIface.coreRuleToIfaceRule
346     }
347
348   -- | Built-in rules are used for constant folding
349   -- and suchlike.  They have no free variables.
350   | BuiltinRule {               
351         ru_name  :: RuleName,   -- ^ As above
352         ru_fn    :: Name,       -- ^ As above
353         ru_nargs :: Int,        -- ^ Number of arguments that 'ru_try' consumes,
354                                 -- if it fires, including type arguments
355         ru_try  :: IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
356                 -- ^ This function does the rewrite.  It given too many
357                 -- arguments, it simply discards them; the returned 'CoreExpr'
358                 -- is just the rewrite of 'ru_fn' applied to the first 'ru_nargs' args
359     }
360                 -- See Note [Extra args in rule matching] in Rules.lhs
361
362 type IdUnfoldingFun = Id -> Unfolding
363 -- A function that embodies how to unfold an Id if you need
364 -- to do that in the Rule.  The reason we need to pass this info in
365 -- is that whether an Id is unfoldable depends on the simplifier phase
366
367 isBuiltinRule :: CoreRule -> Bool
368 isBuiltinRule (BuiltinRule {}) = True
369 isBuiltinRule _                = False
370
371 -- | The number of arguments the 'ru_fn' must be applied 
372 -- to before the rule can match on it
373 ruleArity :: CoreRule -> Int
374 ruleArity (BuiltinRule {ru_nargs = n}) = n
375 ruleArity (Rule {ru_args = args})      = length args
376
377 ruleName :: CoreRule -> RuleName
378 ruleName = ru_name
379
380 ruleActivation_maybe :: CoreRule -> Maybe Activation
381 ruleActivation_maybe (BuiltinRule { })       = Nothing
382 ruleActivation_maybe (Rule { ru_act = act }) = Just act
383
384 -- | The 'Name' of the 'Id.Id' at the head of the rule left hand side
385 ruleIdName :: CoreRule -> Name
386 ruleIdName = ru_fn
387
388 isLocalRule :: CoreRule -> Bool
389 isLocalRule = ru_local
390
391 -- | Set the 'Name' of the 'Id.Id' at the head of the rule left hand side
392 setRuleIdName :: Name -> CoreRule -> CoreRule
393 setRuleIdName nm ru = ru { ru_fn = nm }
394 \end{code}
395
396
397 %************************************************************************
398 %*                                                                      *
399                 Unfoldings
400 %*                                                                      *
401 %************************************************************************
402
403 The @Unfolding@ type is declared here to avoid numerous loops
404
405 \begin{code}
406 -- | Records the /unfolding/ of an identifier, which is approximately the form the
407 -- identifier would have if we substituted its definition in for the identifier.
408 -- This type should be treated as abstract everywhere except in "CoreUnfold"
409 data Unfolding
410   = NoUnfolding        -- ^ We have no information about the unfolding
411
412   | OtherCon [AltCon]  -- ^ It ain't one of these constructors.
413                        -- @OtherCon xs@ also indicates that something has been evaluated
414                        -- and hence there's no point in re-evaluating it.
415                        -- @OtherCon []@ is used even for non-data-type values
416                        -- to indicated evaluated-ness.  Notably:
417                        --
418                        -- > data C = C !(Int -> Int)
419                        -- > case x of { C f -> ... }
420                        --
421                        -- Here, @f@ gets an @OtherCon []@ unfolding.
422
423   | DFunUnfolding DataCon [CoreExpr]    
424                         -- The Unfolding of a DFunId
425                         --     df = /\a1..am. \d1..dn. MkD (op1 a1..am d1..dn)
426                         --                                 (op2 a1..am d1..dn)
427                         -- where Arity = n, the number of dict args to the dfun
428                         -- The [CoreExpr] are the superclasses and methods [op1,op2], 
429                         -- in positional order.
430                         -- They are usually variables, but can be trivial expressions
431                         -- instead (e.g. a type application).  
432
433   | CoreUnfolding {             -- An unfolding for an Id with no pragma, or perhaps a NOINLINE pragma
434                                 -- (For NOINLINE, the phase, if any, is in the InlinePragInfo for this Id.)
435         uf_tmpl       :: CoreExpr,        -- Template; occurrence info is correct
436         uf_src        :: UnfoldingSource, -- Where the unfolding came from
437         uf_is_top     :: Bool,          -- True <=> top level binding
438         uf_arity      :: Arity,         -- Number of value arguments expected
439         uf_is_value   :: Bool,          -- exprIsHNF template (cached); it is ok to discard a `seq` on
440                                         --      this variable
441         uf_is_conlike :: Bool,          -- True <=> application of constructor or CONLIKE function
442                                         --      Cached version of exprIsConLike
443         uf_is_cheap   :: Bool,          -- True <=> doesn't waste (much) work to expand inside an inlining
444                                         --      Cached version of exprIsCheap
445         uf_expandable :: Bool,          -- True <=> can expand in RULE matching
446                                         --      Cached version of exprIsExpandable
447         uf_guidance   :: UnfoldingGuidance      -- Tells about the *size* of the template.
448     }
449   -- ^ An unfolding with redundant cached information. Parameters:
450   --
451   --  uf_tmpl: Template used to perform unfolding; 
452   --           NB: Occurrence info is guaranteed correct: 
453   --               see Note [OccInfo in unfoldings and rules]
454   --
455   --  uf_is_top: Is this a top level binding?
456   --
457   --  uf_is_value: 'exprIsHNF' template (cached); it is ok to discard a 'seq' on
458   --     this variable
459   --
460   --  uf_is_cheap:  Does this waste only a little work if we expand it inside an inlining?
461   --     Basically this is a cached version of 'exprIsCheap'
462   --
463   --  uf_guidance:  Tells us about the /size/ of the unfolding template
464
465 ------------------------------------------------
466 data UnfoldingSource 
467   = InlineCompulsory   -- Something that *has* no binding, so you *must* inline it
468                        -- Only a few primop-like things have this property 
469                        -- (see MkId.lhs, calls to mkCompulsoryUnfolding).
470                        -- Inline absolutely always, however boring the context.
471
472   | InlineRule         -- From an {-# INLINE #-} pragma; See Note [InlineRules]
473
474   | InlineWrapper Id   -- This unfolding is a the wrapper in a 
475                        --     worker/wrapper split from the strictness analyser
476                        -- The Id is the worker-id
477                        -- Used to abbreviate the uf_tmpl in interface files
478                        --       which don't need to contain the RHS; 
479                        --       it can be derived from the strictness info
480
481   | InlineRhs          -- The current rhs of the function
482
483    -- For InlineRhs, the uf_tmpl is replaced each time around
484    -- For all the others we leave uf_tmpl alone
485
486
487 -- | 'UnfoldingGuidance' says when unfolding should take place
488 data UnfoldingGuidance
489   = UnfWhen {   -- Inline without thinking about the *size* of the uf_tmpl
490                 -- Used (a) for small *and* cheap unfoldings
491                 --      (b) for INLINE functions 
492                 -- See Note [INLINE for small functions] in CoreUnfold
493       ug_unsat_ok  :: Bool,     -- True <=> ok to inline even if unsaturated
494       ug_boring_ok :: Bool      -- True <=> ok to inline even if the context is boring
495                 -- So True,True means "always"
496     }
497
498   | UnfIfGoodArgs {     -- Arose from a normal Id; the info here is the
499                         -- result of a simple analysis of the RHS
500
501       ug_args ::  [Int],  -- Discount if the argument is evaluated.
502                           -- (i.e., a simplification will definitely
503                           -- be possible).  One elt of the list per *value* arg.
504
505       ug_size :: Int,     -- The "size" of the unfolding.
506
507       ug_res :: Int       -- Scrutinee discount: the discount to substract if the thing is in
508     }                     -- a context (case (thing args) of ...),
509                           -- (where there are the right number of arguments.)
510
511   | UnfNever        -- The RHS is big, so don't inline it
512
513 -- Constants for the UnfWhen constructor
514 needSaturated, unSaturatedOk :: Bool
515 needSaturated = False
516 unSaturatedOk = True
517
518 boringCxtNotOk, boringCxtOk :: Bool
519 boringCxtOk    = True
520 boringCxtNotOk = False
521
522 ------------------------------------------------
523 noUnfolding :: Unfolding
524 -- ^ There is no known 'Unfolding'
525 evaldUnfolding :: Unfolding
526 -- ^ This unfolding marks the associated thing as being evaluated
527
528 noUnfolding    = NoUnfolding
529 evaldUnfolding = OtherCon []
530
531 mkOtherCon :: [AltCon] -> Unfolding
532 mkOtherCon = OtherCon
533
534 seqUnfolding :: Unfolding -> ()
535 seqUnfolding (CoreUnfolding { uf_tmpl = e, uf_is_top = top, 
536                 uf_is_value = b1, uf_is_cheap = b2, 
537                 uf_expandable = b3, uf_is_conlike = b4,
538                 uf_arity = a, uf_guidance = g})
539   = seqExpr e `seq` top `seq` b1 `seq` a `seq` b2 `seq` b3 `seq` b4 `seq` seqGuidance g
540
541 seqUnfolding _ = ()
542
543 seqGuidance :: UnfoldingGuidance -> ()
544 seqGuidance (UnfIfGoodArgs ns n b) = n `seq` sum ns `seq` b `seq` ()
545 seqGuidance _                      = ()
546 \end{code}
547
548 \begin{code}
549 isInlineRuleSource :: UnfoldingSource -> Bool
550 isInlineRuleSource InlineCompulsory   = True
551 isInlineRuleSource InlineRule         = True
552 isInlineRuleSource (InlineWrapper {}) = True
553 isInlineRuleSource InlineRhs          = False
554  
555 -- | Retrieves the template of an unfolding: panics if none is known
556 unfoldingTemplate :: Unfolding -> CoreExpr
557 unfoldingTemplate = uf_tmpl
558
559 setUnfoldingTemplate :: Unfolding -> CoreExpr -> Unfolding
560 setUnfoldingTemplate unf rhs = unf { uf_tmpl = rhs }
561
562 -- | Retrieves the template of an unfolding if possible
563 maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr
564 maybeUnfoldingTemplate (CoreUnfolding { uf_tmpl = expr })       = Just expr
565 maybeUnfoldingTemplate _                                        = Nothing
566
567 -- | The constructors that the unfolding could never be: 
568 -- returns @[]@ if no information is available
569 otherCons :: Unfolding -> [AltCon]
570 otherCons (OtherCon cons) = cons
571 otherCons _               = []
572
573 -- | Determines if it is certainly the case that the unfolding will
574 -- yield a value (something in HNF): returns @False@ if unsure
575 isValueUnfolding :: Unfolding -> Bool
576         -- Returns False for OtherCon
577 isValueUnfolding (CoreUnfolding { uf_is_value = is_evald }) = is_evald
578 isValueUnfolding _                                          = False
579
580 -- | Determines if it possibly the case that the unfolding will
581 -- yield a value. Unlike 'isValueUnfolding' it returns @True@
582 -- for 'OtherCon'
583 isEvaldUnfolding :: Unfolding -> Bool
584         -- Returns True for OtherCon
585 isEvaldUnfolding (OtherCon _)                               = True
586 isEvaldUnfolding (CoreUnfolding { uf_is_value = is_evald }) = is_evald
587 isEvaldUnfolding _                                          = False
588
589 -- | @True@ if the unfolding is a constructor application, the application
590 -- of a CONLIKE function or 'OtherCon'
591 isConLikeUnfolding :: Unfolding -> Bool
592 isConLikeUnfolding (OtherCon _)                             = True
593 isConLikeUnfolding (CoreUnfolding { uf_is_conlike = con })  = con
594 isConLikeUnfolding _                                        = False
595
596 -- | Is the thing we will unfold into certainly cheap?
597 isCheapUnfolding :: Unfolding -> Bool
598 isCheapUnfolding (CoreUnfolding { uf_is_cheap = is_cheap }) = is_cheap
599 isCheapUnfolding _                                          = False
600
601 isExpandableUnfolding :: Unfolding -> Bool
602 isExpandableUnfolding (CoreUnfolding { uf_expandable = is_expable }) = is_expable
603 isExpandableUnfolding _                                              = False
604
605 expandUnfolding_maybe :: Unfolding -> Maybe CoreExpr
606 -- Expand an expandable unfolding; this is used in rule matching 
607 --   See Note [Expanding variables] in Rules.lhs
608 -- The key point here is that CONLIKE things can be expanded
609 expandUnfolding_maybe (CoreUnfolding { uf_expandable = True, uf_tmpl = rhs }) = Just rhs
610 expandUnfolding_maybe _                                                       = Nothing
611
612 isInlineRule :: Unfolding -> Bool
613 isInlineRule (CoreUnfolding { uf_src = src }) = isInlineRuleSource src
614 isInlineRule _                                = False
615
616 isInlineRule_maybe :: Unfolding -> Maybe (UnfoldingSource, Bool)
617 isInlineRule_maybe (CoreUnfolding { uf_src = src, uf_guidance = guide }) 
618    | isInlineRuleSource src
619    = Just (src, unsat_ok)
620    where
621      unsat_ok = case guide of
622                   UnfWhen unsat_ok _ -> unsat_ok
623                   _                  -> needSaturated
624 isInlineRule_maybe _ = Nothing
625
626 isCompulsoryUnfolding :: Unfolding -> Bool
627 isCompulsoryUnfolding (CoreUnfolding { uf_src = InlineCompulsory }) = True
628 isCompulsoryUnfolding _                                             = False
629
630 isStableUnfolding :: Unfolding -> Bool
631 -- True of unfoldings that should not be overwritten 
632 -- by a CoreUnfolding for the RHS of a let-binding
633 isStableUnfolding (CoreUnfolding { uf_src = src }) = isInlineRuleSource src
634 isStableUnfolding (DFunUnfolding {})               = True
635 isStableUnfolding _                                = False
636
637 unfoldingArity :: Unfolding -> Arity
638 unfoldingArity (CoreUnfolding { uf_arity = arity }) = arity
639 unfoldingArity _                                    = panic "unfoldingArity"
640
641 isClosedUnfolding :: Unfolding -> Bool          -- No free variables
642 isClosedUnfolding (CoreUnfolding {}) = False
643 isClosedUnfolding (DFunUnfolding {}) = False
644 isClosedUnfolding _                  = True
645
646 -- | Only returns False if there is no unfolding information available at all
647 hasSomeUnfolding :: Unfolding -> Bool
648 hasSomeUnfolding NoUnfolding = False
649 hasSomeUnfolding _           = True
650
651 neverUnfoldGuidance :: UnfoldingGuidance -> Bool
652 neverUnfoldGuidance UnfNever = True
653 neverUnfoldGuidance _        = False
654
655 canUnfold :: Unfolding -> Bool
656 canUnfold (CoreUnfolding { uf_guidance = g }) = not (neverUnfoldGuidance g)
657 canUnfold _                                   = False
658 \end{code}
659
660 Note [InlineRules]
661 ~~~~~~~~~~~~~~~~~
662 When you say 
663       {-# INLINE f #-}
664       f x = <rhs>
665 you intend that calls (f e) are replaced by <rhs>[e/x] So we
666 should capture (\x.<rhs>) in the Unfolding of 'f', and never meddle
667 with it.  Meanwhile, we can optimise <rhs> to our heart's content,
668 leaving the original unfolding intact in Unfolding of 'f'. For example
669         all xs = foldr (&&) True xs
670         any p = all . map p  {-# INLINE any #-}
671 We optimise any's RHS fully, but leave the InlineRule saying "all . map p",
672 which deforests well at the call site.
673
674 So INLINE pragma gives rise to an InlineRule, which captures the original RHS.
675
676 Moreover, it's only used when 'f' is applied to the
677 specified number of arguments; that is, the number of argument on 
678 the LHS of the '=' sign in the original source definition. 
679 For example, (.) is now defined in the libraries like this
680    {-# INLINE (.) #-}
681    (.) f g = \x -> f (g x)
682 so that it'll inline when applied to two arguments. If 'x' appeared
683 on the left, thus
684    (.) f g x = f (g x)
685 it'd only inline when applied to three arguments.  This slightly-experimental
686 change was requested by Roman, but it seems to make sense.
687
688 See also Note [Inlining an InlineRule] in CoreUnfold.
689
690
691 Note [OccInfo in unfoldings and rules]
692 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
693 In unfoldings and rules, we guarantee that the template is occ-analysed,
694 so that the occurence info on the binders is correct.  This is important,
695 because the Simplifier does not re-analyse the template when using it. If
696 the occurrence info is wrong
697   - We may get more simpifier iterations than necessary, because
698     once-occ info isn't there
699   - More seriously, we may get an infinite loop if there's a Rec
700     without a loop breaker marked
701
702
703 %************************************************************************
704 %*                                                                      *
705 \subsection{The main data type}
706 %*                                                                      *
707 %************************************************************************
708
709 \begin{code}
710 -- The Ord is needed for the FiniteMap used in the lookForConstructor
711 -- in SimplEnv.  If you declared that lookForConstructor *ignores*
712 -- constructor-applications with LitArg args, then you could get
713 -- rid of this Ord.
714
715 instance Outputable AltCon where
716   ppr (DataAlt dc) = ppr dc
717   ppr (LitAlt lit) = ppr lit
718   ppr DEFAULT      = ptext (sLit "__DEFAULT")
719
720 instance Show AltCon where
721   showsPrec p con = showsPrecSDoc p (ppr con)
722
723 cmpAlt :: Alt b -> Alt b -> Ordering
724 cmpAlt (con1, _, _) (con2, _, _) = con1 `cmpAltCon` con2
725
726 ltAlt :: Alt b -> Alt b -> Bool
727 ltAlt a1 a2 = (a1 `cmpAlt` a2) == LT
728
729 cmpAltCon :: AltCon -> AltCon -> Ordering
730 -- ^ Compares 'AltCon's within a single list of alternatives
731 cmpAltCon DEFAULT      DEFAULT     = EQ
732 cmpAltCon DEFAULT      _           = LT
733
734 cmpAltCon (DataAlt d1) (DataAlt d2) = dataConTag d1 `compare` dataConTag d2
735 cmpAltCon (DataAlt _)  DEFAULT      = GT
736 cmpAltCon (LitAlt  l1) (LitAlt  l2) = l1 `compare` l2
737 cmpAltCon (LitAlt _)   DEFAULT      = GT
738
739 cmpAltCon con1 con2 = WARN( True, text "Comparing incomparable AltCons" <+> 
740                                   ppr con1 <+> ppr con2 )
741                       LT
742 \end{code}
743
744 %************************************************************************
745 %*                                                                      *
746 \subsection{Useful synonyms}
747 %*                                                                      *
748 %************************************************************************
749
750 \begin{code}
751 -- | The common case for the type of binders and variables when
752 -- we are manipulating the Core language within GHC
753 type CoreBndr = Var
754 -- | Expressions where binders are 'CoreBndr's
755 type CoreExpr = Expr CoreBndr
756 -- | Argument expressions where binders are 'CoreBndr's
757 type CoreArg  = Arg  CoreBndr
758 -- | Binding groups where binders are 'CoreBndr's
759 type CoreBind = Bind CoreBndr
760 -- | Case alternatives where binders are 'CoreBndr's
761 type CoreAlt  = Alt  CoreBndr
762 \end{code}
763
764 %************************************************************************
765 %*                                                                      *
766 \subsection{Tagging}
767 %*                                                                      *
768 %************************************************************************
769
770 \begin{code}
771 -- | Binders are /tagged/ with a t
772 data TaggedBndr t = TB CoreBndr t       -- TB for "tagged binder"
773
774 type TaggedBind t = Bind (TaggedBndr t)
775 type TaggedExpr t = Expr (TaggedBndr t)
776 type TaggedArg  t = Arg  (TaggedBndr t)
777 type TaggedAlt  t = Alt  (TaggedBndr t)
778
779 instance Outputable b => Outputable (TaggedBndr b) where
780   ppr (TB b l) = char '<' <> ppr b <> comma <> ppr l <> char '>'
781
782 instance Outputable b => OutputableBndr (TaggedBndr b) where
783   pprBndr _ b = ppr b   -- Simple
784 \end{code}
785
786
787 %************************************************************************
788 %*                                                                      *
789 \subsection{Core-constructing functions with checking}
790 %*                                                                      *
791 %************************************************************************
792
793 \begin{code}
794 -- | Apply a list of argument expressions to a function expression in a nested fashion. Prefer to
795 -- use 'CoreUtils.mkCoreApps' if possible
796 mkApps    :: Expr b -> [Arg b]  -> Expr b
797 -- | Apply a list of type argument expressions to a function expression in a nested fashion
798 mkTyApps  :: Expr b -> [Type]   -> Expr b
799 -- | Apply a list of type or value variables to a function expression in a nested fashion
800 mkVarApps :: Expr b -> [Var] -> Expr b
801 -- | Apply a list of argument expressions to a data constructor in a nested fashion. Prefer to
802 -- use 'MkCore.mkCoreConApps' if possible
803 mkConApp      :: DataCon -> [Arg b] -> Expr b
804
805 mkApps    f args = foldl App                       f args
806 mkTyApps  f args = foldl (\ e a -> App e (Type a)) f args
807 mkVarApps f vars = foldl (\ e a -> App e (varToCoreExpr a)) f vars
808 mkConApp con args = mkApps (Var (dataConWorkId con)) args
809
810
811 -- | Create a machine integer literal expression of type @Int#@ from an @Integer@.
812 -- If you want an expression of type @Int@ use 'MkCore.mkIntExpr'
813 mkIntLit      :: Integer -> Expr b
814 -- | Create a machine integer literal expression of type @Int#@ from an @Int@.
815 -- If you want an expression of type @Int@ use 'MkCore.mkIntExpr'
816 mkIntLitInt   :: Int     -> Expr b
817
818 mkIntLit    n = Lit (mkMachInt n)
819 mkIntLitInt n = Lit (mkMachInt (toInteger n))
820
821 -- | Create a machine word literal expression of type  @Word#@ from an @Integer@.
822 -- If you want an expression of type @Word@ use 'MkCore.mkWordExpr'
823 mkWordLit     :: Integer -> Expr b
824 -- | Create a machine word literal expression of type  @Word#@ from a @Word@.
825 -- If you want an expression of type @Word@ use 'MkCore.mkWordExpr'
826 mkWordLitWord :: Word -> Expr b
827
828 mkWordLit     w = Lit (mkMachWord w)
829 mkWordLitWord w = Lit (mkMachWord (toInteger w))
830
831 -- | Create a machine character literal expression of type @Char#@.
832 -- If you want an expression of type @Char@ use 'MkCore.mkCharExpr'
833 mkCharLit :: Char -> Expr b
834 -- | Create a machine string literal expression of type @Addr#@.
835 -- If you want an expression of type @String@ use 'MkCore.mkStringExpr'
836 mkStringLit :: String -> Expr b
837
838 mkCharLit   c = Lit (mkMachChar c)
839 mkStringLit s = Lit (mkMachString s)
840
841 -- | Create a machine single precision literal expression of type @Float#@ from a @Rational@.
842 -- If you want an expression of type @Float@ use 'MkCore.mkFloatExpr'
843 mkFloatLit :: Rational -> Expr b
844 -- | Create a machine single precision literal expression of type @Float#@ from a @Float@.
845 -- If you want an expression of type @Float@ use 'MkCore.mkFloatExpr'
846 mkFloatLitFloat :: Float -> Expr b
847
848 mkFloatLit      f = Lit (mkMachFloat f)
849 mkFloatLitFloat f = Lit (mkMachFloat (toRational f))
850
851 -- | Create a machine double precision literal expression of type @Double#@ from a @Rational@.
852 -- If you want an expression of type @Double@ use 'MkCore.mkDoubleExpr'
853 mkDoubleLit :: Rational -> Expr b
854 -- | Create a machine double precision literal expression of type @Double#@ from a @Double@.
855 -- If you want an expression of type @Double@ use 'MkCore.mkDoubleExpr'
856 mkDoubleLitDouble :: Double -> Expr b
857
858 mkDoubleLit       d = Lit (mkMachDouble d)
859 mkDoubleLitDouble d = Lit (mkMachDouble (toRational d))
860
861 -- | Bind all supplied binding groups over an expression in a nested let expression. Prefer to
862 -- use 'CoreUtils.mkCoreLets' if possible
863 mkLets        :: [Bind b] -> Expr b -> Expr b
864 -- | Bind all supplied binders over an expression in a nested lambda expression. Prefer to
865 -- use 'CoreUtils.mkCoreLams' if possible
866 mkLams        :: [b] -> Expr b -> Expr b
867
868 mkLams binders body = foldr Lam body binders
869 mkLets binds body   = foldr Let body binds
870
871
872 -- | Create a binding group where a type variable is bound to a type. Per "CoreSyn#type_let",
873 -- this can only be used to bind something in a non-recursive @let@ expression
874 mkTyBind :: TyVar -> Type -> CoreBind
875 mkTyBind tv ty      = NonRec tv (Type ty)
876
877 -- | Convert a binder into either a 'Var' or 'Type' 'Expr' appropriately
878 varToCoreExpr :: CoreBndr -> Expr b
879 varToCoreExpr v | isId v = Var v
880                 | otherwise = Type (mkTyVarTy v)
881
882 varsToCoreExprs :: [CoreBndr] -> [Expr b]
883 varsToCoreExprs vs = map varToCoreExpr vs
884 \end{code}
885
886
887 %************************************************************************
888 %*                                                                      *
889 \subsection{Simple access functions}
890 %*                                                                      *
891 %************************************************************************
892
893 \begin{code}
894 -- | Extract every variable by this group
895 bindersOf  :: Bind b -> [b]
896 bindersOf (NonRec binder _) = [binder]
897 bindersOf (Rec pairs)       = [binder | (binder, _) <- pairs]
898
899 -- | 'bindersOf' applied to a list of binding groups
900 bindersOfBinds :: [Bind b] -> [b]
901 bindersOfBinds binds = foldr ((++) . bindersOf) [] binds
902
903 rhssOfBind :: Bind b -> [Expr b]
904 rhssOfBind (NonRec _ rhs) = [rhs]
905 rhssOfBind (Rec pairs)    = [rhs | (_,rhs) <- pairs]
906
907 rhssOfAlts :: [Alt b] -> [Expr b]
908 rhssOfAlts alts = [e | (_,_,e) <- alts]
909
910 -- | Collapse all the bindings in the supplied groups into a single
911 -- list of lhs\/rhs pairs suitable for binding in a 'Rec' binding group
912 flattenBinds :: [Bind b] -> [(b, Expr b)]
913 flattenBinds (NonRec b r : binds) = (b,r) : flattenBinds binds
914 flattenBinds (Rec prs1   : binds) = prs1 ++ flattenBinds binds
915 flattenBinds []                   = []
916 \end{code}
917
918 \begin{code}
919 -- | We often want to strip off leading lambdas before getting down to
920 -- business. This function is your friend.
921 collectBinders               :: Expr b -> ([b],         Expr b)
922 -- | Collect as many type bindings as possible from the front of a nested lambda
923 collectTyBinders             :: CoreExpr -> ([TyVar],     CoreExpr)
924 -- | Collect as many value bindings as possible from the front of a nested lambda
925 collectValBinders            :: CoreExpr -> ([Id],        CoreExpr)
926 -- | Collect type binders from the front of the lambda first, 
927 -- then follow up by collecting as many value bindings as possible
928 -- from the resulting stripped expression
929 collectTyAndValBinders       :: CoreExpr -> ([TyVar], [Id], CoreExpr)
930
931 collectBinders expr
932   = go [] expr
933   where
934     go bs (Lam b e) = go (b:bs) e
935     go bs e          = (reverse bs, e)
936
937 collectTyAndValBinders expr
938   = (tvs, ids, body)
939   where
940     (tvs, body1) = collectTyBinders expr
941     (ids, body)  = collectValBinders body1
942
943 collectTyBinders expr
944   = go [] expr
945   where
946     go tvs (Lam b e) | isTyVar b = go (b:tvs) e
947     go tvs e                     = (reverse tvs, e)
948
949 collectValBinders expr
950   = go [] expr
951   where
952     go ids (Lam b e) | isId b = go (b:ids) e
953     go ids body               = (reverse ids, body)
954 \end{code}
955
956 \begin{code}
957 -- | Takes a nested application expression and returns the the function
958 -- being applied and the arguments to which it is applied
959 collectArgs :: Expr b -> (Expr b, [Arg b])
960 collectArgs expr
961   = go expr []
962   where
963     go (App f a) as = go f (a:as)
964     go e         as = (e, as)
965 \end{code}
966
967 \begin{code}
968 -- | Gets the cost centre enclosing an expression, if any.
969 -- It looks inside lambdas because @(scc \"foo\" \\x.e) = \\x. scc \"foo\" e@
970 coreExprCc :: Expr b -> CostCentre
971 coreExprCc (Note (SCC cc) _)   = cc
972 coreExprCc (Note _ e)          = coreExprCc e
973 coreExprCc (Lam _ e)           = coreExprCc e
974 coreExprCc _                   = noCostCentre
975 \end{code}
976
977 %************************************************************************
978 %*                                                                      *
979 \subsection{Predicates}
980 %*                                                                      *
981 %************************************************************************
982
983 At one time we optionally carried type arguments through to runtime.
984 @isRuntimeVar v@ returns if (Lam v _) really becomes a lambda at runtime,
985 i.e. if type applications are actual lambdas because types are kept around
986 at runtime.  Similarly isRuntimeArg.  
987
988 \begin{code}
989 -- | Will this variable exist at runtime?
990 isRuntimeVar :: Var -> Bool
991 isRuntimeVar = isId 
992
993 -- | Will this argument expression exist at runtime?
994 isRuntimeArg :: CoreExpr -> Bool
995 isRuntimeArg = isValArg
996
997 -- | Returns @False@ iff the expression is a 'Type' expression at its top level
998 isValArg :: Expr b -> Bool
999 isValArg (Type _) = False
1000 isValArg _        = True
1001
1002 -- | Returns @True@ iff the expression is a 'Type' expression at its top level
1003 isTypeArg :: Expr b -> Bool
1004 isTypeArg (Type _) = True
1005 isTypeArg _        = False
1006
1007 -- | The number of binders that bind values rather than types
1008 valBndrCount :: [CoreBndr] -> Int
1009 valBndrCount = count isId
1010
1011 -- | The number of argument expressions that are values rather than types at their top level
1012 valArgCount :: [Arg b] -> Int
1013 valArgCount = count isValArg
1014 \end{code}
1015
1016
1017 %************************************************************************
1018 %*                                                                      *
1019 \subsection{Seq stuff}
1020 %*                                                                      *
1021 %************************************************************************
1022
1023 \begin{code}
1024 seqExpr :: CoreExpr -> ()
1025 seqExpr (Var v)         = v `seq` ()
1026 seqExpr (Lit lit)       = lit `seq` ()
1027 seqExpr (App f a)       = seqExpr f `seq` seqExpr a
1028 seqExpr (Lam b e)       = seqBndr b `seq` seqExpr e
1029 seqExpr (Let b e)       = seqBind b `seq` seqExpr e
1030 seqExpr (Case e b t as) = seqExpr e `seq` seqBndr b `seq` seqType t `seq` seqAlts as
1031 seqExpr (Cast e co)     = seqExpr e `seq` seqType co
1032 seqExpr (Note n e)      = seqNote n `seq` seqExpr e
1033 seqExpr (Type t)        = seqType t
1034
1035 seqExprs :: [CoreExpr] -> ()
1036 seqExprs [] = ()
1037 seqExprs (e:es) = seqExpr e `seq` seqExprs es
1038
1039 seqNote :: Note -> ()
1040 seqNote (CoreNote s)   = s `seq` ()
1041 seqNote _              = ()
1042
1043 seqBndr :: CoreBndr -> ()
1044 seqBndr b = b `seq` ()
1045
1046 seqBndrs :: [CoreBndr] -> ()
1047 seqBndrs [] = ()
1048 seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
1049
1050 seqBind :: Bind CoreBndr -> ()
1051 seqBind (NonRec b e) = seqBndr b `seq` seqExpr e
1052 seqBind (Rec prs)    = seqPairs prs
1053
1054 seqPairs :: [(CoreBndr, CoreExpr)] -> ()
1055 seqPairs [] = ()
1056 seqPairs ((b,e):prs) = seqBndr b `seq` seqExpr e `seq` seqPairs prs
1057
1058 seqAlts :: [CoreAlt] -> ()
1059 seqAlts [] = ()
1060 seqAlts ((c,bs,e):alts) = c `seq` seqBndrs bs `seq` seqExpr e `seq` seqAlts alts
1061
1062 seqRules :: [CoreRule] -> ()
1063 seqRules [] = ()
1064 seqRules (Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs } : rules) 
1065   = seqBndrs bndrs `seq` seqExprs (rhs:args) `seq` seqRules rules
1066 seqRules (BuiltinRule {} : rules) = seqRules rules
1067 \end{code}
1068
1069 %************************************************************************
1070 %*                                                                      *
1071 \subsection{Annotated core}
1072 %*                                                                      *
1073 %************************************************************************
1074
1075 \begin{code}
1076 -- | Annotated core: allows annotation at every node in the tree
1077 type AnnExpr bndr annot = (annot, AnnExpr' bndr annot)
1078
1079 -- | A clone of the 'Expr' type but allowing annotation at every tree node
1080 data AnnExpr' bndr annot
1081   = AnnVar      Id
1082   | AnnLit      Literal
1083   | AnnLam      bndr (AnnExpr bndr annot)
1084   | AnnApp      (AnnExpr bndr annot) (AnnExpr bndr annot)
1085   | AnnCase     (AnnExpr bndr annot) bndr Type [AnnAlt bndr annot]
1086   | AnnLet      (AnnBind bndr annot) (AnnExpr bndr annot)
1087   | AnnCast     (AnnExpr bndr annot) Coercion
1088   | AnnNote     Note (AnnExpr bndr annot)
1089   | AnnType     Type
1090
1091 -- | A clone of the 'Alt' type but allowing annotation at every tree node
1092 type AnnAlt bndr annot = (AltCon, [bndr], AnnExpr bndr annot)
1093
1094 -- | A clone of the 'Bind' type but allowing annotation at every tree node
1095 data AnnBind bndr annot
1096   = AnnNonRec bndr (AnnExpr bndr annot)
1097   | AnnRec    [(bndr, AnnExpr bndr annot)]
1098 \end{code}
1099
1100 \begin{code}
1101 deAnnotate :: AnnExpr bndr annot -> Expr bndr
1102 deAnnotate (_, e) = deAnnotate' e
1103
1104 deAnnotate' :: AnnExpr' bndr annot -> Expr bndr
1105 deAnnotate' (AnnType t)           = Type t
1106 deAnnotate' (AnnVar  v)           = Var v
1107 deAnnotate' (AnnLit  lit)         = Lit lit
1108 deAnnotate' (AnnLam  binder body) = Lam binder (deAnnotate body)
1109 deAnnotate' (AnnApp  fun arg)     = App (deAnnotate fun) (deAnnotate arg)
1110 deAnnotate' (AnnCast e co)        = Cast (deAnnotate e) co
1111 deAnnotate' (AnnNote note body)   = Note note (deAnnotate body)
1112
1113 deAnnotate' (AnnLet bind body)
1114   = Let (deAnnBind bind) (deAnnotate body)
1115   where
1116     deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs)
1117     deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs]
1118
1119 deAnnotate' (AnnCase scrut v t alts)
1120   = Case (deAnnotate scrut) v t (map deAnnAlt alts)
1121
1122 deAnnAlt :: AnnAlt bndr annot -> Alt bndr
1123 deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs)
1124 \end{code}
1125
1126 \begin{code}
1127 -- | As 'collectBinders' but for 'AnnExpr' rather than 'Expr'
1128 collectAnnBndrs :: AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot)
1129 collectAnnBndrs e
1130   = collect [] e
1131   where
1132     collect bs (_, AnnLam b body) = collect (b:bs) body
1133     collect bs body               = (reverse bs, body)
1134 \end{code}