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