Add selectors for common fields (DataCon/PatSyn) to ConLike
[ghc.git] / compiler / basicTypes / BasicTypes.hs
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
17 {-# LANGUAGE DeriveDataTypeable #-}
18
19 module BasicTypes(
20 Version, bumpVersion, initialVersion,
21
22 ConTag, fIRST_TAG,
23
24 Arity, RepArity,
25
26 Alignment,
27
28 FunctionOrData(..),
29
30 WarningTxt(..), StringLiteral(..),
31
32 Fixity(..), FixityDirection(..),
33 defaultFixity, maxPrecedence, minPrecedence,
34 negateFixity, funTyFixity,
35 compareFixity,
36
37 RecFlag(..), isRec, isNonRec, boolToRecFlag,
38 Origin(..), isGenerated,
39
40 RuleName, pprRuleName,
41
42 TopLevelFlag(..), isTopLevel, isNotTopLevel,
43
44 OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe,
45 hasOverlappingFlag, hasOverlappableFlag,
46
47 Boxity(..), isBoxed,
48
49 TupleSort(..), tupleSortBoxity, boxityTupleSort,
50 tupleParens,
51
52 -- ** The OneShotInfo type
53 OneShotInfo(..),
54 noOneShotInfo, hasNoOneShotInfo, isOneShotInfo,
55 bestOneShot, worstOneShot,
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 DefMethSpec(..),
68 SwapFlag(..), flipSwap, unSwap, isSwapped,
69
70 CompilerPhase(..), PhaseNum,
71
72 Activation(..), isActive, isActiveIn, competesWith,
73 isNeverActive, isAlwaysActive, isEarlyActive,
74
75 RuleMatchInfo(..), isConLike, isFunLike,
76 InlineSpec(..), isEmptyInlineSpec,
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
89 HValue(..),
90
91 SourceText,
92
93 IntWithInf, infinity, treatZeroAsInf, mkIntWithInf, intGtLimit
94 ) where
95
96 import FastString
97 import Outputable
98 import SrcLoc ( Located,unLoc )
99 import StaticFlags( opt_PprStyle_Debug )
100 import Data.Data hiding (Fixity)
101 import Data.Function (on)
102 import GHC.Exts (Any)
103
104 {-
105 ************************************************************************
106 * *
107 \subsection[Arity]{Arity}
108 * *
109 ************************************************************************
110 -}
111
112 -- | The number of value arguments that can be applied to a value before it does
113 -- "real work". So:
114 -- fib 100 has arity 0
115 -- \x -> fib x has arity 1
116 type Arity = Int
117
118 -- | The number of represented arguments that can be applied to a value before it does
119 -- "real work". So:
120 -- fib 100 has representation arity 0
121 -- \x -> fib x has representation arity 1
122 -- \(# x, y #) -> fib (x + y) has representation arity 2
123 type RepArity = Int
124
125 {-
126 ************************************************************************
127 * *
128 Constructor tags
129 * *
130 ************************************************************************
131 -}
132
133 -- | Type of the tags associated with each constructor possibility
134 -- or superclass selector
135 type ConTag = Int
136
137 fIRST_TAG :: ConTag
138 -- ^ Tags are allocated from here for real constructors
139 -- or for superclass selectors
140 fIRST_TAG = 1
141
142 {-
143 ************************************************************************
144 * *
145 \subsection[Alignment]{Alignment}
146 * *
147 ************************************************************************
148 -}
149
150 type Alignment = Int -- align to next N-byte boundary (N must be a power of 2).
151
152 {-
153 ************************************************************************
154 * *
155 One-shot information
156 * *
157 ************************************************************************
158 -}
159
160 -- | If the 'Id' is a lambda-bound variable then it may have lambda-bound
161 -- variable info. Sometimes we know whether the lambda binding this variable
162 -- is a \"one-shot\" lambda; that is, whether it is applied at most once.
163 --
164 -- This information may be useful in optimisation, as computations may
165 -- safely be floated inside such a lambda without risk of duplicating
166 -- work.
167 data OneShotInfo
168 = NoOneShotInfo -- ^ No information
169 | ProbOneShot -- ^ The lambda is probably applied at most once
170 -- See Note [Computing one-shot info, and ProbOneShot] in Demand
171 | OneShotLam -- ^ The lambda is applied at most once.
172 deriving (Eq)
173
174 -- | It is always safe to assume that an 'Id' has no lambda-bound variable information
175 noOneShotInfo :: OneShotInfo
176 noOneShotInfo = NoOneShotInfo
177
178 isOneShotInfo, hasNoOneShotInfo :: OneShotInfo -> Bool
179 isOneShotInfo OneShotLam = True
180 isOneShotInfo _ = False
181
182 hasNoOneShotInfo NoOneShotInfo = True
183 hasNoOneShotInfo _ = False
184
185 worstOneShot, bestOneShot :: OneShotInfo -> OneShotInfo -> OneShotInfo
186 worstOneShot NoOneShotInfo _ = NoOneShotInfo
187 worstOneShot ProbOneShot NoOneShotInfo = NoOneShotInfo
188 worstOneShot ProbOneShot _ = ProbOneShot
189 worstOneShot OneShotLam os = os
190
191 bestOneShot NoOneShotInfo os = os
192 bestOneShot ProbOneShot OneShotLam = OneShotLam
193 bestOneShot ProbOneShot _ = ProbOneShot
194 bestOneShot OneShotLam _ = OneShotLam
195
196 pprOneShotInfo :: OneShotInfo -> SDoc
197 pprOneShotInfo NoOneShotInfo = empty
198 pprOneShotInfo ProbOneShot = ptext (sLit "ProbOneShot")
199 pprOneShotInfo OneShotLam = ptext (sLit "OneShot")
200
201 instance Outputable OneShotInfo where
202 ppr = pprOneShotInfo
203
204 {-
205 ************************************************************************
206 * *
207 Swap flag
208 * *
209 ************************************************************************
210 -}
211
212 data SwapFlag
213 = NotSwapped -- Args are: actual, expected
214 | IsSwapped -- Args are: expected, actual
215
216 instance Outputable SwapFlag where
217 ppr IsSwapped = ptext (sLit "Is-swapped")
218 ppr NotSwapped = ptext (sLit "Not-swapped")
219
220 flipSwap :: SwapFlag -> SwapFlag
221 flipSwap IsSwapped = NotSwapped
222 flipSwap NotSwapped = IsSwapped
223
224 isSwapped :: SwapFlag -> Bool
225 isSwapped IsSwapped = True
226 isSwapped NotSwapped = False
227
228 unSwap :: SwapFlag -> (a->a->b) -> a -> a -> b
229 unSwap NotSwapped f a b = f a b
230 unSwap IsSwapped f a b = f b a
231
232 {-
233 ************************************************************************
234 * *
235 \subsection[FunctionOrData]{FunctionOrData}
236 * *
237 ************************************************************************
238 -}
239
240 data FunctionOrData = IsFunction | IsData
241 deriving (Eq, Ord, Data, Typeable)
242
243 instance Outputable FunctionOrData where
244 ppr IsFunction = text "(function)"
245 ppr IsData = text "(data)"
246
247 {-
248 ************************************************************************
249 * *
250 \subsection[Version]{Module and identifier version numbers}
251 * *
252 ************************************************************************
253 -}
254
255 type Version = Int
256
257 bumpVersion :: Version -> Version
258 bumpVersion v = v+1
259
260 initialVersion :: Version
261 initialVersion = 1
262
263 {-
264 ************************************************************************
265 * *
266 Deprecations
267 * *
268 ************************************************************************
269 -}
270
271 -- |A String Literal in the source, including its original raw format for use by
272 -- source to source manipulation tools.
273 data StringLiteral = StringLiteral
274 { sl_st :: SourceText, -- literal raw source.
275 -- See not [Literal source text]
276 sl_fs :: FastString -- literal string value
277 } deriving (Data, Typeable)
278
279 instance Eq StringLiteral where
280 (StringLiteral _ a) == (StringLiteral _ b) = a == b
281
282 -- reason/explanation from a WARNING or DEPRECATED pragma
283 data WarningTxt = WarningTxt (Located SourceText)
284 [Located StringLiteral]
285 | DeprecatedTxt (Located SourceText)
286 [Located StringLiteral]
287 deriving (Eq, Data, Typeable)
288
289 instance Outputable WarningTxt where
290 ppr (WarningTxt _ ws)
291 = doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ws))
292 ppr (DeprecatedTxt _ ds)
293 = text "Deprecated:" <+>
294 doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ds))
295
296 {-
297 ************************************************************************
298 * *
299 Rules
300 * *
301 ************************************************************************
302 -}
303
304 type RuleName = FastString
305
306 pprRuleName :: RuleName -> SDoc
307 pprRuleName rn = doubleQuotes (ftext rn)
308
309 {-
310 ************************************************************************
311 * *
312 \subsection[Fixity]{Fixity info}
313 * *
314 ************************************************************************
315 -}
316
317 ------------------------
318 data Fixity = Fixity Int FixityDirection
319 deriving (Data, Typeable)
320
321 instance Outputable Fixity where
322 ppr (Fixity prec dir) = hcat [ppr dir, space, int prec]
323
324 instance Eq Fixity where -- Used to determine if two fixities conflict
325 (Fixity p1 dir1) == (Fixity p2 dir2) = p1==p2 && dir1 == dir2
326
327 ------------------------
328 data FixityDirection = InfixL | InfixR | InfixN
329 deriving (Eq, Data, Typeable)
330
331 instance Outputable FixityDirection where
332 ppr InfixL = ptext (sLit "infixl")
333 ppr InfixR = ptext (sLit "infixr")
334 ppr InfixN = ptext (sLit "infix")
335
336 ------------------------
337 maxPrecedence, minPrecedence :: Int
338 maxPrecedence = 9
339 minPrecedence = 0
340
341 defaultFixity :: Fixity
342 defaultFixity = Fixity maxPrecedence InfixL
343
344 negateFixity, funTyFixity :: Fixity
345 -- Wired-in fixities
346 negateFixity = Fixity 6 InfixL -- Fixity of unary negate
347 funTyFixity = Fixity 0 InfixR -- Fixity of '->'
348
349 {-
350 Consider
351
352 \begin{verbatim}
353 a `op1` b `op2` c
354 \end{verbatim}
355 @(compareFixity op1 op2)@ tells which way to arrange appication, or
356 whether there's an error.
357 -}
358
359 compareFixity :: Fixity -> Fixity
360 -> (Bool, -- Error please
361 Bool) -- Associate to the right: a op1 (b op2 c)
362 compareFixity (Fixity prec1 dir1) (Fixity prec2 dir2)
363 = case prec1 `compare` prec2 of
364 GT -> left
365 LT -> right
366 EQ -> case (dir1, dir2) of
367 (InfixR, InfixR) -> right
368 (InfixL, InfixL) -> left
369 _ -> error_please
370 where
371 right = (False, True)
372 left = (False, False)
373 error_please = (True, False)
374
375 {-
376 ************************************************************************
377 * *
378 \subsection[Top-level/local]{Top-level/not-top level flag}
379 * *
380 ************************************************************************
381 -}
382
383 data TopLevelFlag
384 = TopLevel
385 | NotTopLevel
386
387 isTopLevel, isNotTopLevel :: TopLevelFlag -> Bool
388
389 isNotTopLevel NotTopLevel = True
390 isNotTopLevel TopLevel = False
391
392 isTopLevel TopLevel = True
393 isTopLevel NotTopLevel = False
394
395 instance Outputable TopLevelFlag where
396 ppr TopLevel = ptext (sLit "<TopLevel>")
397 ppr NotTopLevel = ptext (sLit "<NotTopLevel>")
398
399 {-
400 ************************************************************************
401 * *
402 Boxity flag
403 * *
404 ************************************************************************
405 -}
406
407 data Boxity
408 = Boxed
409 | Unboxed
410 deriving( Eq, Data, Typeable )
411
412 isBoxed :: Boxity -> Bool
413 isBoxed Boxed = True
414 isBoxed Unboxed = False
415
416 {-
417 ************************************************************************
418 * *
419 Recursive/Non-Recursive flag
420 * *
421 ************************************************************************
422 -}
423
424 data RecFlag = Recursive
425 | NonRecursive
426 deriving( Eq, Data, Typeable )
427
428 isRec :: RecFlag -> Bool
429 isRec Recursive = True
430 isRec NonRecursive = False
431
432 isNonRec :: RecFlag -> Bool
433 isNonRec Recursive = False
434 isNonRec NonRecursive = True
435
436 boolToRecFlag :: Bool -> RecFlag
437 boolToRecFlag True = Recursive
438 boolToRecFlag False = NonRecursive
439
440 instance Outputable RecFlag where
441 ppr Recursive = ptext (sLit "Recursive")
442 ppr NonRecursive = ptext (sLit "NonRecursive")
443
444 {-
445 ************************************************************************
446 * *
447 Code origin
448 * *
449 ************************************************************************
450 -}
451
452 data Origin = FromSource
453 | Generated
454 deriving( Eq, Data, Typeable )
455
456 isGenerated :: Origin -> Bool
457 isGenerated Generated = True
458 isGenerated FromSource = False
459
460 instance Outputable Origin where
461 ppr FromSource = ptext (sLit "FromSource")
462 ppr Generated = ptext (sLit "Generated")
463
464 {-
465 ************************************************************************
466 * *
467 Instance overlap flag
468 * *
469 ************************************************************************
470 -}
471
472 -- | The semantics allowed for overlapping instances for a particular
473 -- instance. See Note [Safe Haskell isSafeOverlap] (in `InstEnv.hs`) for a
474 -- explanation of the `isSafeOverlap` field.
475 --
476 -- - 'ApiAnnotation.AnnKeywordId' :
477 -- 'ApiAnnotation.AnnOpen' @'\{-\# OVERLAPPABLE'@ or
478 -- @'\{-\# OVERLAPPING'@ or
479 -- @'\{-\# OVERLAPS'@ or
480 -- @'\{-\# INCOHERENT'@,
481 -- 'ApiAnnotation.AnnClose' @`\#-\}`@,
482
483 -- For details on above see note [Api annotations] in ApiAnnotation
484 data OverlapFlag = OverlapFlag
485 { overlapMode :: OverlapMode
486 , isSafeOverlap :: Bool
487 } deriving (Eq, Data, Typeable)
488
489 setOverlapModeMaybe :: OverlapFlag -> Maybe OverlapMode -> OverlapFlag
490 setOverlapModeMaybe f Nothing = f
491 setOverlapModeMaybe f (Just m) = f { overlapMode = m }
492
493 hasOverlappableFlag :: OverlapMode -> Bool
494 hasOverlappableFlag mode =
495 case mode of
496 Overlappable _ -> True
497 Overlaps _ -> True
498 Incoherent _ -> True
499 _ -> False
500
501 hasOverlappingFlag :: OverlapMode -> Bool
502 hasOverlappingFlag mode =
503 case mode of
504 Overlapping _ -> True
505 Overlaps _ -> True
506 Incoherent _ -> True
507 _ -> False
508
509 data OverlapMode -- See Note [Rules for instance lookup] in InstEnv
510 = NoOverlap SourceText
511 -- See Note [Pragma source text]
512 -- ^ This instance must not overlap another `NoOverlap` instance.
513 -- However, it may be overlapped by `Overlapping` instances,
514 -- and it may overlap `Overlappable` instances.
515
516
517 | Overlappable SourceText
518 -- See Note [Pragma source text]
519 -- ^ Silently ignore this instance if you find a
520 -- more specific one that matches the constraint
521 -- you are trying to resolve
522 --
523 -- Example: constraint (Foo [Int])
524 -- instance Foo [Int]
525 -- instance {-# OVERLAPPABLE #-} Foo [a]
526 --
527 -- Since the second instance has the Overlappable flag,
528 -- the first instance will be chosen (otherwise
529 -- its ambiguous which to choose)
530
531
532 | Overlapping SourceText
533 -- See Note [Pragma source text]
534 -- ^ Silently ignore any more general instances that may be
535 -- used to solve the constraint.
536 --
537 -- Example: constraint (Foo [Int])
538 -- instance {-# OVERLAPPING #-} Foo [Int]
539 -- instance Foo [a]
540 --
541 -- Since the first instance has the Overlapping flag,
542 -- the second---more general---instance will be ignored (otherwise
543 -- it is ambiguous which to choose)
544
545
546 | Overlaps SourceText
547 -- See Note [Pragma source text]
548 -- ^ Equivalent to having both `Overlapping` and `Overlappable` flags.
549
550 | Incoherent SourceText
551 -- See Note [Pragma source text]
552 -- ^ Behave like Overlappable and Overlapping, and in addition pick
553 -- an an arbitrary one if there are multiple matching candidates, and
554 -- don't worry about later instantiation
555 --
556 -- Example: constraint (Foo [b])
557 -- instance {-# INCOHERENT -} Foo [Int]
558 -- instance Foo [a]
559 -- Without the Incoherent flag, we'd complain that
560 -- instantiating 'b' would change which instance
561 -- was chosen. See also note [Incoherent instances] in InstEnv
562
563 deriving (Eq, Data, Typeable)
564
565
566 instance Outputable OverlapFlag where
567 ppr flag = ppr (overlapMode flag) <+> pprSafeOverlap (isSafeOverlap flag)
568
569 instance Outputable OverlapMode where
570 ppr (NoOverlap _) = empty
571 ppr (Overlappable _) = ptext (sLit "[overlappable]")
572 ppr (Overlapping _) = ptext (sLit "[overlapping]")
573 ppr (Overlaps _) = ptext (sLit "[overlap ok]")
574 ppr (Incoherent _) = ptext (sLit "[incoherent]")
575
576 pprSafeOverlap :: Bool -> SDoc
577 pprSafeOverlap True = ptext $ sLit "[safe]"
578 pprSafeOverlap False = empty
579
580 {-
581 ************************************************************************
582 * *
583 Tuples
584 * *
585 ************************************************************************
586 -}
587
588 data TupleSort
589 = BoxedTuple
590 | UnboxedTuple
591 | ConstraintTuple
592 deriving( Eq, Data, Typeable )
593
594 tupleSortBoxity :: TupleSort -> Boxity
595 tupleSortBoxity BoxedTuple = Boxed
596 tupleSortBoxity UnboxedTuple = Unboxed
597 tupleSortBoxity ConstraintTuple = Boxed
598
599 boxityTupleSort :: Boxity -> TupleSort
600 boxityTupleSort Boxed = BoxedTuple
601 boxityTupleSort Unboxed = UnboxedTuple
602
603 tupleParens :: TupleSort -> SDoc -> SDoc
604 tupleParens BoxedTuple p = parens p
605 tupleParens UnboxedTuple p = ptext (sLit "(#") <+> p <+> ptext (sLit "#)")
606 tupleParens ConstraintTuple p -- In debug-style write (% Eq a, Ord b %)
607 | opt_PprStyle_Debug = ptext (sLit "(%") <+> p <+> ptext (sLit "%)")
608 | otherwise = parens p
609
610 {-
611 ************************************************************************
612 * *
613 \subsection[Generic]{Generic flag}
614 * *
615 ************************************************************************
616
617 This is the "Embedding-Projection pair" datatype, it contains
618 two pieces of code (normally either RenamedExpr's or Id's)
619 If we have a such a pair (EP from to), the idea is that 'from' and 'to'
620 represents functions of type
621
622 from :: T -> Tring
623 to :: Tring -> T
624
625 And we should have
626
627 to (from x) = x
628
629 T and Tring are arbitrary, but typically T is the 'main' type while
630 Tring is the 'representation' type. (This just helps us remember
631 whether to use 'from' or 'to'.
632 -}
633
634 data EP a = EP { fromEP :: a, -- :: T -> Tring
635 toEP :: a } -- :: Tring -> T
636
637 {-
638 Embedding-projection pairs are used in several places:
639
640 First of all, each type constructor has an EP associated with it, the
641 code in EP converts (datatype T) from T to Tring and back again.
642
643 Secondly, when we are filling in Generic methods (in the typechecker,
644 tcMethodBinds), we are constructing bimaps by induction on the structure
645 of the type of the method signature.
646
647
648 ************************************************************************
649 * *
650 \subsection{Occurrence information}
651 * *
652 ************************************************************************
653
654 This data type is used exclusively by the simplifier, but it appears in a
655 SubstResult, which is currently defined in VarEnv, which is pretty near
656 the base of the module hierarchy. So it seemed simpler to put the
657 defn of OccInfo here, safely at the bottom
658 -}
659
660 -- | Identifier occurrence information
661 data OccInfo
662 = NoOccInfo -- ^ There are many occurrences, or unknown occurrences
663
664 | IAmDead -- ^ Marks unused variables. Sometimes useful for
665 -- lambda and case-bound variables.
666
667 | OneOcc
668 !InsideLam
669 !OneBranch
670 !InterestingCxt -- ^ Occurs exactly once, not inside a rule
671
672 -- | This identifier breaks a loop of mutually recursive functions. The field
673 -- marks whether it is only a loop breaker due to a reference in a rule
674 | IAmALoopBreaker -- Note [LoopBreaker OccInfo]
675 !RulesOnly
676
677 deriving (Eq)
678
679 type RulesOnly = Bool
680
681 {-
682 Note [LoopBreaker OccInfo]
683 ~~~~~~~~~~~~~~~~~~~~~~~~~~
684 IAmALoopBreaker True <=> A "weak" or rules-only loop breaker
685 Do not preInlineUnconditionally
686
687 IAmALoopBreaker False <=> A "strong" loop breaker
688 Do not inline at all
689
690 See OccurAnal Note [Weak loop breakers]
691 -}
692
693 isNoOcc :: OccInfo -> Bool
694 isNoOcc NoOccInfo = True
695 isNoOcc _ = False
696
697 seqOccInfo :: OccInfo -> ()
698 seqOccInfo occ = occ `seq` ()
699
700 -----------------
701 type InterestingCxt = Bool -- True <=> Function: is applied
702 -- Data value: scrutinised by a case with
703 -- at least one non-DEFAULT branch
704
705 -----------------
706 type InsideLam = Bool -- True <=> Occurs inside a non-linear lambda
707 -- Substituting a redex for this occurrence is
708 -- dangerous because it might duplicate work.
709 insideLam, notInsideLam :: InsideLam
710 insideLam = True
711 notInsideLam = False
712
713 -----------------
714 type OneBranch = Bool -- True <=> Occurs in only one case branch
715 -- so no code-duplication issue to worry about
716 oneBranch, notOneBranch :: OneBranch
717 oneBranch = True
718 notOneBranch = False
719
720 strongLoopBreaker, weakLoopBreaker :: OccInfo
721 strongLoopBreaker = IAmALoopBreaker False
722 weakLoopBreaker = IAmALoopBreaker True
723
724 isWeakLoopBreaker :: OccInfo -> Bool
725 isWeakLoopBreaker (IAmALoopBreaker _) = True
726 isWeakLoopBreaker _ = False
727
728 isStrongLoopBreaker :: OccInfo -> Bool
729 isStrongLoopBreaker (IAmALoopBreaker False) = True -- Loop-breaker that breaks a non-rule cycle
730 isStrongLoopBreaker _ = False
731
732 isDeadOcc :: OccInfo -> Bool
733 isDeadOcc IAmDead = True
734 isDeadOcc _ = False
735
736 isOneOcc :: OccInfo -> Bool
737 isOneOcc (OneOcc {}) = True
738 isOneOcc _ = False
739
740 zapFragileOcc :: OccInfo -> OccInfo
741 zapFragileOcc (OneOcc {}) = NoOccInfo
742 zapFragileOcc occ = occ
743
744 instance Outputable OccInfo where
745 -- only used for debugging; never parsed. KSW 1999-07
746 ppr NoOccInfo = empty
747 ppr (IAmALoopBreaker ro) = ptext (sLit "LoopBreaker") <> if ro then char '!' else empty
748 ppr IAmDead = ptext (sLit "Dead")
749 ppr (OneOcc inside_lam one_branch int_cxt)
750 = ptext (sLit "Once") <> pp_lam <> pp_br <> pp_args
751 where
752 pp_lam | inside_lam = char 'L'
753 | otherwise = empty
754 pp_br | one_branch = empty
755 | otherwise = char '*'
756 pp_args | int_cxt = char '!'
757 | otherwise = empty
758
759 {-
760 ************************************************************************
761 * *
762 Default method specfication
763 * *
764 ************************************************************************
765
766 The DefMethSpec enumeration just indicates what sort of default method
767 is used for a class. It is generated from source code, and present in
768 interface files; it is converted to Class.DefMeth before begin put in a
769 Class object.
770 -}
771
772 data DefMethSpec = NoDM -- No default method
773 | VanillaDM -- Default method given with polymorphic code
774 | GenericDM -- Default method given with generic code
775 deriving Eq
776
777 instance Outputable DefMethSpec where
778 ppr NoDM = empty
779 ppr VanillaDM = ptext (sLit "{- Has default method -}")
780 ppr GenericDM = ptext (sLit "{- Has generic default method -}")
781
782 {-
783 ************************************************************************
784 * *
785 \subsection{Success flag}
786 * *
787 ************************************************************************
788 -}
789
790 data SuccessFlag = Succeeded | Failed
791
792 instance Outputable SuccessFlag where
793 ppr Succeeded = ptext (sLit "Succeeded")
794 ppr Failed = ptext (sLit "Failed")
795
796 successIf :: Bool -> SuccessFlag
797 successIf True = Succeeded
798 successIf False = Failed
799
800 succeeded, failed :: SuccessFlag -> Bool
801 succeeded Succeeded = True
802 succeeded Failed = False
803
804 failed Succeeded = False
805 failed Failed = True
806
807 {-
808 ************************************************************************
809 * *
810 \subsection{Source Text}
811 * *
812 ************************************************************************
813 Keeping Source Text for source to source conversions
814
815 Note [Pragma source text]
816 ~~~~~~~~~~~~~~~~~~~~~~~~~
817 The lexer does a case-insensitive match for pragmas, as well as
818 accepting both UK and US spelling variants.
819
820 So
821
822 {-# SPECIALISE #-}
823 {-# SPECIALIZE #-}
824 {-# Specialize #-}
825
826 will all generate ITspec_prag token for the start of the pragma.
827
828 In order to be able to do source to source conversions, the original
829 source text for the token needs to be preserved, hence the
830 `SourceText` field.
831
832 So the lexer will then generate
833
834 ITspec_prag "{ -# SPECIALISE"
835 ITspec_prag "{ -# SPECIALIZE"
836 ITspec_prag "{ -# Specialize"
837
838 for the cases above.
839 [without the space between '{' and '-', otherwise this comment won't parse]
840
841
842 Note [Literal source text]
843 ~~~~~~~~~~~~~~~~~~~~~~~~~~
844 The lexer/parser converts literals from their original source text
845 versions to an appropriate internal representation. This is a problem
846 for tools doing source to source conversions, so the original source
847 text is stored in literals where this can occur.
848
849 Motivating examples for HsLit
850
851 HsChar '\n' == '\x20`
852 HsCharPrim '\x41`# == `A`
853 HsString "\x20\x41" == " A"
854 HsStringPrim "\x20"# == " "#
855 HsInt 001 == 1
856 HsIntPrim 002# == 2#
857 HsWordPrim 003## == 3##
858 HsInt64Prim 004## == 4##
859 HsWord64Prim 005## == 5##
860 HsInteger 006 == 6
861
862 For OverLitVal
863
864 HsIntegral 003 == 0x003
865 HsIsString "\x41nd" == "And"
866 -}
867
868 type SourceText = String -- Note [Literal source text],[Pragma source text]
869
870
871 {-
872 ************************************************************************
873 * *
874 \subsection{Activation}
875 * *
876 ************************************************************************
877
878 When a rule or inlining is active
879 -}
880
881 type PhaseNum = Int -- Compilation phase
882 -- Phases decrease towards zero
883 -- Zero is the last phase
884
885 data CompilerPhase
886 = Phase PhaseNum
887 | InitialPhase -- The first phase -- number = infinity!
888
889 instance Outputable CompilerPhase where
890 ppr (Phase n) = int n
891 ppr InitialPhase = ptext (sLit "InitialPhase")
892
893 data Activation = NeverActive
894 | AlwaysActive
895 | ActiveBefore PhaseNum -- Active only *strictly before* this phase
896 | ActiveAfter PhaseNum -- Active in this phase and later
897 deriving( Eq, Data, Typeable ) -- Eq used in comparing rules in HsDecls
898
899 data RuleMatchInfo = ConLike -- See Note [CONLIKE pragma]
900 | FunLike
901 deriving( Eq, Data, Typeable, Show )
902 -- Show needed for Lexer.x
903
904 data InlinePragma -- Note [InlinePragma]
905 = InlinePragma
906 { inl_src :: SourceText -- Note [Pragma source text]
907 , inl_inline :: InlineSpec
908
909 , inl_sat :: Maybe Arity -- Just n <=> Inline only when applied to n
910 -- explicit (non-type, non-dictionary) args
911 -- That is, inl_sat describes the number of *source-code*
912 -- arguments the thing must be applied to. We add on the
913 -- number of implicit, dictionary arguments when making
914 -- the InlineRule, and don't look at inl_sat further
915
916 , inl_act :: Activation -- Says during which phases inlining is allowed
917
918 , inl_rule :: RuleMatchInfo -- Should the function be treated like a constructor?
919 } deriving( Eq, Data, Typeable )
920
921 data InlineSpec -- What the user's INLINE pragma looked like
922 = Inline
923 | Inlinable
924 | NoInline
925 | EmptyInlineSpec -- Used in a place-holder InlinePragma in SpecPrag or IdInfo,
926 -- where there isn't any real inline pragma at all
927 deriving( Eq, Data, Typeable, Show )
928 -- Show needed for Lexer.x
929
930 {-
931 Note [InlinePragma]
932 ~~~~~~~~~~~~~~~~~~~
933 This data type mirrors what you can write in an INLINE or NOINLINE pragma in
934 the source program.
935
936 If you write nothing at all, you get defaultInlinePragma:
937 inl_inline = False
938 inl_act = AlwaysActive
939 inl_rule = FunLike
940
941 It's not possible to get that combination by *writing* something, so
942 if an Id has defaultInlinePragma it means the user didn't specify anything.
943
944 If inl_inline = True, then the Id should have an InlineRule unfolding.
945
946 Note [CONLIKE pragma]
947 ~~~~~~~~~~~~~~~~~~~~~
948 The ConLike constructor of a RuleMatchInfo is aimed at the following.
949 Consider first
950 {-# RULE "r/cons" forall a as. r (a:as) = f (a+1) #-}
951 g b bs = let x = b:bs in ..x...x...(r x)...
952 Now, the rule applies to the (r x) term, because GHC "looks through"
953 the definition of 'x' to see that it is (b:bs).
954
955 Now consider
956 {-# RULE "r/f" forall v. r (f v) = f (v+1) #-}
957 g v = let x = f v in ..x...x...(r x)...
958 Normally the (r x) would *not* match the rule, because GHC would be
959 scared about duplicating the redex (f v), so it does not "look
960 through" the bindings.
961
962 However the CONLIKE modifier says to treat 'f' like a constructor in
963 this situation, and "look through" the unfolding for x. So (r x)
964 fires, yielding (f (v+1)).
965
966 This is all controlled with a user-visible pragma:
967 {-# NOINLINE CONLIKE [1] f #-}
968
969 The main effects of CONLIKE are:
970
971 - The occurrence analyser (OccAnal) and simplifier (Simplify) treat
972 CONLIKE thing like constructors, by ANF-ing them
973
974 - New function coreUtils.exprIsExpandable is like exprIsCheap, but
975 additionally spots applications of CONLIKE functions
976
977 - A CoreUnfolding has a field that caches exprIsExpandable
978
979 - The rule matcher consults this field. See
980 Note [Expanding variables] in Rules.hs.
981 -}
982
983 isConLike :: RuleMatchInfo -> Bool
984 isConLike ConLike = True
985 isConLike _ = False
986
987 isFunLike :: RuleMatchInfo -> Bool
988 isFunLike FunLike = True
989 isFunLike _ = False
990
991 isEmptyInlineSpec :: InlineSpec -> Bool
992 isEmptyInlineSpec EmptyInlineSpec = True
993 isEmptyInlineSpec _ = False
994
995 defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma
996 :: InlinePragma
997 defaultInlinePragma = InlinePragma { inl_src = "{-# INLINE"
998 , inl_act = AlwaysActive
999 , inl_rule = FunLike
1000 , inl_inline = EmptyInlineSpec
1001 , inl_sat = Nothing }
1002
1003 alwaysInlinePragma = defaultInlinePragma { inl_inline = Inline }
1004 neverInlinePragma = defaultInlinePragma { inl_act = NeverActive }
1005
1006 inlinePragmaSpec :: InlinePragma -> InlineSpec
1007 inlinePragmaSpec = inl_inline
1008
1009 -- A DFun has an always-active inline activation so that
1010 -- exprIsConApp_maybe can "see" its unfolding
1011 -- (However, its actual Unfolding is a DFunUnfolding, which is
1012 -- never inlined other than via exprIsConApp_maybe.)
1013 dfunInlinePragma = defaultInlinePragma { inl_act = AlwaysActive
1014 , inl_rule = ConLike }
1015
1016 isDefaultInlinePragma :: InlinePragma -> Bool
1017 isDefaultInlinePragma (InlinePragma { inl_act = activation
1018 , inl_rule = match_info
1019 , inl_inline = inline })
1020 = isEmptyInlineSpec inline && isAlwaysActive activation && isFunLike match_info
1021
1022 isInlinePragma :: InlinePragma -> Bool
1023 isInlinePragma prag = case inl_inline prag of
1024 Inline -> True
1025 _ -> False
1026
1027 isInlinablePragma :: InlinePragma -> Bool
1028 isInlinablePragma prag = case inl_inline prag of
1029 Inlinable -> True
1030 _ -> False
1031
1032 isAnyInlinePragma :: InlinePragma -> Bool
1033 -- INLINE or INLINABLE
1034 isAnyInlinePragma prag = case inl_inline prag of
1035 Inline -> True
1036 Inlinable -> True
1037 _ -> False
1038
1039 inlinePragmaSat :: InlinePragma -> Maybe Arity
1040 inlinePragmaSat = inl_sat
1041
1042 inlinePragmaActivation :: InlinePragma -> Activation
1043 inlinePragmaActivation (InlinePragma { inl_act = activation }) = activation
1044
1045 inlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo
1046 inlinePragmaRuleMatchInfo (InlinePragma { inl_rule = info }) = info
1047
1048 setInlinePragmaActivation :: InlinePragma -> Activation -> InlinePragma
1049 setInlinePragmaActivation prag activation = prag { inl_act = activation }
1050
1051 setInlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo -> InlinePragma
1052 setInlinePragmaRuleMatchInfo prag info = prag { inl_rule = info }
1053
1054 instance Outputable Activation where
1055 ppr AlwaysActive = brackets (ptext (sLit "ALWAYS"))
1056 ppr NeverActive = brackets (ptext (sLit "NEVER"))
1057 ppr (ActiveBefore n) = brackets (char '~' <> int n)
1058 ppr (ActiveAfter n) = brackets (int n)
1059
1060 instance Outputable RuleMatchInfo where
1061 ppr ConLike = ptext (sLit "CONLIKE")
1062 ppr FunLike = ptext (sLit "FUNLIKE")
1063
1064 instance Outputable InlineSpec where
1065 ppr Inline = ptext (sLit "INLINE")
1066 ppr NoInline = ptext (sLit "NOINLINE")
1067 ppr Inlinable = ptext (sLit "INLINABLE")
1068 ppr EmptyInlineSpec = empty
1069
1070 instance Outputable InlinePragma where
1071 ppr (InlinePragma { inl_inline = inline, inl_act = activation
1072 , inl_rule = info, inl_sat = mb_arity })
1073 = ppr inline <> pp_act inline activation <+> pp_sat <+> pp_info
1074 where
1075 pp_act Inline AlwaysActive = empty
1076 pp_act NoInline NeverActive = empty
1077 pp_act _ act = ppr act
1078
1079 pp_sat | Just ar <- mb_arity = parens (ptext (sLit "sat-args=") <> int ar)
1080 | otherwise = empty
1081 pp_info | isFunLike info = empty
1082 | otherwise = ppr info
1083
1084 isActive :: CompilerPhase -> Activation -> Bool
1085 isActive InitialPhase AlwaysActive = True
1086 isActive InitialPhase (ActiveBefore {}) = True
1087 isActive InitialPhase _ = False
1088 isActive (Phase p) act = isActiveIn p act
1089
1090 isActiveIn :: PhaseNum -> Activation -> Bool
1091 isActiveIn _ NeverActive = False
1092 isActiveIn _ AlwaysActive = True
1093 isActiveIn p (ActiveAfter n) = p <= n
1094 isActiveIn p (ActiveBefore n) = p > n
1095
1096 competesWith :: Activation -> Activation -> Bool
1097 -- See Note [Activation competition]
1098 competesWith NeverActive _ = False
1099 competesWith _ NeverActive = False
1100 competesWith AlwaysActive _ = True
1101
1102 competesWith (ActiveBefore {}) AlwaysActive = True
1103 competesWith (ActiveBefore {}) (ActiveBefore {}) = True
1104 competesWith (ActiveBefore a) (ActiveAfter b) = a < b
1105
1106 competesWith (ActiveAfter {}) AlwaysActive = False
1107 competesWith (ActiveAfter {}) (ActiveBefore {}) = False
1108 competesWith (ActiveAfter a) (ActiveAfter b) = a >= b
1109
1110 {- Note [Competing activations]
1111 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1112 Sometimes a RULE and an inlining may compete, or two RULES.
1113 See Note [Rules and inlining/other rules] in Desugar.
1114
1115 We say that act1 "competes with" act2 iff
1116 act1 is active in the phase when act2 *becomes* active
1117 NB: remember that phases count *down*: 2, 1, 0!
1118
1119 It's too conservative to ensure that the two are never simultaneously
1120 active. For example, a rule might be always active, and an inlining
1121 might switch on in phase 2. We could switch off the rule, but it does
1122 no harm.
1123 -}
1124
1125 isNeverActive, isAlwaysActive, isEarlyActive :: Activation -> Bool
1126 isNeverActive NeverActive = True
1127 isNeverActive _ = False
1128
1129 isAlwaysActive AlwaysActive = True
1130 isAlwaysActive _ = False
1131
1132 isEarlyActive AlwaysActive = True
1133 isEarlyActive (ActiveBefore {}) = True
1134 isEarlyActive _ = False
1135
1136 -- Used (instead of Rational) to represent exactly the floating point literal that we
1137 -- encountered in the user's source program. This allows us to pretty-print exactly what
1138 -- the user wrote, which is important e.g. for floating point numbers that can't represented
1139 -- as Doubles (we used to via Double for pretty-printing). See also #2245.
1140 data FractionalLit
1141 = FL { fl_text :: String -- How the value was written in the source
1142 , fl_value :: Rational -- Numeric value of the literal
1143 }
1144 deriving (Data, Typeable, Show)
1145 -- The Show instance is required for the derived Lexer.x:Token instance when DEBUG is on
1146
1147 negateFractionalLit :: FractionalLit -> FractionalLit
1148 negateFractionalLit (FL { fl_text = '-':text, fl_value = value }) = FL { fl_text = text, fl_value = negate value }
1149 negateFractionalLit (FL { fl_text = text, fl_value = value }) = FL { fl_text = '-':text, fl_value = negate value }
1150
1151 integralFractionalLit :: Integer -> FractionalLit
1152 integralFractionalLit i = FL { fl_text = show i, fl_value = fromInteger i }
1153
1154 -- Comparison operations are needed when grouping literals
1155 -- for compiling pattern-matching (module MatchLit)
1156
1157 instance Eq FractionalLit where
1158 (==) = (==) `on` fl_value
1159
1160 instance Ord FractionalLit where
1161 compare = compare `on` fl_value
1162
1163 instance Outputable FractionalLit where
1164 ppr = text . fl_text
1165
1166 newtype HValue = HValue Any
1167
1168 {-
1169 ************************************************************************
1170 * *
1171 IntWithInf
1172 * *
1173 ************************************************************************
1174
1175 Represents an integer or positive infinity
1176
1177 -}
1178
1179 -- | An integer or infinity
1180 data IntWithInf = Int {-# UNPACK #-} !Int
1181 | Infinity
1182 deriving Eq
1183
1184 -- | A representation of infinity
1185 infinity :: IntWithInf
1186 infinity = Infinity
1187
1188 instance Ord IntWithInf where
1189 compare Infinity Infinity = EQ
1190 compare (Int _) Infinity = LT
1191 compare Infinity (Int _) = GT
1192 compare (Int a) (Int b) = a `compare` b
1193
1194 instance Outputable IntWithInf where
1195 ppr Infinity = char ''
1196 ppr (Int n) = int n
1197
1198 instance Num IntWithInf where
1199 (+) = plusWithInf
1200 (*) = mulWithInf
1201
1202 abs Infinity = Infinity
1203 abs (Int n) = Int (abs n)
1204
1205 signum Infinity = Int 1
1206 signum (Int n) = Int (signum n)
1207
1208 fromInteger = Int . fromInteger
1209
1210 (-) = panic "subtracting IntWithInfs"
1211
1212 intGtLimit :: Int -> IntWithInf -> Bool
1213 intGtLimit _ Infinity = False
1214 intGtLimit n (Int m) = n > m
1215
1216 -- | Add two 'IntWithInf's
1217 plusWithInf :: IntWithInf -> IntWithInf -> IntWithInf
1218 plusWithInf Infinity _ = Infinity
1219 plusWithInf _ Infinity = Infinity
1220 plusWithInf (Int a) (Int b) = Int (a + b)
1221
1222 -- | Multiply two 'IntWithInf's
1223 mulWithInf :: IntWithInf -> IntWithInf -> IntWithInf
1224 mulWithInf Infinity _ = Infinity
1225 mulWithInf _ Infinity = Infinity
1226 mulWithInf (Int a) (Int b) = Int (a * b)
1227
1228 -- | Turn a positive number into an 'IntWithInf', where 0 represents infinity
1229 treatZeroAsInf :: Int -> IntWithInf
1230 treatZeroAsInf 0 = Infinity
1231 treatZeroAsInf n = Int n
1232
1233 -- | Inject any integer into an 'IntWithInf'
1234 mkIntWithInf :: Int -> IntWithInf
1235 mkIntWithInf = Int