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