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