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