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