Two signficant changes to the simplifier
[ghc.git] / compiler / basicTypes / BasicTypes.lhs
1 %
2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1997-1998
4 %
5 \section[BasicTypes]{Miscellanous types}
6
7 This module defines a miscellaneously collection of very simple
8 types that
9
10 \begin{itemize}
11 \item have no other obvious home
12 \item don't depend on any other complicated types
13 \item are used in more than one "part" of the compiler
14 \end{itemize}
15
16 \begin{code}
17 {-# LANGUAGE DeriveDataTypeable #-}
18
19 module BasicTypes(
20         Version, bumpVersion, initialVersion,
21
22         Arity, 
23
24         FunctionOrData(..),
25         
26         WarningTxt(..),
27
28         Fixity(..), FixityDirection(..),
29         defaultFixity, maxPrecedence, 
30         negateFixity, funTyFixity,
31         compareFixity,
32
33         IPName(..), ipNameName, mapIPName,
34
35         RecFlag(..), isRec, isNonRec, boolToRecFlag,
36
37         RuleName,
38
39         TopLevelFlag(..), isTopLevel, isNotTopLevel,
40
41         OverlapFlag(..), 
42
43         Boxity(..), isBoxed, 
44
45         TupCon(..), tupleParens,
46
47         OccInfo(..), seqOccInfo, zapFragileOcc, isOneOcc, 
48         isDeadOcc, isLoopBreaker, isNonRuleLoopBreaker, isNoOcc,
49         nonRuleLoopBreaker,
50
51         InsideLam, insideLam, notInsideLam,
52         OneBranch, oneBranch, notOneBranch,
53         InterestingCxt,
54
55         EP(..),
56
57         HsBang(..), isBanged, isMarkedUnboxed, 
58         StrictnessMark(..), isMarkedStrict,
59
60         DefMethSpec(..),
61
62         CompilerPhase, 
63         Activation(..), isActive, isNeverActive, isAlwaysActive, isEarlyActive,
64         RuleMatchInfo(..), isConLike, isFunLike, 
65         InlineSpec(..), 
66         InlinePragma(..), defaultInlinePragma, alwaysInlinePragma, 
67         neverInlinePragma, dfunInlinePragma, 
68         isDefaultInlinePragma, 
69         isInlinePragma, isInlinablePragma, isAnyInlinePragma,
70         inlinePragmaSpec, inlinePragmaSat,
71         inlinePragmaActivation, inlinePragmaRuleMatchInfo,
72         setInlinePragmaActivation, setInlinePragmaRuleMatchInfo,
73
74         SuccessFlag(..), succeeded, failed, successIf
75    ) where
76
77 import FastString
78 import Outputable
79
80 import Data.Data hiding (Fixity)
81 \end{code}
82
83 %************************************************************************
84 %*                                                                      *
85 \subsection[Arity]{Arity}
86 %*                                                                      *
87 %************************************************************************
88
89 \begin{code}
90 type Arity = Int
91 \end{code}
92
93 %************************************************************************
94 %*                                                                      *
95 \subsection[FunctionOrData]{FunctionOrData}
96 %*                                                                      *
97 %************************************************************************
98
99 \begin{code}
100 data FunctionOrData = IsFunction | IsData
101     deriving (Eq, Ord, Data, Typeable)
102
103 instance Outputable FunctionOrData where
104     ppr IsFunction = text "(function)"
105     ppr IsData     = text "(data)"
106 \end{code}
107
108
109 %************************************************************************
110 %*                                                                      *
111 \subsection[Version]{Module and identifier version numbers}
112 %*                                                                      *
113 %************************************************************************
114
115 \begin{code}
116 type Version = Int
117
118 bumpVersion :: Version -> Version 
119 bumpVersion v = v+1
120
121 initialVersion :: Version
122 initialVersion = 1
123 \end{code}
124
125 %************************************************************************
126 %*                                                                      *
127                 Deprecations
128 %*                                                                      *
129 %************************************************************************
130
131
132 \begin{code}
133 -- reason/explanation from a WARNING or DEPRECATED pragma
134 data WarningTxt = WarningTxt [FastString]
135                 | DeprecatedTxt [FastString]
136     deriving (Eq, Data, Typeable)
137
138 instance Outputable WarningTxt where
139     ppr (WarningTxt    ws) = doubleQuotes (vcat (map ftext ws))
140     ppr (DeprecatedTxt ds) = text "Deprecated:" <+>
141                              doubleQuotes (vcat (map ftext ds))
142 \end{code}
143
144 %************************************************************************
145 %*                                                                      *
146 \subsection{Implicit parameter identity}
147 %*                                                                      *
148 %************************************************************************
149
150 The @IPName@ type is here because it is used in TypeRep (i.e. very
151 early in the hierarchy), but also in HsSyn.
152
153 \begin{code}
154 newtype IPName name = IPName name       -- ?x
155   deriving( Eq, Ord, Data, Typeable )
156   -- Ord is used in the IP name cache finite map
157   -- (used in HscTypes.OrigIParamCache)
158
159 ipNameName :: IPName name -> name
160 ipNameName (IPName n) = n
161
162 mapIPName :: (a->b) -> IPName a -> IPName b
163 mapIPName f (IPName n) = IPName (f n)
164
165 instance Outputable name => Outputable (IPName name) where
166     ppr (IPName n) = char '?' <> ppr n -- Ordinary implicit parameters
167 \end{code}
168
169 %************************************************************************
170 %*                                                                      *
171                 Rules
172 %*                                                                      *
173 %************************************************************************
174
175 \begin{code}
176 type RuleName = FastString
177 \end{code}
178
179 %************************************************************************
180 %*                                                                      *
181 \subsection[Fixity]{Fixity info}
182 %*                                                                      *
183 %************************************************************************
184
185 \begin{code}
186 ------------------------
187 data Fixity = Fixity Int FixityDirection
188   deriving (Data, Typeable)
189
190 instance Outputable Fixity where
191     ppr (Fixity prec dir) = hcat [ppr dir, space, int prec]
192
193 instance Eq Fixity where                -- Used to determine if two fixities conflict
194   (Fixity p1 dir1) == (Fixity p2 dir2) = p1==p2 && dir1 == dir2
195
196 ------------------------
197 data FixityDirection = InfixL | InfixR | InfixN 
198                      deriving (Eq, Data, Typeable)
199
200 instance Outputable FixityDirection where
201     ppr InfixL = ptext (sLit "infixl")
202     ppr InfixR = ptext (sLit "infixr")
203     ppr InfixN = ptext (sLit "infix")
204
205 ------------------------
206 maxPrecedence :: Int
207 maxPrecedence = 9
208 defaultFixity :: Fixity
209 defaultFixity = Fixity maxPrecedence InfixL
210
211 negateFixity, funTyFixity :: Fixity
212 -- Wired-in fixities
213 negateFixity = Fixity 6 InfixL  -- Fixity of unary negate
214 funTyFixity  = Fixity 0 InfixR  -- Fixity of '->'
215 \end{code}
216
217 Consider
218
219 \begin{verbatim}
220         a `op1` b `op2` c
221 \end{verbatim}
222 @(compareFixity op1 op2)@ tells which way to arrange appication, or
223 whether there's an error.
224
225 \begin{code}
226 compareFixity :: Fixity -> Fixity
227               -> (Bool,         -- Error please
228                   Bool)         -- Associate to the right: a op1 (b op2 c)
229 compareFixity (Fixity prec1 dir1) (Fixity prec2 dir2)
230   = case prec1 `compare` prec2 of
231         GT -> left
232         LT -> right
233         EQ -> case (dir1, dir2) of
234                         (InfixR, InfixR) -> right
235                         (InfixL, InfixL) -> left
236                         _                -> error_please
237   where
238     right        = (False, True)
239     left         = (False, False)
240     error_please = (True,  False)
241 \end{code}
242
243
244 %************************************************************************
245 %*                                                                      *
246 \subsection[Top-level/local]{Top-level/not-top level flag}
247 %*                                                                      *
248 %************************************************************************
249
250 \begin{code}
251 data TopLevelFlag
252   = TopLevel
253   | NotTopLevel
254
255 isTopLevel, isNotTopLevel :: TopLevelFlag -> Bool
256
257 isNotTopLevel NotTopLevel = True
258 isNotTopLevel TopLevel    = False
259
260 isTopLevel TopLevel     = True
261 isTopLevel NotTopLevel  = False
262
263 instance Outputable TopLevelFlag where
264   ppr TopLevel    = ptext (sLit "<TopLevel>")
265   ppr NotTopLevel = ptext (sLit "<NotTopLevel>")
266 \end{code}
267
268
269 %************************************************************************
270 %*                                                                      *
271                 Top-level/not-top level flag
272 %*                                                                      *
273 %************************************************************************
274
275 \begin{code}
276 data Boxity
277   = Boxed
278   | Unboxed
279   deriving( Eq, Data, Typeable )
280
281 isBoxed :: Boxity -> Bool
282 isBoxed Boxed   = True
283 isBoxed Unboxed = False
284 \end{code}
285
286
287 %************************************************************************
288 %*                                                                      *
289                 Recursive/Non-Recursive flag
290 %*                                                                      *
291 %************************************************************************
292
293 \begin{code}
294 data RecFlag = Recursive 
295              | NonRecursive
296              deriving( Eq, Data, Typeable )
297
298 isRec :: RecFlag -> Bool
299 isRec Recursive    = True
300 isRec NonRecursive = False
301
302 isNonRec :: RecFlag -> Bool
303 isNonRec Recursive    = False
304 isNonRec NonRecursive = True
305
306 boolToRecFlag :: Bool -> RecFlag
307 boolToRecFlag True  = Recursive
308 boolToRecFlag False = NonRecursive
309
310 instance Outputable RecFlag where
311   ppr Recursive    = ptext (sLit "Recursive")
312   ppr NonRecursive = ptext (sLit "NonRecursive")
313 \end{code}
314
315 %************************************************************************
316 %*                                                                      *
317                 Instance overlap flag
318 %*                                                                      *
319 %************************************************************************
320
321 \begin{code}
322 data OverlapFlag
323   = NoOverlap   -- This instance must not overlap another
324
325   | OverlapOk   -- Silently ignore this instance if you find a 
326                 -- more specific one that matches the constraint
327                 -- you are trying to resolve
328                 --
329                 -- Example: constraint (Foo [Int])
330                 --          instances  (Foo [Int])
331         
332                 --                     (Foo [a])        OverlapOk
333                 -- Since the second instance has the OverlapOk flag,
334                 -- the first instance will be chosen (otherwise 
335                 -- its ambiguous which to choose)
336
337   | Incoherent  -- Like OverlapOk, but also ignore this instance 
338                 -- if it doesn't match the constraint you are
339                 -- trying to resolve, but could match if the type variables
340                 -- in the constraint were instantiated
341                 --
342                 -- Example: constraint (Foo [b])
343                 --          instances  (Foo [Int])      Incoherent
344                 --                     (Foo [a])
345                 -- Without the Incoherent flag, we'd complain that
346                 -- instantiating 'b' would change which instance 
347                 -- was chosen
348   deriving( Eq )
349
350 instance Outputable OverlapFlag where
351    ppr NoOverlap  = empty
352    ppr OverlapOk  = ptext (sLit "[overlap ok]")
353    ppr Incoherent = ptext (sLit "[incoherent]")
354
355 \end{code}
356
357 %************************************************************************
358 %*                                                                      *
359                 Tuples
360 %*                                                                      *
361 %************************************************************************
362
363 \begin{code}
364 data TupCon = TupCon Boxity Arity
365
366 instance Eq TupCon where
367   (TupCon b1 a1) == (TupCon b2 a2) = b1==b2 && a1==a2
368    
369 tupleParens :: Boxity -> SDoc -> SDoc
370 tupleParens Boxed   p = parens p
371 tupleParens Unboxed p = ptext (sLit "(#") <+> p <+> ptext (sLit "#)")
372 \end{code}
373
374 %************************************************************************
375 %*                                                                      *
376 \subsection[Generic]{Generic flag}
377 %*                                                                      *
378 %************************************************************************
379
380 This is the "Embedding-Projection pair" datatype, it contains 
381 two pieces of code (normally either RenamedExpr's or Id's)
382 If we have a such a pair (EP from to), the idea is that 'from' and 'to'
383 represents functions of type 
384
385         from :: T -> Tring
386         to   :: Tring -> T
387
388 And we should have 
389
390         to (from x) = x
391
392 T and Tring are arbitrary, but typically T is the 'main' type while
393 Tring is the 'representation' type.  (This just helps us remember 
394 whether to use 'from' or 'to'.
395
396 \begin{code}
397 data EP a = EP { fromEP :: a,   -- :: T -> Tring
398                  toEP   :: a }  -- :: Tring -> T
399 \end{code}
400
401 Embedding-projection pairs are used in several places:
402
403 First of all, each type constructor has an EP associated with it, the
404 code in EP converts (datatype T) from T to Tring and back again.
405
406 Secondly, when we are filling in Generic methods (in the typechecker, 
407 tcMethodBinds), we are constructing bimaps by induction on the structure
408 of the type of the method signature.
409
410
411 %************************************************************************
412 %*                                                                      *
413 \subsection{Occurrence information}
414 %*                                                                      *
415 %************************************************************************
416
417 This data type is used exclusively by the simplifier, but it appears in a
418 SubstResult, which is currently defined in VarEnv, which is pretty near
419 the base of the module hierarchy.  So it seemed simpler to put the
420 defn of OccInfo here, safely at the bottom
421
422 \begin{code}
423 -- | Identifier occurrence information
424 data OccInfo 
425   = NoOccInfo           -- ^ There are many occurrences, or unknown occurences
426
427   | IAmDead             -- ^ Marks unused variables.  Sometimes useful for
428                         -- lambda and case-bound variables.
429
430   | OneOcc
431         !InsideLam
432         !OneBranch
433         !InterestingCxt -- ^ Occurs exactly once, not inside a rule
434
435   -- | This identifier breaks a loop of mutually recursive functions. The field
436   -- marks whether it is only a loop breaker due to a reference in a rule
437   | IAmALoopBreaker     -- Note [LoopBreaker OccInfo]
438         !RulesOnly      -- True <=> This is a weak or rules-only loop breaker
439                         --          See OccurAnal Note [Weak loop breakers]
440
441 type RulesOnly = Bool
442 \end{code}
443
444 Note [LoopBreaker OccInfo]
445 ~~~~~~~~~~~~~~~~~~~~~~~~~~
446 An OccInfo of (IAmLoopBreaker False) is used by the occurrence 
447 analyser in two ways:
448   (a) to mark loop-breakers in a group of recursive 
449       definitions (hence the name)
450   (b) to mark binders that must not be inlined in this phase
451       (perhaps it has a NOINLINE pragma)
452 Things with (IAmLoopBreaker False) do not get an unfolding 
453 pinned on to them, so they are completely opaque.
454
455 See OccurAnal Note [Weak loop breakers] for (IAmLoopBreaker True).
456
457
458 \begin{code}
459 isNoOcc :: OccInfo -> Bool
460 isNoOcc NoOccInfo = True
461 isNoOcc _         = False
462
463 seqOccInfo :: OccInfo -> ()
464 seqOccInfo occ = occ `seq` ()
465
466 -----------------
467 type InterestingCxt = Bool      -- True <=> Function: is applied
468                                 --          Data value: scrutinised by a case with
469                                 --                      at least one non-DEFAULT branch
470
471 -----------------
472 type InsideLam = Bool   -- True <=> Occurs inside a non-linear lambda
473                         -- Substituting a redex for this occurrence is
474                         -- dangerous because it might duplicate work.
475 insideLam, notInsideLam :: InsideLam
476 insideLam    = True
477 notInsideLam = False
478
479 -----------------
480 type OneBranch = Bool   -- True <=> Occurs in only one case branch
481                         --      so no code-duplication issue to worry about
482 oneBranch, notOneBranch :: OneBranch
483 oneBranch    = True
484 notOneBranch = False
485
486 isLoopBreaker :: OccInfo -> Bool
487 isLoopBreaker (IAmALoopBreaker _) = True
488 isLoopBreaker _                   = False
489
490 isNonRuleLoopBreaker :: OccInfo -> Bool
491 isNonRuleLoopBreaker (IAmALoopBreaker False) = True   -- Loop-breaker that breaks a non-rule cycle
492 isNonRuleLoopBreaker _                       = False
493
494 nonRuleLoopBreaker :: OccInfo
495 nonRuleLoopBreaker = IAmALoopBreaker False
496
497 isDeadOcc :: OccInfo -> Bool
498 isDeadOcc IAmDead = True
499 isDeadOcc _       = False
500
501 isOneOcc :: OccInfo -> Bool
502 isOneOcc (OneOcc {}) = True
503 isOneOcc _           = False
504
505 zapFragileOcc :: OccInfo -> OccInfo
506 zapFragileOcc (OneOcc {}) = NoOccInfo
507 zapFragileOcc occ         = occ
508 \end{code}
509
510 \begin{code}
511 instance Outputable OccInfo where
512   -- only used for debugging; never parsed.  KSW 1999-07
513   ppr NoOccInfo            = empty
514   ppr (IAmALoopBreaker ro) = ptext (sLit "LoopBreaker") <> if ro then char '!' else empty
515   ppr IAmDead              = ptext (sLit "Dead")
516   ppr (OneOcc inside_lam one_branch int_cxt)
517         = ptext (sLit "Once") <> pp_lam <> pp_br <> pp_args
518         where
519           pp_lam | inside_lam = char 'L'
520                  | otherwise  = empty
521           pp_br  | one_branch = empty
522                  | otherwise  = char '*'
523           pp_args | int_cxt   = char '!'
524                   | otherwise = empty
525
526 instance Show OccInfo where
527   showsPrec p occ = showsPrecSDoc p (ppr occ)
528 \end{code}
529
530 %************************************************************************
531 %*                                                                      *
532                 Strictness indication
533 %*                                                                      *
534 %************************************************************************
535
536 The strictness annotations on types in data type declarations
537 e.g.    data T = MkT !Int !(Bool,Bool)
538
539 \begin{code}
540 -------------------------
541 -- HsBang describes what the *programmer* wrote
542 -- This info is retained in the DataCon.dcStrictMarks field
543 data HsBang = HsNoBang  
544
545             | HsStrict  
546
547             | HsUnpack         -- {-# UNPACK #-} ! (GHC extension, meaning "unbox")
548
549             | HsUnpackFailed   -- An UNPACK pragma that we could not make 
550                                -- use of, because the type isn't unboxable; 
551                                -- equivalant to HsStrict except for checkValidDataCon
552   deriving (Eq, Data, Typeable)
553
554 instance Outputable HsBang where
555     ppr HsNoBang       = empty
556     ppr HsStrict       = char '!'
557     ppr HsUnpack       = ptext (sLit "{-# UNPACK #-} !")
558     ppr HsUnpackFailed = ptext (sLit "{-# UNPACK (failed) #-} !")
559
560 isBanged :: HsBang -> Bool
561 isBanged HsNoBang = False
562 isBanged _        = True
563
564 isMarkedUnboxed :: HsBang -> Bool
565 isMarkedUnboxed HsUnpack = True
566 isMarkedUnboxed _        = False
567
568 -------------------------
569 -- StrictnessMark is internal only, used to indicate strictness 
570 -- of the DataCon *worker* fields
571 data StrictnessMark = MarkedStrict | NotMarkedStrict    
572
573 instance Outputable StrictnessMark where
574   ppr MarkedStrict     = ptext (sLit "!")
575   ppr NotMarkedStrict  = empty
576
577 isMarkedStrict :: StrictnessMark -> Bool
578 isMarkedStrict NotMarkedStrict = False
579 isMarkedStrict _               = True   -- All others are strict
580 \end{code}
581
582
583 %************************************************************************
584 %*                                                                      *
585                 Default method specfication
586 %*                                                                      *
587 %************************************************************************
588
589 The DefMethSpec enumeration just indicates what sort of default method
590 is used for a class. It is generated from source code, and present in 
591 interface files; it is converted to Class.DefMeth before begin put in a 
592 Class object.
593
594 \begin{code}
595 data DefMethSpec = NoDM        -- No default method
596                  | VanillaDM   -- Default method given with polymorphic code
597                  | GenericDM   -- Default method given with generic code
598
599 instance Outputable DefMethSpec where
600   ppr NoDM      = empty
601   ppr VanillaDM = ptext (sLit "{- Has default method -}")
602   ppr GenericDM = ptext (sLit "{- Has generic default method -}")
603 \end{code}
604
605 %************************************************************************
606 %*                                                                      *
607 \subsection{Success flag}
608 %*                                                                      *
609 %************************************************************************
610
611 \begin{code}
612 data SuccessFlag = Succeeded | Failed
613
614 instance Outputable SuccessFlag where
615     ppr Succeeded = ptext (sLit "Succeeded")
616     ppr Failed    = ptext (sLit "Failed")
617
618 successIf :: Bool -> SuccessFlag
619 successIf True  = Succeeded
620 successIf False = Failed
621
622 succeeded, failed :: SuccessFlag -> Bool
623 succeeded Succeeded = True
624 succeeded Failed    = False
625
626 failed Succeeded = False
627 failed Failed    = True
628 \end{code}
629
630
631 %************************************************************************
632 %*                                                                      *
633 \subsection{Activation}
634 %*                                                                      *
635 %************************************************************************
636
637 When a rule or inlining is active
638
639 \begin{code}
640 type CompilerPhase = Int        -- Compilation phase
641                                 -- Phases decrease towards zero
642                                 -- Zero is the last phase
643
644 data Activation = NeverActive
645                 | AlwaysActive
646                 | ActiveBefore CompilerPhase    -- Active only *before* this phase
647                 | ActiveAfter CompilerPhase     -- Active in this phase and later
648                 deriving( Eq, Data, Typeable )  -- Eq used in comparing rules in HsDecls
649
650 data RuleMatchInfo = ConLike                    -- See Note [CONLIKE pragma]
651                    | FunLike
652                    deriving( Eq, Data, Typeable, Show )
653         -- Show needed for Lexer.x
654
655 data InlinePragma            -- Note [InlinePragma]
656   = InlinePragma
657       { inl_inline :: InlineSpec
658
659       , inl_sat    :: Maybe Arity    -- Just n <=> Inline only when applied to n 
660                                      --            explicit (non-type, non-dictionary) args
661                                      --   That is, inl_sat describes the number of *source-code*
662                                      --   arguments the thing must be applied to.  We add on the 
663                                      --   number of implicit, dictionary arguments when making
664                                      --   the InlineRule, and don't look at inl_sat further
665
666       , inl_act    :: Activation     -- Says during which phases inlining is allowed
667
668       , inl_rule   :: RuleMatchInfo  -- Should the function be treated like a constructor?
669     } deriving( Eq, Data, Typeable )
670
671 data InlineSpec   -- What the user's INLINE pragama looked like
672   = Inline
673   | Inlinable
674   | NoInline
675   | EmptyInlineSpec
676   deriving( Eq, Data, Typeable, Show )
677         -- Show needed for Lexer.x
678 \end{code}
679
680 Note [InlinePragma]
681 ~~~~~~~~~~~~~~~~~~~
682 This data type mirrors what you can write in an INLINE or NOINLINE pragma in 
683 the source program.
684
685 If you write nothing at all, you get defaultInlinePragma:
686    inl_inline = False
687    inl_act    = AlwaysActive
688    inl_rule   = FunLike
689
690 It's not possible to get that combination by *writing* something, so 
691 if an Id has defaultInlinePragma it means the user didn't specify anything.
692
693 If inl_inline = True, then the Id should have an InlineRule unfolding.
694
695 Note [CONLIKE pragma]
696 ~~~~~~~~~~~~~~~~~~~~~
697 The ConLike constructor of a RuleMatchInfo is aimed at the following.
698 Consider first
699     {-# RULE "r/cons" forall a as. r (a:as) = f (a+1) #-}
700     g b bs = let x = b:bs in ..x...x...(r x)...
701 Now, the rule applies to the (r x) term, because GHC "looks through" 
702 the definition of 'x' to see that it is (b:bs).
703
704 Now consider
705     {-# RULE "r/f" forall v. r (f v) = f (v+1) #-}
706     g v = let x = f v in ..x...x...(r x)...
707 Normally the (r x) would *not* match the rule, because GHC would be
708 scared about duplicating the redex (f v), so it does not "look
709 through" the bindings.  
710
711 However the CONLIKE modifier says to treat 'f' like a constructor in
712 this situation, and "look through" the unfolding for x.  So (r x)
713 fires, yielding (f (v+1)).
714
715 This is all controlled with a user-visible pragma:
716      {-# NOINLINE CONLIKE [1] f #-}
717
718 The main effects of CONLIKE are:
719
720     - The occurrence analyser (OccAnal) and simplifier (Simplify) treat
721       CONLIKE thing like constructors, by ANF-ing them
722
723     - New function coreUtils.exprIsExpandable is like exprIsCheap, but
724       additionally spots applications of CONLIKE functions
725
726     - A CoreUnfolding has a field that caches exprIsExpandable
727
728     - The rule matcher consults this field.  See
729       Note [Expanding variables] in Rules.lhs.
730
731 \begin{code}
732 isConLike :: RuleMatchInfo -> Bool
733 isConLike ConLike = True
734 isConLike _            = False
735
736 isFunLike :: RuleMatchInfo -> Bool
737 isFunLike FunLike = True
738 isFunLike _            = False
739
740 isEmptyInlineSpec :: InlineSpec -> Bool
741 isEmptyInlineSpec EmptyInlineSpec = True
742 isEmptyInlineSpec _               = False
743
744 defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma
745   :: InlinePragma
746 defaultInlinePragma = InlinePragma { inl_act = AlwaysActive
747                                    , inl_rule = FunLike
748                                    , inl_inline = EmptyInlineSpec
749                                    , inl_sat = Nothing }
750
751 alwaysInlinePragma = defaultInlinePragma { inl_inline = Inline }
752 neverInlinePragma  = defaultInlinePragma { inl_act    = NeverActive }
753
754 inlinePragmaSpec :: InlinePragma -> InlineSpec
755 inlinePragmaSpec = inl_inline
756
757 -- A DFun has an always-active inline activation so that 
758 -- exprIsConApp_maybe can "see" its unfolding
759 -- (However, its actual Unfolding is a DFunUnfolding, which is
760 --  never inlined other than via exprIsConApp_maybe.)
761 dfunInlinePragma   = defaultInlinePragma { inl_act  = AlwaysActive
762                                          , inl_rule = ConLike }
763
764 isDefaultInlinePragma :: InlinePragma -> Bool
765 isDefaultInlinePragma (InlinePragma { inl_act = activation
766                                     , inl_rule = match_info
767                                     , inl_inline = inline })
768   = isEmptyInlineSpec inline && isAlwaysActive activation && isFunLike match_info
769
770 isInlinePragma :: InlinePragma -> Bool
771 isInlinePragma prag = case inl_inline prag of
772                         Inline -> True
773                         _      -> False
774
775 isInlinablePragma :: InlinePragma -> Bool
776 isInlinablePragma prag = case inl_inline prag of
777                            Inlinable -> True
778                            _         -> False
779
780 isAnyInlinePragma :: InlinePragma -> Bool
781 -- INLINE or INLINABLE
782 isAnyInlinePragma prag = case inl_inline prag of
783                         Inline    -> True
784                         Inlinable -> True
785                         _         -> False
786  
787 inlinePragmaSat :: InlinePragma -> Maybe Arity
788 inlinePragmaSat = inl_sat
789
790 inlinePragmaActivation :: InlinePragma -> Activation
791 inlinePragmaActivation (InlinePragma { inl_act = activation }) = activation
792
793 inlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo
794 inlinePragmaRuleMatchInfo (InlinePragma { inl_rule = info }) = info
795
796 setInlinePragmaActivation :: InlinePragma -> Activation -> InlinePragma
797 setInlinePragmaActivation prag activation = prag { inl_act = activation }
798
799 setInlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo -> InlinePragma
800 setInlinePragmaRuleMatchInfo prag info = prag { inl_rule = info }
801
802 instance Outputable Activation where
803    ppr AlwaysActive     = brackets (ptext (sLit "ALWAYS"))
804    ppr NeverActive      = brackets (ptext (sLit "NEVER"))
805    ppr (ActiveBefore n) = brackets (char '~' <> int n)
806    ppr (ActiveAfter n)  = brackets (int n)
807
808 instance Outputable RuleMatchInfo where
809    ppr ConLike = ptext (sLit "CONLIKE")
810    ppr FunLike = ptext (sLit "FUNLIKE")
811
812 instance Outputable InlineSpec where
813    ppr Inline          = ptext (sLit "INLINE")
814    ppr NoInline        = ptext (sLit "NOINLINE")
815    ppr Inlinable       = ptext (sLit "INLINABLE")
816    ppr EmptyInlineSpec = empty
817
818 instance Outputable InlinePragma where
819   ppr (InlinePragma { inl_inline = inline, inl_act = activation
820                     , inl_rule = info, inl_sat = mb_arity })
821     = ppr inline <> pp_act inline activation <+> pp_sat <+> pp_info 
822     where
823       pp_act Inline   AlwaysActive = empty      
824       pp_act NoInline NeverActive  = empty
825       pp_act _        act          = ppr act
826
827       pp_sat | Just ar <- mb_arity = parens (ptext (sLit "sat-args=") <> int ar)
828              | otherwise           = empty
829       pp_info | isFunLike info = empty
830               | otherwise      = ppr info
831
832 isActive :: CompilerPhase -> Activation -> Bool
833 isActive _ NeverActive      = False
834 isActive _ AlwaysActive     = True
835 isActive p (ActiveAfter n)  = p <= n
836 isActive p (ActiveBefore n) = p >  n
837
838 isNeverActive, isAlwaysActive, isEarlyActive :: Activation -> Bool
839 isNeverActive NeverActive = True
840 isNeverActive _           = False
841
842 isAlwaysActive AlwaysActive = True
843 isAlwaysActive _            = False
844
845 isEarlyActive AlwaysActive      = True
846 isEarlyActive (ActiveBefore {}) = True
847 isEarlyActive _                 = False
848 \end{code}
849