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