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