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