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