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