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