Smarter HsType pretty-print for promoted datacons
[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 LeftOrRight(..),
23 pickLR,
24
25 ConTag, ConTagZ, fIRST_TAG,
26
27 Arity, RepArity, JoinArity,
28
29 Alignment,
30
31 PromotionFlag(..), isPromoted,
32 FunctionOrData(..),
33
34 WarningTxt(..), pprWarningTxtForMsg, StringLiteral(..),
35
36 Fixity(..), FixityDirection(..),
37 defaultFixity, maxPrecedence, minPrecedence,
38 negateFixity, funTyFixity,
39 compareFixity,
40 LexicalFixity(..),
41
42 RecFlag(..), isRec, isNonRec, boolToRecFlag,
43 Origin(..), isGenerated,
44
45 RuleName, pprRuleName,
46
47 TopLevelFlag(..), isTopLevel, isNotTopLevel,
48
49 OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe,
50 hasOverlappingFlag, hasOverlappableFlag, hasIncoherentFlag,
51
52 Boxity(..), isBoxed,
53
54 PprPrec(..), topPrec, sigPrec, opPrec, funPrec, appPrec, maybeParen,
55
56 TupleSort(..), tupleSortBoxity, boxityTupleSort,
57 tupleParens,
58
59 sumParens, pprAlternative,
60
61 -- ** The OneShotInfo type
62 OneShotInfo(..),
63 noOneShotInfo, hasNoOneShotInfo, isOneShotInfo,
64 bestOneShot, worstOneShot,
65
66 OccInfo(..), noOccInfo, seqOccInfo, zapFragileOcc, isOneOcc,
67 isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker, isManyOccs,
68 strongLoopBreaker, weakLoopBreaker,
69
70 InsideLam, insideLam, notInsideLam,
71 OneBranch, oneBranch, notOneBranch,
72 InterestingCxt,
73 TailCallInfo(..), tailCallInfo, zapOccTailCallInfo,
74 isAlwaysTailCalled,
75
76 EP(..),
77
78 DefMethSpec(..),
79 SwapFlag(..), flipSwap, unSwap, isSwapped,
80
81 CompilerPhase(..), PhaseNum,
82
83 Activation(..), isActive, isActiveIn, competesWith,
84 isNeverActive, isAlwaysActive, isEarlyActive,
85 activeAfterInitial, activeDuringFinal,
86
87 RuleMatchInfo(..), isConLike, isFunLike,
88 InlineSpec(..), noUserInlineSpec,
89 InlinePragma(..), defaultInlinePragma, alwaysInlinePragma,
90 neverInlinePragma, dfunInlinePragma,
91 isDefaultInlinePragma,
92 isInlinePragma, isInlinablePragma, isAnyInlinePragma,
93 inlinePragmaSpec, inlinePragmaSat,
94 inlinePragmaActivation, inlinePragmaRuleMatchInfo,
95 setInlinePragmaActivation, setInlinePragmaRuleMatchInfo,
96 pprInline, pprInlineDebug,
97
98 SuccessFlag(..), succeeded, failed, successIf,
99
100 IntegralLit(..), FractionalLit(..),
101 negateIntegralLit, negateFractionalLit,
102 mkIntegralLit, mkFractionalLit,
103 integralFractionalLit,
104
105 SourceText(..), pprWithSourceText,
106
107 IntWithInf, infinity, treatZeroAsInf, mkIntWithInf, intGtLimit,
108
109 SpliceExplicitFlag(..)
110 ) where
111
112 import GhcPrelude
113
114 import FastString
115 import Outputable
116 import SrcLoc ( Located,unLoc )
117 import Data.Data hiding (Fixity, Prefix, Infix)
118 import Data.Function (on)
119
120 {-
121 ************************************************************************
122 * *
123 Binary choice
124 * *
125 ************************************************************************
126 -}
127
128 data LeftOrRight = CLeft | CRight
129 deriving( Eq, Data )
130
131 pickLR :: LeftOrRight -> (a,a) -> a
132 pickLR CLeft (l,_) = l
133 pickLR CRight (_,r) = r
134
135 instance Outputable LeftOrRight where
136 ppr CLeft = text "Left"
137 ppr CRight = text "Right"
138
139 {-
140 ************************************************************************
141 * *
142 \subsection[Arity]{Arity}
143 * *
144 ************************************************************************
145 -}
146
147 -- | The number of value arguments that can be applied to a value before it does
148 -- "real work". So:
149 -- fib 100 has arity 0
150 -- \x -> fib x has arity 1
151 -- See also Note [Definition of arity] in CoreArity
152 type Arity = Int
153
154 -- | Representation Arity
155 --
156 -- The number of represented arguments that can be applied to a value before it does
157 -- "real work". So:
158 -- fib 100 has representation arity 0
159 -- \x -> fib x has representation arity 1
160 -- \(# x, y #) -> fib (x + y) has representation arity 2
161 type RepArity = Int
162
163 -- | The number of arguments that a join point takes. Unlike the arity of a
164 -- function, this is a purely syntactic property and is fixed when the join
165 -- point is created (or converted from a value). Both type and value arguments
166 -- are counted.
167 type JoinArity = Int
168
169 {-
170 ************************************************************************
171 * *
172 Constructor tags
173 * *
174 ************************************************************************
175 -}
176
177 -- | Constructor Tag
178 --
179 -- Type of the tags associated with each constructor possibility or superclass
180 -- selector
181 type ConTag = Int
182
183 -- | A *zero-indexed* constructor tag
184 type ConTagZ = Int
185
186 fIRST_TAG :: ConTag
187 -- ^ Tags are allocated from here for real constructors
188 -- or for superclass selectors
189 fIRST_TAG = 1
190
191 {-
192 ************************************************************************
193 * *
194 \subsection[Alignment]{Alignment}
195 * *
196 ************************************************************************
197 -}
198
199 type Alignment = Int -- align to next N-byte boundary (N must be a power of 2).
200
201 {-
202 ************************************************************************
203 * *
204 One-shot information
205 * *
206 ************************************************************************
207 -}
208
209 -- | If the 'Id' is a lambda-bound variable then it may have lambda-bound
210 -- variable info. Sometimes we know whether the lambda binding this variable
211 -- is a \"one-shot\" lambda; that is, whether it is applied at most once.
212 --
213 -- This information may be useful in optimisation, as computations may
214 -- safely be floated inside such a lambda without risk of duplicating
215 -- work.
216 data OneShotInfo
217 = NoOneShotInfo -- ^ No information
218 | OneShotLam -- ^ The lambda is applied at most once.
219 deriving (Eq)
220
221 -- | It is always safe to assume that an 'Id' has no lambda-bound variable information
222 noOneShotInfo :: OneShotInfo
223 noOneShotInfo = NoOneShotInfo
224
225 isOneShotInfo, hasNoOneShotInfo :: OneShotInfo -> Bool
226 isOneShotInfo OneShotLam = True
227 isOneShotInfo _ = False
228
229 hasNoOneShotInfo NoOneShotInfo = True
230 hasNoOneShotInfo _ = False
231
232 worstOneShot, bestOneShot :: OneShotInfo -> OneShotInfo -> OneShotInfo
233 worstOneShot NoOneShotInfo _ = NoOneShotInfo
234 worstOneShot OneShotLam os = os
235
236 bestOneShot NoOneShotInfo os = os
237 bestOneShot OneShotLam _ = OneShotLam
238
239 pprOneShotInfo :: OneShotInfo -> SDoc
240 pprOneShotInfo NoOneShotInfo = empty
241 pprOneShotInfo OneShotLam = text "OneShot"
242
243 instance Outputable OneShotInfo where
244 ppr = pprOneShotInfo
245
246 {-
247 ************************************************************************
248 * *
249 Swap flag
250 * *
251 ************************************************************************
252 -}
253
254 data SwapFlag
255 = NotSwapped -- Args are: actual, expected
256 | IsSwapped -- Args are: expected, actual
257
258 instance Outputable SwapFlag where
259 ppr IsSwapped = text "Is-swapped"
260 ppr NotSwapped = text "Not-swapped"
261
262 flipSwap :: SwapFlag -> SwapFlag
263 flipSwap IsSwapped = NotSwapped
264 flipSwap NotSwapped = IsSwapped
265
266 isSwapped :: SwapFlag -> Bool
267 isSwapped IsSwapped = True
268 isSwapped NotSwapped = False
269
270 unSwap :: SwapFlag -> (a->a->b) -> a -> a -> b
271 unSwap NotSwapped f a b = f a b
272 unSwap IsSwapped f a b = f b a
273
274
275 {- *********************************************************************
276 * *
277 Promotion flag
278 * *
279 ********************************************************************* -}
280
281 -- | Is a TyCon a promoted data constructor or just a normal type constructor?
282 data PromotionFlag
283 = NotPromoted
284 | IsPromoted
285 deriving ( Eq, Data )
286
287 isPromoted :: PromotionFlag -> Bool
288 isPromoted IsPromoted = True
289 isPromoted NotPromoted = False
290
291
292 {-
293 ************************************************************************
294 * *
295 \subsection[FunctionOrData]{FunctionOrData}
296 * *
297 ************************************************************************
298 -}
299
300 data FunctionOrData = IsFunction | IsData
301 deriving (Eq, Ord, Data)
302
303 instance Outputable FunctionOrData where
304 ppr IsFunction = text "(function)"
305 ppr IsData = text "(data)"
306
307 {-
308 ************************************************************************
309 * *
310 \subsection[Version]{Module and identifier version numbers}
311 * *
312 ************************************************************************
313 -}
314
315 type Version = Int
316
317 bumpVersion :: Version -> Version
318 bumpVersion v = v+1
319
320 initialVersion :: Version
321 initialVersion = 1
322
323 {-
324 ************************************************************************
325 * *
326 Deprecations
327 * *
328 ************************************************************************
329 -}
330
331 -- | A String Literal in the source, including its original raw format for use by
332 -- source to source manipulation tools.
333 data StringLiteral = StringLiteral
334 { sl_st :: SourceText, -- literal raw source.
335 -- See not [Literal source text]
336 sl_fs :: FastString -- literal string value
337 } deriving Data
338
339 instance Eq StringLiteral where
340 (StringLiteral _ a) == (StringLiteral _ b) = a == b
341
342 instance Outputable StringLiteral where
343 ppr sl = pprWithSourceText (sl_st sl) (ftext $ sl_fs sl)
344
345 -- | Warning Text
346 --
347 -- reason/explanation from a WARNING or DEPRECATED pragma
348 data WarningTxt = WarningTxt (Located SourceText)
349 [Located StringLiteral]
350 | DeprecatedTxt (Located SourceText)
351 [Located StringLiteral]
352 deriving (Eq, Data)
353
354 instance Outputable WarningTxt where
355 ppr (WarningTxt lsrc ws)
356 = case unLoc lsrc of
357 NoSourceText -> pp_ws ws
358 SourceText src -> text src <+> pp_ws ws <+> text "#-}"
359
360 ppr (DeprecatedTxt lsrc ds)
361 = case unLoc lsrc of
362 NoSourceText -> pp_ws ds
363 SourceText src -> text src <+> pp_ws ds <+> text "#-}"
364
365 pp_ws :: [Located StringLiteral] -> SDoc
366 pp_ws [l] = ppr $ unLoc l
367 pp_ws ws
368 = text "["
369 <+> vcat (punctuate comma (map (ppr . unLoc) ws))
370 <+> text "]"
371
372
373 pprWarningTxtForMsg :: WarningTxt -> SDoc
374 pprWarningTxtForMsg (WarningTxt _ ws)
375 = doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ws))
376 pprWarningTxtForMsg (DeprecatedTxt _ ds)
377 = text "Deprecated:" <+>
378 doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ds))
379
380 {-
381 ************************************************************************
382 * *
383 Rules
384 * *
385 ************************************************************************
386 -}
387
388 type RuleName = FastString
389
390 pprRuleName :: RuleName -> SDoc
391 pprRuleName rn = doubleQuotes (ftext rn)
392
393 {-
394 ************************************************************************
395 * *
396 \subsection[Fixity]{Fixity info}
397 * *
398 ************************************************************************
399 -}
400
401 ------------------------
402 data Fixity = Fixity SourceText Int FixityDirection
403 -- Note [Pragma source text]
404 deriving Data
405
406 instance Outputable Fixity where
407 ppr (Fixity _ prec dir) = hcat [ppr dir, space, int prec]
408
409 instance Eq Fixity where -- Used to determine if two fixities conflict
410 (Fixity _ p1 dir1) == (Fixity _ p2 dir2) = p1==p2 && dir1 == dir2
411
412 ------------------------
413 data FixityDirection = InfixL | InfixR | InfixN
414 deriving (Eq, Data)
415
416 instance Outputable FixityDirection where
417 ppr InfixL = text "infixl"
418 ppr InfixR = text "infixr"
419 ppr InfixN = text "infix"
420
421 ------------------------
422 maxPrecedence, minPrecedence :: Int
423 maxPrecedence = 9
424 minPrecedence = 0
425
426 defaultFixity :: Fixity
427 defaultFixity = Fixity NoSourceText maxPrecedence InfixL
428
429 negateFixity, funTyFixity :: Fixity
430 -- Wired-in fixities
431 negateFixity = Fixity NoSourceText 6 InfixL -- Fixity of unary negate
432 funTyFixity = Fixity NoSourceText (-1) InfixR -- Fixity of '->', see #15235
433
434 {-
435 Consider
436
437 \begin{verbatim}
438 a `op1` b `op2` c
439 \end{verbatim}
440 @(compareFixity op1 op2)@ tells which way to arrange application, or
441 whether there's an error.
442 -}
443
444 compareFixity :: Fixity -> Fixity
445 -> (Bool, -- Error please
446 Bool) -- Associate to the right: a op1 (b op2 c)
447 compareFixity (Fixity _ prec1 dir1) (Fixity _ prec2 dir2)
448 = case prec1 `compare` prec2 of
449 GT -> left
450 LT -> right
451 EQ -> case (dir1, dir2) of
452 (InfixR, InfixR) -> right
453 (InfixL, InfixL) -> left
454 _ -> error_please
455 where
456 right = (False, True)
457 left = (False, False)
458 error_please = (True, False)
459
460 -- |Captures the fixity of declarations as they are parsed. This is not
461 -- necessarily the same as the fixity declaration, as the normal fixity may be
462 -- overridden using parens or backticks.
463 data LexicalFixity = Prefix | Infix deriving (Data,Eq)
464
465 instance Outputable LexicalFixity where
466 ppr Prefix = text "Prefix"
467 ppr Infix = text "Infix"
468
469 {-
470 ************************************************************************
471 * *
472 \subsection[Top-level/local]{Top-level/not-top level flag}
473 * *
474 ************************************************************************
475 -}
476
477 data TopLevelFlag
478 = TopLevel
479 | NotTopLevel
480
481 isTopLevel, isNotTopLevel :: TopLevelFlag -> Bool
482
483 isNotTopLevel NotTopLevel = True
484 isNotTopLevel TopLevel = False
485
486 isTopLevel TopLevel = True
487 isTopLevel NotTopLevel = False
488
489 instance Outputable TopLevelFlag where
490 ppr TopLevel = text "<TopLevel>"
491 ppr NotTopLevel = text "<NotTopLevel>"
492
493 {-
494 ************************************************************************
495 * *
496 Boxity flag
497 * *
498 ************************************************************************
499 -}
500
501 data Boxity
502 = Boxed
503 | Unboxed
504 deriving( Eq, Data )
505
506 isBoxed :: Boxity -> Bool
507 isBoxed Boxed = True
508 isBoxed Unboxed = False
509
510 instance Outputable Boxity where
511 ppr Boxed = text "Boxed"
512 ppr Unboxed = text "Unboxed"
513
514 {-
515 ************************************************************************
516 * *
517 Recursive/Non-Recursive flag
518 * *
519 ************************************************************************
520 -}
521
522 -- | Recursivity Flag
523 data RecFlag = Recursive
524 | NonRecursive
525 deriving( Eq, Data )
526
527 isRec :: RecFlag -> Bool
528 isRec Recursive = True
529 isRec NonRecursive = False
530
531 isNonRec :: RecFlag -> Bool
532 isNonRec Recursive = False
533 isNonRec NonRecursive = True
534
535 boolToRecFlag :: Bool -> RecFlag
536 boolToRecFlag True = Recursive
537 boolToRecFlag False = NonRecursive
538
539 instance Outputable RecFlag where
540 ppr Recursive = text "Recursive"
541 ppr NonRecursive = text "NonRecursive"
542
543 {-
544 ************************************************************************
545 * *
546 Code origin
547 * *
548 ************************************************************************
549 -}
550
551 data Origin = FromSource
552 | Generated
553 deriving( Eq, Data )
554
555 isGenerated :: Origin -> Bool
556 isGenerated Generated = True
557 isGenerated FromSource = False
558
559 instance Outputable Origin where
560 ppr FromSource = text "FromSource"
561 ppr Generated = text "Generated"
562
563 {-
564 ************************************************************************
565 * *
566 Instance overlap flag
567 * *
568 ************************************************************************
569 -}
570
571 -- | The semantics allowed for overlapping instances for a particular
572 -- instance. See Note [Safe Haskell isSafeOverlap] (in `InstEnv.hs`) for a
573 -- explanation of the `isSafeOverlap` field.
574 --
575 -- - 'ApiAnnotation.AnnKeywordId' :
576 -- 'ApiAnnotation.AnnOpen' @'\{-\# OVERLAPPABLE'@ or
577 -- @'\{-\# OVERLAPPING'@ or
578 -- @'\{-\# OVERLAPS'@ or
579 -- @'\{-\# INCOHERENT'@,
580 -- 'ApiAnnotation.AnnClose' @`\#-\}`@,
581
582 -- For details on above see note [Api annotations] in ApiAnnotation
583 data OverlapFlag = OverlapFlag
584 { overlapMode :: OverlapMode
585 , isSafeOverlap :: Bool
586 } deriving (Eq, Data)
587
588 setOverlapModeMaybe :: OverlapFlag -> Maybe OverlapMode -> OverlapFlag
589 setOverlapModeMaybe f Nothing = f
590 setOverlapModeMaybe f (Just m) = f { overlapMode = m }
591
592 hasIncoherentFlag :: OverlapMode -> Bool
593 hasIncoherentFlag mode =
594 case mode of
595 Incoherent _ -> True
596 _ -> False
597
598 hasOverlappableFlag :: OverlapMode -> Bool
599 hasOverlappableFlag mode =
600 case mode of
601 Overlappable _ -> True
602 Overlaps _ -> True
603 Incoherent _ -> True
604 _ -> False
605
606 hasOverlappingFlag :: OverlapMode -> Bool
607 hasOverlappingFlag mode =
608 case mode of
609 Overlapping _ -> True
610 Overlaps _ -> True
611 Incoherent _ -> True
612 _ -> False
613
614 data OverlapMode -- See Note [Rules for instance lookup] in InstEnv
615 = NoOverlap SourceText
616 -- See Note [Pragma source text]
617 -- ^ This instance must not overlap another `NoOverlap` instance.
618 -- However, it may be overlapped by `Overlapping` instances,
619 -- and it may overlap `Overlappable` instances.
620
621
622 | Overlappable SourceText
623 -- See Note [Pragma source text]
624 -- ^ Silently ignore this instance if you find a
625 -- more specific one that matches the constraint
626 -- you are trying to resolve
627 --
628 -- Example: constraint (Foo [Int])
629 -- instance Foo [Int]
630 -- instance {-# OVERLAPPABLE #-} Foo [a]
631 --
632 -- Since the second instance has the Overlappable flag,
633 -- the first instance will be chosen (otherwise
634 -- its ambiguous which to choose)
635
636
637 | Overlapping SourceText
638 -- See Note [Pragma source text]
639 -- ^ Silently ignore any more general instances that may be
640 -- used to solve the constraint.
641 --
642 -- Example: constraint (Foo [Int])
643 -- instance {-# OVERLAPPING #-} Foo [Int]
644 -- instance Foo [a]
645 --
646 -- Since the first instance has the Overlapping flag,
647 -- the second---more general---instance will be ignored (otherwise
648 -- it is ambiguous which to choose)
649
650
651 | Overlaps SourceText
652 -- See Note [Pragma source text]
653 -- ^ Equivalent to having both `Overlapping` and `Overlappable` flags.
654
655 | Incoherent SourceText
656 -- See Note [Pragma source text]
657 -- ^ Behave like Overlappable and Overlapping, and in addition pick
658 -- an an arbitrary one if there are multiple matching candidates, and
659 -- don't worry about later instantiation
660 --
661 -- Example: constraint (Foo [b])
662 -- instance {-# INCOHERENT -} Foo [Int]
663 -- instance Foo [a]
664 -- Without the Incoherent flag, we'd complain that
665 -- instantiating 'b' would change which instance
666 -- was chosen. See also note [Incoherent instances] in InstEnv
667
668 deriving (Eq, Data)
669
670
671 instance Outputable OverlapFlag where
672 ppr flag = ppr (overlapMode flag) <+> pprSafeOverlap (isSafeOverlap flag)
673
674 instance Outputable OverlapMode where
675 ppr (NoOverlap _) = empty
676 ppr (Overlappable _) = text "[overlappable]"
677 ppr (Overlapping _) = text "[overlapping]"
678 ppr (Overlaps _) = text "[overlap ok]"
679 ppr (Incoherent _) = text "[incoherent]"
680
681 pprSafeOverlap :: Bool -> SDoc
682 pprSafeOverlap True = text "[safe]"
683 pprSafeOverlap False = empty
684
685 {-
686 ************************************************************************
687 * *
688 Precedence
689 * *
690 ************************************************************************
691 -}
692
693 -- | A general-purpose pretty-printing precedence type.
694 newtype PprPrec = PprPrec Int deriving (Eq, Ord, Show)
695 -- See Note [Precedence in types]
696
697 topPrec, sigPrec, funPrec, opPrec, appPrec :: PprPrec
698 topPrec = PprPrec 0 -- No parens
699 sigPrec = PprPrec 1 -- Explicit type signatures
700 funPrec = PprPrec 2 -- Function args; no parens for constructor apps
701 -- See [Type operator precedence] for why both
702 -- funPrec and opPrec exist.
703 opPrec = PprPrec 2 -- Infix operator
704 appPrec = PprPrec 3 -- Constructor args; no parens for atomic
705
706 maybeParen :: PprPrec -> PprPrec -> SDoc -> SDoc
707 maybeParen ctxt_prec inner_prec pretty
708 | ctxt_prec < inner_prec = pretty
709 | otherwise = parens pretty
710
711 {- Note [Precedence in types]
712 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
713 Many pretty-printing functions have type
714 ppr_ty :: PprPrec -> Type -> SDoc
715
716 The PprPrec gives the binding strength of the context. For example, in
717 T ty1 ty2
718 we will pretty-print 'ty1' and 'ty2' with the call
719 (ppr_ty appPrec ty)
720 to indicate that the context is that of an argument of a TyConApp.
721
722 We use this consistently for Type and HsType.
723
724 Note [Type operator precedence]
725 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
726 We don't keep the fixity of type operators in the operator. So the
727 pretty printer follows the following precedence order:
728
729 TyConPrec Type constructor application
730 TyOpPrec/FunPrec Operator application and function arrow
731
732 We have funPrec and opPrec to represent the precedence of function
733 arrow and type operators respectively, but currently we implement
734 funPrec == opPrec, so that we don't distinguish the two. Reason:
735 it's hard to parse a type like
736 a ~ b => c * d -> e - f
737
738 By treating opPrec = funPrec we end up with more parens
739 (a ~ b) => (c * d) -> (e - f)
740
741 But the two are different constructors of PprPrec so we could make
742 (->) bind more or less tightly if we wanted.
743 -}
744
745 {-
746 ************************************************************************
747 * *
748 Tuples
749 * *
750 ************************************************************************
751 -}
752
753 data TupleSort
754 = BoxedTuple
755 | UnboxedTuple
756 | ConstraintTuple
757 deriving( Eq, Data )
758
759 tupleSortBoxity :: TupleSort -> Boxity
760 tupleSortBoxity BoxedTuple = Boxed
761 tupleSortBoxity UnboxedTuple = Unboxed
762 tupleSortBoxity ConstraintTuple = Boxed
763
764 boxityTupleSort :: Boxity -> TupleSort
765 boxityTupleSort Boxed = BoxedTuple
766 boxityTupleSort Unboxed = UnboxedTuple
767
768 tupleParens :: TupleSort -> SDoc -> SDoc
769 tupleParens BoxedTuple p = parens p
770 tupleParens UnboxedTuple p = text "(#" <+> p <+> ptext (sLit "#)")
771 tupleParens ConstraintTuple p -- In debug-style write (% Eq a, Ord b %)
772 = ifPprDebug (text "(%" <+> p <+> ptext (sLit "%)"))
773 (parens p)
774
775 {-
776 ************************************************************************
777 * *
778 Sums
779 * *
780 ************************************************************************
781 -}
782
783 sumParens :: SDoc -> SDoc
784 sumParens p = ptext (sLit "(#") <+> p <+> ptext (sLit "#)")
785
786 -- | Pretty print an alternative in an unboxed sum e.g. "| a | |".
787 pprAlternative :: (a -> SDoc) -- ^ The pretty printing function to use
788 -> a -- ^ The things to be pretty printed
789 -> ConTag -- ^ Alternative (one-based)
790 -> Arity -- ^ Arity
791 -> SDoc -- ^ 'SDoc' where the alternative havs been pretty
792 -- printed and finally packed into a paragraph.
793 pprAlternative pp x alt arity =
794 fsep (replicate (alt - 1) vbar ++ [pp x] ++ replicate (arity - alt) vbar)
795
796 {-
797 ************************************************************************
798 * *
799 \subsection[Generic]{Generic flag}
800 * *
801 ************************************************************************
802
803 This is the "Embedding-Projection pair" datatype, it contains
804 two pieces of code (normally either RenamedExpr's or Id's)
805 If we have a such a pair (EP from to), the idea is that 'from' and 'to'
806 represents functions of type
807
808 from :: T -> Tring
809 to :: Tring -> T
810
811 And we should have
812
813 to (from x) = x
814
815 T and Tring are arbitrary, but typically T is the 'main' type while
816 Tring is the 'representation' type. (This just helps us remember
817 whether to use 'from' or 'to'.
818 -}
819
820 -- | Embedding Projection pair
821 data EP a = EP { fromEP :: a, -- :: T -> Tring
822 toEP :: a } -- :: Tring -> T
823
824 {-
825 Embedding-projection pairs are used in several places:
826
827 First of all, each type constructor has an EP associated with it, the
828 code in EP converts (datatype T) from T to Tring and back again.
829
830 Secondly, when we are filling in Generic methods (in the typechecker,
831 tcMethodBinds), we are constructing bimaps by induction on the structure
832 of the type of the method signature.
833
834
835 ************************************************************************
836 * *
837 \subsection{Occurrence information}
838 * *
839 ************************************************************************
840
841 This data type is used exclusively by the simplifier, but it appears in a
842 SubstResult, which is currently defined in VarEnv, which is pretty near
843 the base of the module hierarchy. So it seemed simpler to put the
844 defn of OccInfo here, safely at the bottom
845 -}
846
847 -- | identifier Occurrence Information
848 data OccInfo
849 = ManyOccs { occ_tail :: !TailCallInfo }
850 -- ^ There are many occurrences, or unknown occurrences
851
852 | IAmDead -- ^ Marks unused variables. Sometimes useful for
853 -- lambda and case-bound variables.
854
855 | OneOcc { occ_in_lam :: !InsideLam
856 , occ_one_br :: !OneBranch
857 , occ_int_cxt :: !InterestingCxt
858 , occ_tail :: !TailCallInfo }
859 -- ^ Occurs exactly once (per branch), not inside a rule
860
861 -- | This identifier breaks a loop of mutually recursive functions. The field
862 -- marks whether it is only a loop breaker due to a reference in a rule
863 | IAmALoopBreaker { occ_rules_only :: !RulesOnly
864 , occ_tail :: !TailCallInfo }
865 -- Note [LoopBreaker OccInfo]
866
867 deriving (Eq)
868
869 type RulesOnly = Bool
870
871 {-
872 Note [LoopBreaker OccInfo]
873 ~~~~~~~~~~~~~~~~~~~~~~~~~~
874 IAmALoopBreaker True <=> A "weak" or rules-only loop breaker
875 Do not preInlineUnconditionally
876
877 IAmALoopBreaker False <=> A "strong" loop breaker
878 Do not inline at all
879
880 See OccurAnal Note [Weak loop breakers]
881 -}
882
883 noOccInfo :: OccInfo
884 noOccInfo = ManyOccs { occ_tail = NoTailCallInfo }
885
886 isManyOccs :: OccInfo -> Bool
887 isManyOccs ManyOccs{} = True
888 isManyOccs _ = False
889
890 seqOccInfo :: OccInfo -> ()
891 seqOccInfo occ = occ `seq` ()
892
893 -----------------
894 -- | Interesting Context
895 type InterestingCxt = Bool -- True <=> Function: is applied
896 -- Data value: scrutinised by a case with
897 -- at least one non-DEFAULT branch
898
899 -----------------
900 -- | Inside Lambda
901 type InsideLam = Bool -- True <=> Occurs inside a non-linear lambda
902 -- Substituting a redex for this occurrence is
903 -- dangerous because it might duplicate work.
904 insideLam, notInsideLam :: InsideLam
905 insideLam = True
906 notInsideLam = False
907
908 -----------------
909 type OneBranch = Bool -- True <=> Occurs in only one case branch
910 -- so no code-duplication issue to worry about
911 oneBranch, notOneBranch :: OneBranch
912 oneBranch = True
913 notOneBranch = False
914
915 -----------------
916 data TailCallInfo = AlwaysTailCalled JoinArity -- See Note [TailCallInfo]
917 | NoTailCallInfo
918 deriving (Eq)
919
920 tailCallInfo :: OccInfo -> TailCallInfo
921 tailCallInfo IAmDead = NoTailCallInfo
922 tailCallInfo other = occ_tail other
923
924 zapOccTailCallInfo :: OccInfo -> OccInfo
925 zapOccTailCallInfo IAmDead = IAmDead
926 zapOccTailCallInfo occ = occ { occ_tail = NoTailCallInfo }
927
928 isAlwaysTailCalled :: OccInfo -> Bool
929 isAlwaysTailCalled occ
930 = case tailCallInfo occ of AlwaysTailCalled{} -> True
931 NoTailCallInfo -> False
932
933 instance Outputable TailCallInfo where
934 ppr (AlwaysTailCalled ar) = sep [ text "Tail", int ar ]
935 ppr _ = empty
936
937 -----------------
938 strongLoopBreaker, weakLoopBreaker :: OccInfo
939 strongLoopBreaker = IAmALoopBreaker False NoTailCallInfo
940 weakLoopBreaker = IAmALoopBreaker True NoTailCallInfo
941
942 isWeakLoopBreaker :: OccInfo -> Bool
943 isWeakLoopBreaker (IAmALoopBreaker{}) = True
944 isWeakLoopBreaker _ = False
945
946 isStrongLoopBreaker :: OccInfo -> Bool
947 isStrongLoopBreaker (IAmALoopBreaker { occ_rules_only = False }) = True
948 -- Loop-breaker that breaks a non-rule cycle
949 isStrongLoopBreaker _ = False
950
951 isDeadOcc :: OccInfo -> Bool
952 isDeadOcc IAmDead = True
953 isDeadOcc _ = False
954
955 isOneOcc :: OccInfo -> Bool
956 isOneOcc (OneOcc {}) = True
957 isOneOcc _ = False
958
959 zapFragileOcc :: OccInfo -> OccInfo
960 -- Keep only the most robust data: deadness, loop-breaker-hood
961 zapFragileOcc (OneOcc {}) = noOccInfo
962 zapFragileOcc occ = zapOccTailCallInfo occ
963
964 instance Outputable OccInfo where
965 -- only used for debugging; never parsed. KSW 1999-07
966 ppr (ManyOccs tails) = pprShortTailCallInfo tails
967 ppr IAmDead = text "Dead"
968 ppr (IAmALoopBreaker rule_only tails)
969 = text "LoopBreaker" <> pp_ro <> pprShortTailCallInfo tails
970 where
971 pp_ro | rule_only = char '!'
972 | otherwise = empty
973 ppr (OneOcc inside_lam one_branch int_cxt tail_info)
974 = text "Once" <> pp_lam <> pp_br <> pp_args <> pp_tail
975 where
976 pp_lam | inside_lam = char 'L'
977 | otherwise = empty
978 pp_br | one_branch = empty
979 | otherwise = char '*'
980 pp_args | int_cxt = char '!'
981 | otherwise = empty
982 pp_tail = pprShortTailCallInfo tail_info
983
984 pprShortTailCallInfo :: TailCallInfo -> SDoc
985 pprShortTailCallInfo (AlwaysTailCalled ar) = char 'T' <> brackets (int ar)
986 pprShortTailCallInfo NoTailCallInfo = empty
987
988 {-
989 Note [TailCallInfo]
990 ~~~~~~~~~~~~~~~~~~~
991 The occurrence analyser determines what can be made into a join point, but it
992 doesn't change the binder into a JoinId because then it would be inconsistent
993 with the occurrences. Thus it's left to the simplifier (or to simpleOptExpr) to
994 change the IdDetails.
995
996 The AlwaysTailCalled marker actually means slightly more than simply that the
997 function is always tail-called. See Note [Invariants on join points].
998
999 This info is quite fragile and should not be relied upon unless the occurrence
1000 analyser has *just* run. Use 'Id.isJoinId_maybe' for the permanent state of
1001 the join-point-hood of a binder; a join id itself will not be marked
1002 AlwaysTailCalled.
1003
1004 Note that there is a 'TailCallInfo' on a 'ManyOccs' value. One might expect that
1005 being tail-called would mean that the variable could only appear once per branch
1006 (thus getting a `OneOcc { occ_one_br = True }` occurrence info), but a join
1007 point can also be invoked from other join points, not just from case branches:
1008
1009 let j1 x = ...
1010 j2 y = ... j1 z {- tail call -} ...
1011 in case w of
1012 A -> j1 v
1013 B -> j2 u
1014 C -> j2 q
1015
1016 Here both 'j1' and 'j2' will get marked AlwaysTailCalled, but j1 will get
1017 ManyOccs and j2 will get `OneOcc { occ_one_br = True }`.
1018
1019 ************************************************************************
1020 * *
1021 Default method specification
1022 * *
1023 ************************************************************************
1024
1025 The DefMethSpec enumeration just indicates what sort of default method
1026 is used for a class. It is generated from source code, and present in
1027 interface files; it is converted to Class.DefMethInfo before begin put in a
1028 Class object.
1029 -}
1030
1031 -- | Default Method Specification
1032 data DefMethSpec ty
1033 = VanillaDM -- Default method given with polymorphic code
1034 | GenericDM ty -- Default method given with code of this type
1035
1036 instance Outputable (DefMethSpec ty) where
1037 ppr VanillaDM = text "{- Has default method -}"
1038 ppr (GenericDM {}) = text "{- Has generic default method -}"
1039
1040 {-
1041 ************************************************************************
1042 * *
1043 \subsection{Success flag}
1044 * *
1045 ************************************************************************
1046 -}
1047
1048 data SuccessFlag = Succeeded | Failed
1049
1050 instance Outputable SuccessFlag where
1051 ppr Succeeded = text "Succeeded"
1052 ppr Failed = text "Failed"
1053
1054 successIf :: Bool -> SuccessFlag
1055 successIf True = Succeeded
1056 successIf False = Failed
1057
1058 succeeded, failed :: SuccessFlag -> Bool
1059 succeeded Succeeded = True
1060 succeeded Failed = False
1061
1062 failed Succeeded = False
1063 failed Failed = True
1064
1065 {-
1066 ************************************************************************
1067 * *
1068 \subsection{Source Text}
1069 * *
1070 ************************************************************************
1071 Keeping Source Text for source to source conversions
1072
1073 Note [Pragma source text]
1074 ~~~~~~~~~~~~~~~~~~~~~~~~~
1075 The lexer does a case-insensitive match for pragmas, as well as
1076 accepting both UK and US spelling variants.
1077
1078 So
1079
1080 {-# SPECIALISE #-}
1081 {-# SPECIALIZE #-}
1082 {-# Specialize #-}
1083
1084 will all generate ITspec_prag token for the start of the pragma.
1085
1086 In order to be able to do source to source conversions, the original
1087 source text for the token needs to be preserved, hence the
1088 `SourceText` field.
1089
1090 So the lexer will then generate
1091
1092 ITspec_prag "{ -# SPECIALISE"
1093 ITspec_prag "{ -# SPECIALIZE"
1094 ITspec_prag "{ -# Specialize"
1095
1096 for the cases above.
1097 [without the space between '{' and '-', otherwise this comment won't parse]
1098
1099
1100 Note [Literal source text]
1101 ~~~~~~~~~~~~~~~~~~~~~~~~~~
1102 The lexer/parser converts literals from their original source text
1103 versions to an appropriate internal representation. This is a problem
1104 for tools doing source to source conversions, so the original source
1105 text is stored in literals where this can occur.
1106
1107 Motivating examples for HsLit
1108
1109 HsChar '\n' == '\x20`
1110 HsCharPrim '\x41`# == `A`
1111 HsString "\x20\x41" == " A"
1112 HsStringPrim "\x20"# == " "#
1113 HsInt 001 == 1
1114 HsIntPrim 002# == 2#
1115 HsWordPrim 003## == 3##
1116 HsInt64Prim 004## == 4##
1117 HsWord64Prim 005## == 5##
1118 HsInteger 006 == 6
1119
1120 For OverLitVal
1121
1122 HsIntegral 003 == 0x003
1123 HsIsString "\x41nd" == "And"
1124 -}
1125
1126 -- Note [Literal source text],[Pragma source text]
1127 data SourceText = SourceText String
1128 | NoSourceText -- ^ For when code is generated, e.g. TH,
1129 -- deriving. The pretty printer will then make
1130 -- its own representation of the item.
1131 deriving (Data, Show, Eq )
1132
1133 instance Outputable SourceText where
1134 ppr (SourceText s) = text "SourceText" <+> text s
1135 ppr NoSourceText = text "NoSourceText"
1136
1137 -- | Special combinator for showing string literals.
1138 pprWithSourceText :: SourceText -> SDoc -> SDoc
1139 pprWithSourceText NoSourceText d = d
1140 pprWithSourceText (SourceText src) _ = text src
1141
1142 {-
1143 ************************************************************************
1144 * *
1145 \subsection{Activation}
1146 * *
1147 ************************************************************************
1148
1149 When a rule or inlining is active
1150 -}
1151
1152 -- | Phase Number
1153 type PhaseNum = Int -- Compilation phase
1154 -- Phases decrease towards zero
1155 -- Zero is the last phase
1156
1157 data CompilerPhase
1158 = Phase PhaseNum
1159 | InitialPhase -- The first phase -- number = infinity!
1160
1161 instance Outputable CompilerPhase where
1162 ppr (Phase n) = int n
1163 ppr InitialPhase = text "InitialPhase"
1164
1165 activeAfterInitial :: Activation
1166 -- Active in the first phase after the initial phase
1167 -- Currently we have just phases [2,1,0]
1168 activeAfterInitial = ActiveAfter NoSourceText 2
1169
1170 activeDuringFinal :: Activation
1171 -- Active in the final simplification phase (which is repeated)
1172 activeDuringFinal = ActiveAfter NoSourceText 0
1173
1174 -- See note [Pragma source text]
1175 data Activation = NeverActive
1176 | AlwaysActive
1177 | ActiveBefore SourceText PhaseNum
1178 -- Active only *strictly before* this phase
1179 | ActiveAfter SourceText PhaseNum
1180 -- Active in this phase and later
1181 deriving( Eq, Data )
1182 -- Eq used in comparing rules in HsDecls
1183
1184 -- | Rule Match Information
1185 data RuleMatchInfo = ConLike -- See Note [CONLIKE pragma]
1186 | FunLike
1187 deriving( Eq, Data, Show )
1188 -- Show needed for Lexer.x
1189
1190 data InlinePragma -- Note [InlinePragma]
1191 = InlinePragma
1192 { inl_src :: SourceText -- Note [Pragma source text]
1193 , inl_inline :: InlineSpec -- See Note [inl_inline and inl_act]
1194
1195 , inl_sat :: Maybe Arity -- Just n <=> Inline only when applied to n
1196 -- explicit (non-type, non-dictionary) args
1197 -- That is, inl_sat describes the number of *source-code*
1198 -- arguments the thing must be applied to. We add on the
1199 -- number of implicit, dictionary arguments when making
1200 -- the Unfolding, and don't look at inl_sat further
1201
1202 , inl_act :: Activation -- Says during which phases inlining is allowed
1203 -- See Note [inl_inline and inl_act]
1204
1205 , inl_rule :: RuleMatchInfo -- Should the function be treated like a constructor?
1206 } deriving( Eq, Data )
1207
1208 -- | Inline Specification
1209 data InlineSpec -- What the user's INLINE pragma looked like
1210 = Inline -- User wrote INLINE
1211 | Inlinable -- User wrote INLINABLE
1212 | NoInline -- User wrote NOINLINE
1213 | NoUserInline -- User did not write any of INLINE/INLINABLE/NOINLINE
1214 -- e.g. in `defaultInlinePragma` or when created by CSE
1215 deriving( Eq, Data, Show )
1216 -- Show needed for Lexer.x
1217
1218 {- Note [InlinePragma]
1219 ~~~~~~~~~~~~~~~~~~~~~~
1220 This data type mirrors what you can write in an INLINE or NOINLINE pragma in
1221 the source program.
1222
1223 If you write nothing at all, you get defaultInlinePragma:
1224 inl_inline = NoUserInline
1225 inl_act = AlwaysActive
1226 inl_rule = FunLike
1227
1228 It's not possible to get that combination by *writing* something, so
1229 if an Id has defaultInlinePragma it means the user didn't specify anything.
1230
1231 If inl_inline = Inline or Inlineable, then the Id should have an InlineRule unfolding.
1232
1233 If you want to know where InlinePragmas take effect: Look in DsBinds.makeCorePair
1234
1235 Note [inl_inline and inl_act]
1236 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1237 * inl_inline says what the user wrote: did she say INLINE, NOINLINE,
1238 INLINABLE, or nothing at all
1239
1240 * inl_act says in what phases the unfolding is active or inactive
1241 E.g If you write INLINE[1] then inl_act will be set to ActiveAfter 1
1242 If you write NOINLINE[1] then inl_act will be set to ActiveBefore 1
1243 If you write NOINLINE[~1] then inl_act will be set to ActiveAfter 1
1244 So note that inl_act does not say what pragma you wrote: it just
1245 expresses its consequences
1246
1247 * inl_act just says when the unfolding is active; it doesn't say what
1248 to inline. If you say INLINE f, then f's inl_act will be AlwaysActive,
1249 but in addition f will get a "stable unfolding" with UnfoldingGuidance
1250 that tells the inliner to be pretty eager about it.
1251
1252 Note [CONLIKE pragma]
1253 ~~~~~~~~~~~~~~~~~~~~~
1254 The ConLike constructor of a RuleMatchInfo is aimed at the following.
1255 Consider first
1256 {-# RULE "r/cons" forall a as. r (a:as) = f (a+1) #-}
1257 g b bs = let x = b:bs in ..x...x...(r x)...
1258 Now, the rule applies to the (r x) term, because GHC "looks through"
1259 the definition of 'x' to see that it is (b:bs).
1260
1261 Now consider
1262 {-# RULE "r/f" forall v. r (f v) = f (v+1) #-}
1263 g v = let x = f v in ..x...x...(r x)...
1264 Normally the (r x) would *not* match the rule, because GHC would be
1265 scared about duplicating the redex (f v), so it does not "look
1266 through" the bindings.
1267
1268 However the CONLIKE modifier says to treat 'f' like a constructor in
1269 this situation, and "look through" the unfolding for x. So (r x)
1270 fires, yielding (f (v+1)).
1271
1272 This is all controlled with a user-visible pragma:
1273 {-# NOINLINE CONLIKE [1] f #-}
1274
1275 The main effects of CONLIKE are:
1276
1277 - The occurrence analyser (OccAnal) and simplifier (Simplify) treat
1278 CONLIKE thing like constructors, by ANF-ing them
1279
1280 - New function coreUtils.exprIsExpandable is like exprIsCheap, but
1281 additionally spots applications of CONLIKE functions
1282
1283 - A CoreUnfolding has a field that caches exprIsExpandable
1284
1285 - The rule matcher consults this field. See
1286 Note [Expanding variables] in Rules.hs.
1287 -}
1288
1289 isConLike :: RuleMatchInfo -> Bool
1290 isConLike ConLike = True
1291 isConLike _ = False
1292
1293 isFunLike :: RuleMatchInfo -> Bool
1294 isFunLike FunLike = True
1295 isFunLike _ = False
1296
1297 noUserInlineSpec :: InlineSpec -> Bool
1298 noUserInlineSpec NoUserInline = True
1299 noUserInlineSpec _ = False
1300
1301 defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma
1302 :: InlinePragma
1303 defaultInlinePragma = InlinePragma { inl_src = SourceText "{-# INLINE"
1304 , inl_act = AlwaysActive
1305 , inl_rule = FunLike
1306 , inl_inline = NoUserInline
1307 , inl_sat = Nothing }
1308
1309 alwaysInlinePragma = defaultInlinePragma { inl_inline = Inline }
1310 neverInlinePragma = defaultInlinePragma { inl_act = NeverActive }
1311
1312 inlinePragmaSpec :: InlinePragma -> InlineSpec
1313 inlinePragmaSpec = inl_inline
1314
1315 -- A DFun has an always-active inline activation so that
1316 -- exprIsConApp_maybe can "see" its unfolding
1317 -- (However, its actual Unfolding is a DFunUnfolding, which is
1318 -- never inlined other than via exprIsConApp_maybe.)
1319 dfunInlinePragma = defaultInlinePragma { inl_act = AlwaysActive
1320 , inl_rule = ConLike }
1321
1322 isDefaultInlinePragma :: InlinePragma -> Bool
1323 isDefaultInlinePragma (InlinePragma { inl_act = activation
1324 , inl_rule = match_info
1325 , inl_inline = inline })
1326 = noUserInlineSpec inline && isAlwaysActive activation && isFunLike match_info
1327
1328 isInlinePragma :: InlinePragma -> Bool
1329 isInlinePragma prag = case inl_inline prag of
1330 Inline -> True
1331 _ -> False
1332
1333 isInlinablePragma :: InlinePragma -> Bool
1334 isInlinablePragma prag = case inl_inline prag of
1335 Inlinable -> True
1336 _ -> False
1337
1338 isAnyInlinePragma :: InlinePragma -> Bool
1339 -- INLINE or INLINABLE
1340 isAnyInlinePragma prag = case inl_inline prag of
1341 Inline -> True
1342 Inlinable -> True
1343 _ -> False
1344
1345 inlinePragmaSat :: InlinePragma -> Maybe Arity
1346 inlinePragmaSat = inl_sat
1347
1348 inlinePragmaActivation :: InlinePragma -> Activation
1349 inlinePragmaActivation (InlinePragma { inl_act = activation }) = activation
1350
1351 inlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo
1352 inlinePragmaRuleMatchInfo (InlinePragma { inl_rule = info }) = info
1353
1354 setInlinePragmaActivation :: InlinePragma -> Activation -> InlinePragma
1355 setInlinePragmaActivation prag activation = prag { inl_act = activation }
1356
1357 setInlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo -> InlinePragma
1358 setInlinePragmaRuleMatchInfo prag info = prag { inl_rule = info }
1359
1360 instance Outputable Activation where
1361 ppr AlwaysActive = empty
1362 ppr NeverActive = brackets (text "~")
1363 ppr (ActiveBefore _ n) = brackets (char '~' <> int n)
1364 ppr (ActiveAfter _ n) = brackets (int n)
1365
1366 instance Outputable RuleMatchInfo where
1367 ppr ConLike = text "CONLIKE"
1368 ppr FunLike = text "FUNLIKE"
1369
1370 instance Outputable InlineSpec where
1371 ppr Inline = text "INLINE"
1372 ppr NoInline = text "NOINLINE"
1373 ppr Inlinable = text "INLINABLE"
1374 ppr NoUserInline = text "NOUSERINLINE" -- what is better?
1375
1376 instance Outputable InlinePragma where
1377 ppr = pprInline
1378
1379 pprInline :: InlinePragma -> SDoc
1380 pprInline = pprInline' True
1381
1382 pprInlineDebug :: InlinePragma -> SDoc
1383 pprInlineDebug = pprInline' False
1384
1385 pprInline' :: Bool -- True <=> do not display the inl_inline field
1386 -> InlinePragma
1387 -> SDoc
1388 pprInline' emptyInline (InlinePragma { inl_inline = inline, inl_act = activation
1389 , inl_rule = info, inl_sat = mb_arity })
1390 = pp_inl inline <> pp_act inline activation <+> pp_sat <+> pp_info
1391 where
1392 pp_inl x = if emptyInline then empty else ppr x
1393
1394 pp_act Inline AlwaysActive = empty
1395 pp_act NoInline NeverActive = empty
1396 pp_act _ act = ppr act
1397
1398 pp_sat | Just ar <- mb_arity = parens (text "sat-args=" <> int ar)
1399 | otherwise = empty
1400 pp_info | isFunLike info = empty
1401 | otherwise = ppr info
1402
1403 isActive :: CompilerPhase -> Activation -> Bool
1404 isActive InitialPhase AlwaysActive = True
1405 isActive InitialPhase (ActiveBefore {}) = True
1406 isActive InitialPhase _ = False
1407 isActive (Phase p) act = isActiveIn p act
1408
1409 isActiveIn :: PhaseNum -> Activation -> Bool
1410 isActiveIn _ NeverActive = False
1411 isActiveIn _ AlwaysActive = True
1412 isActiveIn p (ActiveAfter _ n) = p <= n
1413 isActiveIn p (ActiveBefore _ n) = p > n
1414
1415 competesWith :: Activation -> Activation -> Bool
1416 -- See Note [Activation competition]
1417 competesWith NeverActive _ = False
1418 competesWith _ NeverActive = False
1419 competesWith AlwaysActive _ = True
1420
1421 competesWith (ActiveBefore {}) AlwaysActive = True
1422 competesWith (ActiveBefore {}) (ActiveBefore {}) = True
1423 competesWith (ActiveBefore _ a) (ActiveAfter _ b) = a < b
1424
1425 competesWith (ActiveAfter {}) AlwaysActive = False
1426 competesWith (ActiveAfter {}) (ActiveBefore {}) = False
1427 competesWith (ActiveAfter _ a) (ActiveAfter _ b) = a >= b
1428
1429 {- Note [Competing activations]
1430 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1431 Sometimes a RULE and an inlining may compete, or two RULES.
1432 See Note [Rules and inlining/other rules] in Desugar.
1433
1434 We say that act1 "competes with" act2 iff
1435 act1 is active in the phase when act2 *becomes* active
1436 NB: remember that phases count *down*: 2, 1, 0!
1437
1438 It's too conservative to ensure that the two are never simultaneously
1439 active. For example, a rule might be always active, and an inlining
1440 might switch on in phase 2. We could switch off the rule, but it does
1441 no harm.
1442 -}
1443
1444 isNeverActive, isAlwaysActive, isEarlyActive :: Activation -> Bool
1445 isNeverActive NeverActive = True
1446 isNeverActive _ = False
1447
1448 isAlwaysActive AlwaysActive = True
1449 isAlwaysActive _ = False
1450
1451 isEarlyActive AlwaysActive = True
1452 isEarlyActive (ActiveBefore {}) = True
1453 isEarlyActive _ = False
1454
1455 -- | Integral Literal
1456 --
1457 -- Used (instead of Integer) to represent negative zegative zero which is
1458 -- required for NegativeLiterals extension to correctly parse `-0::Double`
1459 -- as negative zero. See also #13211.
1460 data IntegralLit
1461 = IL { il_text :: SourceText
1462 , il_neg :: Bool -- See Note [Negative zero]
1463 , il_value :: Integer
1464 }
1465 deriving (Data, Show)
1466
1467 mkIntegralLit :: Integral a => a -> IntegralLit
1468 mkIntegralLit i = IL { il_text = SourceText (show i_integer)
1469 , il_neg = i < 0
1470 , il_value = i_integer }
1471 where
1472 i_integer :: Integer
1473 i_integer = toInteger i
1474
1475 negateIntegralLit :: IntegralLit -> IntegralLit
1476 negateIntegralLit (IL text neg value)
1477 = case text of
1478 SourceText ('-':src) -> IL (SourceText src) False (negate value)
1479 SourceText src -> IL (SourceText ('-':src)) True (negate value)
1480 NoSourceText -> IL NoSourceText (not neg) (negate value)
1481
1482 -- | Fractional Literal
1483 --
1484 -- Used (instead of Rational) to represent exactly the floating point literal that we
1485 -- encountered in the user's source program. This allows us to pretty-print exactly what
1486 -- the user wrote, which is important e.g. for floating point numbers that can't represented
1487 -- as Doubles (we used to via Double for pretty-printing). See also #2245.
1488 data FractionalLit
1489 = FL { fl_text :: SourceText -- How the value was written in the source
1490 , fl_neg :: Bool -- See Note [Negative zero]
1491 , fl_value :: Rational -- Numeric value of the literal
1492 }
1493 deriving (Data, Show)
1494 -- The Show instance is required for the derived Lexer.x:Token instance when DEBUG is on
1495
1496 mkFractionalLit :: Real a => a -> FractionalLit
1497 mkFractionalLit r = FL { fl_text = SourceText (show (realToFrac r::Double))
1498 -- Converting to a Double here may technically lose
1499 -- precision (see #15502). We could alternatively
1500 -- convert to a Rational for the most accuracy, but
1501 -- it would cause Floats and Doubles to be displayed
1502 -- strangely, so we opt not to do this. (In contrast
1503 -- to mkIntegralLit, where we always convert to an
1504 -- Integer for the highest accuracy.)
1505 , fl_neg = r < 0
1506 , fl_value = toRational r }
1507
1508 negateFractionalLit :: FractionalLit -> FractionalLit
1509 negateFractionalLit (FL text neg value)
1510 = case text of
1511 SourceText ('-':src) -> FL (SourceText src) False value
1512 SourceText src -> FL (SourceText ('-':src)) True value
1513 NoSourceText -> FL NoSourceText (not neg) (negate value)
1514
1515 integralFractionalLit :: Bool -> Integer -> FractionalLit
1516 integralFractionalLit neg i = FL { fl_text = SourceText (show i),
1517 fl_neg = neg,
1518 fl_value = fromInteger i }
1519
1520 -- Comparison operations are needed when grouping literals
1521 -- for compiling pattern-matching (module MatchLit)
1522
1523 instance Eq IntegralLit where
1524 (==) = (==) `on` il_value
1525
1526 instance Ord IntegralLit where
1527 compare = compare `on` il_value
1528
1529 instance Outputable IntegralLit where
1530 ppr (IL (SourceText src) _ _) = text src
1531 ppr (IL NoSourceText _ value) = text (show value)
1532
1533 instance Eq FractionalLit where
1534 (==) = (==) `on` fl_value
1535
1536 instance Ord FractionalLit where
1537 compare = compare `on` fl_value
1538
1539 instance Outputable FractionalLit where
1540 ppr f = pprWithSourceText (fl_text f) (rational (fl_value f))
1541
1542 {-
1543 ************************************************************************
1544 * *
1545 IntWithInf
1546 * *
1547 ************************************************************************
1548
1549 Represents an integer or positive infinity
1550
1551 -}
1552
1553 -- | An integer or infinity
1554 data IntWithInf = Int {-# UNPACK #-} !Int
1555 | Infinity
1556 deriving Eq
1557
1558 -- | A representation of infinity
1559 infinity :: IntWithInf
1560 infinity = Infinity
1561
1562 instance Ord IntWithInf where
1563 compare Infinity Infinity = EQ
1564 compare (Int _) Infinity = LT
1565 compare Infinity (Int _) = GT
1566 compare (Int a) (Int b) = a `compare` b
1567
1568 instance Outputable IntWithInf where
1569 ppr Infinity = char ''
1570 ppr (Int n) = int n
1571
1572 instance Num IntWithInf where
1573 (+) = plusWithInf
1574 (*) = mulWithInf
1575
1576 abs Infinity = Infinity
1577 abs (Int n) = Int (abs n)
1578
1579 signum Infinity = Int 1
1580 signum (Int n) = Int (signum n)
1581
1582 fromInteger = Int . fromInteger
1583
1584 (-) = panic "subtracting IntWithInfs"
1585
1586 intGtLimit :: Int -> IntWithInf -> Bool
1587 intGtLimit _ Infinity = False
1588 intGtLimit n (Int m) = n > m
1589
1590 -- | Add two 'IntWithInf's
1591 plusWithInf :: IntWithInf -> IntWithInf -> IntWithInf
1592 plusWithInf Infinity _ = Infinity
1593 plusWithInf _ Infinity = Infinity
1594 plusWithInf (Int a) (Int b) = Int (a + b)
1595
1596 -- | Multiply two 'IntWithInf's
1597 mulWithInf :: IntWithInf -> IntWithInf -> IntWithInf
1598 mulWithInf Infinity _ = Infinity
1599 mulWithInf _ Infinity = Infinity
1600 mulWithInf (Int a) (Int b) = Int (a * b)
1601
1602 -- | Turn a positive number into an 'IntWithInf', where 0 represents infinity
1603 treatZeroAsInf :: Int -> IntWithInf
1604 treatZeroAsInf 0 = Infinity
1605 treatZeroAsInf n = Int n
1606
1607 -- | Inject any integer into an 'IntWithInf'
1608 mkIntWithInf :: Int -> IntWithInf
1609 mkIntWithInf = Int
1610
1611 data SpliceExplicitFlag
1612 = ExplicitSplice | -- ^ <=> $(f x y)
1613 ImplicitSplice -- ^ <=> f x y, i.e. a naked top level expression
1614 deriving Data