compiler/basicTypes/BasicTypes.lhs

   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 \begin{code}
  17 {-# LANGUAGE DeriveDataTypeable #-}
  18
  19 module BasicTypes(
  20         Version, bumpVersion, initialVersion,
  21
  22         Arity,
  23
  24     FunctionOrData(..),
  25
  26         WarningTxt(..),
  27
  28         Fixity(..), FixityDirection(..),
  29         defaultFixity, maxPrecedence,
  30         negateFixity, funTyFixity,
  31         compareFixity,
  32
  33         IPName(..), ipNameName, mapIPName,
  34
  35         RecFlag(..), isRec, isNonRec, boolToRecFlag,
  36
  37         RuleName,
  38
  39         TopLevelFlag(..), isTopLevel, isNotTopLevel,
  40
  41         OverlapFlag(..),
  42
  43         Boxity(..), isBoxed,
  44
  45         TupCon(..), tupleParens,
  46
  47         OccInfo(..), seqOccInfo, zapFragileOcc, isOneOcc,
  48         isDeadOcc, isLoopBreaker, isNonRuleLoopBreaker, isNoOcc,
  49         nonRuleLoopBreaker,
  50
  51         InsideLam, insideLam, notInsideLam,
  52         OneBranch, oneBranch, notOneBranch,
  53         InterestingCxt,
  54
  55         EP(..),
  56
  57         StrictnessMark(..), isMarkedUnboxed, isMarkedStrict,
  58
  59         CompilerPhase,
  60         Activation(..), isActive, isNeverActive, isAlwaysActive, isEarlyActive,
  61         RuleMatchInfo(..), isConLike, isFunLike,
  62         InlinePragma(..), defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma,
  63         isDefaultInlinePragma, isInlinePragma, inlinePragmaSat,
  64         inlinePragmaActivation, inlinePragmaRuleMatchInfo,
  65         setInlinePragmaActivation, setInlinePragmaRuleMatchInfo,
  66
  67         SuccessFlag(..), succeeded, failed, successIf
  68    ) where
  69
  70 import FastString
  71 import Outputable
  72
  73 import Data.Data hiding (Fixity)
  74 \end{code}
  75
  76 %************************************************************************
  77 %*                                                                      *
  78 \subsection[Arity]{Arity}
  79 %*                                                                      *
  80 %************************************************************************
  81
  82 \begin{code}
  83 type Arity = Int
  84 \end{code}
  85
  86 %************************************************************************
  87 %*                                                                      *
  88 \subsection[FunctionOrData]{FunctionOrData}
  89 %*                                                                      *
  90 %************************************************************************
  91
  92 \begin{code}
  93 data FunctionOrData = IsFunction | IsData
  94     deriving (Eq, Ord, Data, Typeable)
  95
  96 instance Outputable FunctionOrData where
  97     ppr IsFunction = text "(function)"
  98     ppr IsData     = text "(data)"
  99 \end{code}
 100
 101
 102 %************************************************************************
 103 %*                                                                      *
 104 \subsection[Version]{Module and identifier version numbers}
 105 %*                                                                      *
 106 %************************************************************************
 107
 108 \begin{code}
 109 type Version = Int
 110
 111 bumpVersion :: Version -> Version
 112 bumpVersion v = v+1
 113
 114 initialVersion :: Version
 115 initialVersion = 1
 116 \end{code}
 117
 118 %************************************************************************
 119 %*                                                                      *
 120                 Deprecations
 121 %*                                                                      *
 122 %************************************************************************
 123
 124
 125 \begin{code}
 126 -- reason/explanation from a WARNING or DEPRECATED pragma
 127 data WarningTxt = WarningTxt [FastString]
 128                 | DeprecatedTxt [FastString]
 129     deriving (Eq, Data, Typeable)
 130
 131 instance Outputable WarningTxt where
 132     ppr (WarningTxt    ws) = doubleQuotes (vcat (map ftext ws))
 133     ppr (DeprecatedTxt ds) = text "Deprecated:" <+>
 134                              doubleQuotes (vcat (map ftext ds))
 135 \end{code}
 136
 137 %************************************************************************
 138 %*                                                                      *
 139 \subsection{Implicit parameter identity}
 140 %*                                                                      *
 141 %************************************************************************
 142
 143 The @IPName@ type is here because it is used in TypeRep (i.e. very
 144 early in the hierarchy), but also in HsSyn.
 145
 146 \begin{code}
 147 newtype IPName name = IPName name       -- ?x
 148   deriving( Eq, Ord, Data, Typeable )
 149   -- Ord is used in the IP name cache finite map
 150   -- (used in HscTypes.OrigIParamCache)
 151
 152 ipNameName :: IPName name -> name
 153 ipNameName (IPName n) = n
 154
 155 mapIPName :: (a->b) -> IPName a -> IPName b
 156 mapIPName f (IPName n) = IPName (f n)
 157
 158 instance Outputable name => Outputable (IPName name) where
 159     ppr (IPName n) = char '?' <> ppr n -- Ordinary implicit parameters
 160 \end{code}
 161
 162 %************************************************************************
 163 %*                                                                      *
 164                 Rules
 165 %*                                                                      *
 166 %************************************************************************
 167
 168 \begin{code}
 169 type RuleName = FastString
 170 \end{code}
 171
 172 %************************************************************************
 173 %*                                                                      *
 174 \subsection[Fixity]{Fixity info}
 175 %*                                                                      *
 176 %************************************************************************
 177
 178 \begin{code}
 179 ------------------------
 180 data Fixity = Fixity Int FixityDirection
 181   deriving (Data, Typeable)
 182
 183 instance Outputable Fixity where
 184     ppr (Fixity prec dir) = hcat [ppr dir, space, int prec]
 185
 186 instance Eq Fixity where                -- Used to determine if two fixities conflict
 187   (Fixity p1 dir1) == (Fixity p2 dir2) = p1==p2 && dir1 == dir2
 188
 189 ------------------------
 190 data FixityDirection = InfixL | InfixR | InfixN
 191                      deriving (Eq, Data, Typeable)
 192
 193 instance Outputable FixityDirection where
 194     ppr InfixL = ptext (sLit "infixl")
 195     ppr InfixR = ptext (sLit "infixr")
 196     ppr InfixN = ptext (sLit "infix")
 197
 198 ------------------------
 199 maxPrecedence :: Int
 200 maxPrecedence = 9
 201 defaultFixity :: Fixity
 202 defaultFixity = Fixity maxPrecedence InfixL
 203
 204 negateFixity, funTyFixity :: Fixity
 205 -- Wired-in fixities
 206 negateFixity = Fixity 6 InfixL  -- Fixity of unary negate
 207 funTyFixity  = Fixity 0 InfixR  -- Fixity of '->'
 208 \end{code}
 209
 210 Consider
 211
 212 \begin{verbatim}
 213         a `op1` b `op2` c
 214 \end{verbatim}
 215 @(compareFixity op1 op2)@ tells which way to arrange appication, or
 216 whether there's an error.
 217
 218 \begin{code}
 219 compareFixity :: Fixity -> Fixity
 220               -> (Bool,         -- Error please
 221                   Bool)         -- Associate to the right: a op1 (b op2 c)
 222 compareFixity (Fixity prec1 dir1) (Fixity prec2 dir2)
 223   = case prec1 `compare` prec2 of
 224         GT -> left
 225         LT -> right
 226         EQ -> case (dir1, dir2) of
 227                         (InfixR, InfixR) -> right
 228                         (InfixL, InfixL) -> left
 229                         _                -> error_please
 230   where
 231     right        = (False, True)
 232     left         = (False, False)
 233     error_please = (True,  False)
 234 \end{code}
 235
 236
 237 %************************************************************************
 238 %*                                                                      *
 239 \subsection[Top-level/local]{Top-level/not-top level flag}
 240 %*                                                                      *
 241 %************************************************************************
 242
 243 \begin{code}
 244 data TopLevelFlag
 245   = TopLevel
 246   | NotTopLevel
 247
 248 isTopLevel, isNotTopLevel :: TopLevelFlag -> Bool
 249
 250 isNotTopLevel NotTopLevel = True
 251 isNotTopLevel TopLevel    = False
 252
 253 isTopLevel TopLevel     = True
 254 isTopLevel NotTopLevel  = False
 255
 256 instance Outputable TopLevelFlag where
 257   ppr TopLevel    = ptext (sLit "<TopLevel>")
 258   ppr NotTopLevel = ptext (sLit "<NotTopLevel>")
 259 \end{code}
 260
 261
 262 %************************************************************************
 263 %*                                                                      *
 264                 Top-level/not-top level flag
 265 %*                                                                      *
 266 %************************************************************************
 267
 268 \begin{code}
 269 data Boxity
 270   = Boxed
 271   | Unboxed
 272   deriving( Eq, Data, Typeable )
 273
 274 isBoxed :: Boxity -> Bool
 275 isBoxed Boxed   = True
 276 isBoxed Unboxed = False
 277 \end{code}
 278
 279
 280 %************************************************************************
 281 %*                                                                      *
 282                 Recursive/Non-Recursive flag
 283 %*                                                                      *
 284 %************************************************************************
 285
 286 \begin{code}
 287 data RecFlag = Recursive
 288              | NonRecursive
 289              deriving( Eq, Data, Typeable )
 290
 291 isRec :: RecFlag -> Bool
 292 isRec Recursive    = True
 293 isRec NonRecursive = False
 294
 295 isNonRec :: RecFlag -> Bool
 296 isNonRec Recursive    = False
 297 isNonRec NonRecursive = True
 298
 299 boolToRecFlag :: Bool -> RecFlag
 300 boolToRecFlag True  = Recursive
 301 boolToRecFlag False = NonRecursive
 302
 303 instance Outputable RecFlag where
 304   ppr Recursive    = ptext (sLit "Recursive")
 305   ppr NonRecursive = ptext (sLit "NonRecursive")
 306 \end{code}
 307
 308 %************************************************************************
 309 %*                                                                      *
 310                 Instance overlap flag
 311 %*                                                                      *
 312 %************************************************************************
 313
 314 \begin{code}
 315 data OverlapFlag
 316   = NoOverlap   -- This instance must not overlap another
 317
 318   | OverlapOk   -- Silently ignore this instance if you find a
 319                 -- more specific one that matches the constraint
 320                 -- you are trying to resolve
 321                 --
 322                 -- Example: constraint (Foo [Int])
 323                 --          instances  (Foo [Int])
 324                 --                     (Foo [a])        OverlapOk
 325                 -- Since the second instance has the OverlapOk flag,
 326                 -- the first instance will be chosen (otherwise
 327                 -- its ambiguous which to choose)
 328
 329   | Incoherent  -- Like OverlapOk, but also ignore this instance
 330                 -- if it doesn't match the constraint you are
 331                 -- trying to resolve, but could match if the type variables
 332                 -- in the constraint were instantiated
 333                 --
 334                 -- Example: constraint (Foo [b])
 335                 --          instances  (Foo [Int])      Incoherent
 336                 --                     (Foo [a])
 337                 -- Without the Incoherent flag, we'd complain that
 338                 -- instantiating 'b' would change which instance
 339                 -- was chosen
 340   deriving( Eq )
 341
 342 instance Outputable OverlapFlag where
 343    ppr NoOverlap  = empty
 344    ppr OverlapOk  = ptext (sLit "[overlap ok]")
 345    ppr Incoherent = ptext (sLit "[incoherent]")
 346
 347 \end{code}
 348
 349 %************************************************************************
 350 %*                                                                      *
 351                 Tuples
 352 %*                                                                      *
 353 %************************************************************************
 354
 355 \begin{code}
 356 data TupCon = TupCon Boxity Arity
 357
 358 instance Eq TupCon where
 359   (TupCon b1 a1) == (TupCon b2 a2) = b1==b2 && a1==a2
 360
 361 tupleParens :: Boxity -> SDoc -> SDoc
 362 tupleParens Boxed   p = parens p
 363 tupleParens Unboxed p = ptext (sLit "(#") <+> p <+> ptext (sLit "#)")
 364 \end{code}
 365
 366 %************************************************************************
 367 %*                                                                      *
 368 \subsection[Generic]{Generic flag}
 369 %*                                                                      *
 370 %************************************************************************
 371
 372 This is the "Embedding-Projection pair" datatype, it contains
 373 two pieces of code (normally either RenamedExpr's or Id's)
 374 If we have a such a pair (EP from to), the idea is that 'from' and 'to'
 375 represents functions of type
 376
 377         from :: T -> Tring
 378         to   :: Tring -> T
 379
 380 And we should have
 381
 382         to (from x) = x
 383
 384 T and Tring are arbitrary, but typically T is the 'main' type while
 385 Tring is the 'representation' type.  (This just helps us remember
 386 whether to use 'from' or 'to'.
 387
 388 \begin{code}
 389 data EP a = EP { fromEP :: a,   -- :: T -> Tring
 390                  toEP   :: a }  -- :: Tring -> T
 391 \end{code}
 392
 393 Embedding-projection pairs are used in several places:
 394
 395 First of all, each type constructor has an EP associated with it, the
 396 code in EP converts (datatype T) from T to Tring and back again.
 397
 398 Secondly, when we are filling in Generic methods (in the typechecker,
 399 tcMethodBinds), we are constructing bimaps by induction on the structure
 400 of the type of the method signature.
 401
 402
 403 %************************************************************************
 404 %*                                                                      *
 405 \subsection{Occurrence information}
 406 %*                                                                      *
 407 %************************************************************************
 408
 409 This data type is used exclusively by the simplifier, but it appears in a
 410 SubstResult, which is currently defined in VarEnv, which is pretty near
 411 the base of the module hierarchy.  So it seemed simpler to put the
 412 defn of OccInfo here, safely at the bottom
 413
 414 \begin{code}
 415 -- | Identifier occurrence information
 416 data OccInfo
 417   = NoOccInfo           -- ^ There are many occurrences, or unknown occurences
 418
 419   | IAmDead             -- ^ Marks unused variables.  Sometimes useful for
 420                         -- lambda and case-bound variables.
 421
 422   | OneOcc
 423         !InsideLam
 424         !OneBranch
 425         !InterestingCxt -- ^ Occurs exactly once, not inside a rule
 426
 427   -- | This identifier breaks a loop of mutually recursive functions. The field
 428   -- marks whether it is only a loop breaker due to a reference in a rule
 429   | IAmALoopBreaker     -- Note [LoopBreaker OccInfo]
 430         !RulesOnly      -- True <=> This is a weak or rules-only loop breaker
 431                         --          See OccurAnal Note [Weak loop breakers]
 432
 433 type RulesOnly = Bool
 434 \end{code}
 435
 436 Note [LoopBreaker OccInfo]
 437 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 438 An OccInfo of (IAmLoopBreaker False) is used by the occurrence
 439 analyser in two ways:
 440   (a) to mark loop-breakers in a group of recursive
 441       definitions (hence the name)
 442   (b) to mark binders that must not be inlined in this phase
 443       (perhaps it has a NOINLINE pragma)
 444 Things with (IAmLoopBreaker False) do not get an unfolding
 445 pinned on to them, so they are completely opaque.
 446
 447 See OccurAnal Note [Weak loop breakers] for (IAmLoopBreaker True).
 448
 449
 450 \begin{code}
 451 isNoOcc :: OccInfo -> Bool
 452 isNoOcc NoOccInfo = True
 453 isNoOcc _         = False
 454
 455 seqOccInfo :: OccInfo -> ()
 456 seqOccInfo occ = occ `seq` ()
 457
 458 -----------------
 459 type InterestingCxt = Bool      -- True <=> Function: is applied
 460                                 --          Data value: scrutinised by a case with
 461                                 --                      at least one non-DEFAULT branch
 462
 463 -----------------
 464 type InsideLam = Bool   -- True <=> Occurs inside a non-linear lambda
 465                         -- Substituting a redex for this occurrence is
 466                         -- dangerous because it might duplicate work.
 467 insideLam, notInsideLam :: InsideLam
 468 insideLam    = True
 469 notInsideLam = False
 470
 471 -----------------
 472 type OneBranch = Bool   -- True <=> Occurs in only one case branch
 473                         --      so no code-duplication issue to worry about
 474 oneBranch, notOneBranch :: OneBranch
 475 oneBranch    = True
 476 notOneBranch = False
 477
 478 isLoopBreaker :: OccInfo -> Bool
 479 isLoopBreaker (IAmALoopBreaker _) = True
 480 isLoopBreaker _                   = False
 481
 482 isNonRuleLoopBreaker :: OccInfo -> Bool
 483 isNonRuleLoopBreaker (IAmALoopBreaker False) = True   -- Loop-breaker that breaks a non-rule cycle
 484 isNonRuleLoopBreaker _                       = False
 485
 486 nonRuleLoopBreaker :: OccInfo
 487 nonRuleLoopBreaker = IAmALoopBreaker False
 488
 489 isDeadOcc :: OccInfo -> Bool
 490 isDeadOcc IAmDead = True
 491 isDeadOcc _       = False
 492
 493 isOneOcc :: OccInfo -> Bool
 494 isOneOcc (OneOcc {}) = True
 495 isOneOcc _           = False
 496
 497 zapFragileOcc :: OccInfo -> OccInfo
 498 zapFragileOcc (OneOcc {}) = NoOccInfo
 499 zapFragileOcc occ         = occ
 500 \end{code}
 501
 502 \begin{code}
 503 instance Outputable OccInfo where
 504   -- only used for debugging; never parsed.  KSW 1999-07
 505   ppr NoOccInfo            = empty
 506   ppr (IAmALoopBreaker ro) = ptext (sLit "LoopBreaker") <> if ro then char '!' else empty
 507   ppr IAmDead              = ptext (sLit "Dead")
 508   ppr (OneOcc inside_lam one_branch int_cxt)
 509         = ptext (sLit "Once") <> pp_lam <> pp_br <> pp_args
 510         where
 511           pp_lam | inside_lam = char 'L'
 512                  | otherwise  = empty
 513           pp_br  | one_branch = empty
 514                  | otherwise  = char '*'
 515           pp_args | int_cxt   = char '!'
 516                   | otherwise = empty
 517
 518 instance Show OccInfo where
 519   showsPrec p occ = showsPrecSDoc p (ppr occ)
 520 \end{code}
 521
 522 %************************************************************************
 523 %*                                                                      *
 524 \subsection{Strictness indication}
 525 %*                                                                      *
 526 %************************************************************************
 527
 528 The strictness annotations on types in data type declarations
 529 e.g.    data T = MkT !Int !(Bool,Bool)
 530
 531 \begin{code}
 532 data StrictnessMark     -- Used in interface decls only
 533    = MarkedStrict
 534    | MarkedUnboxed
 535    | NotMarkedStrict
 536    deriving( Eq )
 537
 538 isMarkedUnboxed :: StrictnessMark -> Bool
 539 isMarkedUnboxed MarkedUnboxed = True
 540 isMarkedUnboxed _             = False
 541
 542 isMarkedStrict :: StrictnessMark -> Bool
 543 isMarkedStrict NotMarkedStrict = False
 544 isMarkedStrict _               = True   -- All others are strict
 545
 546 instance Outputable StrictnessMark where
 547   ppr MarkedStrict     = ptext (sLit "!")
 548   ppr MarkedUnboxed    = ptext (sLit "!!")
 549   ppr NotMarkedStrict  = ptext (sLit "_")
 550 \end{code}
 551
 552
 553 %************************************************************************
 554 %*                                                                      *
 555 \subsection{Success flag}
 556 %*                                                                      *
 557 %************************************************************************
 558
 559 \begin{code}
 560 data SuccessFlag = Succeeded | Failed
 561
 562 instance Outputable SuccessFlag where
 563     ppr Succeeded = ptext (sLit "Succeeded")
 564     ppr Failed    = ptext (sLit "Failed")
 565
 566 successIf :: Bool -> SuccessFlag
 567 successIf True  = Succeeded
 568 successIf False = Failed
 569
 570 succeeded, failed :: SuccessFlag -> Bool
 571 succeeded Succeeded = True
 572 succeeded Failed    = False
 573
 574 failed Succeeded = False
 575 failed Failed    = True
 576 \end{code}
 577
 578
 579 %************************************************************************
 580 %*                                                                      *
 581 \subsection{Activation}
 582 %*                                                                      *
 583 %************************************************************************
 584
 585 When a rule or inlining is active
 586
 587 \begin{code}
 588 type CompilerPhase = Int        -- Compilation phase
 589                                 -- Phases decrease towards zero
 590                                 -- Zero is the last phase
 591
 592 data Activation = NeverActive
 593                 | AlwaysActive
 594                 | ActiveBefore CompilerPhase    -- Active only *before* this phase
 595                 | ActiveAfter CompilerPhase     -- Active in this phase and later
 596                 deriving( Eq, Data, Typeable )                  -- Eq used in comparing rules in HsDecls
 597
 598 data RuleMatchInfo = ConLike                    -- See Note [CONLIKE pragma]
 599                    | FunLike
 600                    deriving( Eq, Data, Typeable )
 601
 602 data InlinePragma            -- Note [InlinePragma]
 603   = InlinePragma
 604       { inl_inline :: Bool           -- True <=> INLINE,
 605                                      -- False <=> no pragma at all, or NOINLINE
 606       , inl_sat    :: Maybe Arity    -- Just n <=> Inline only when applied to n
 607                                      --            explicit (non-type, non-dictionary) args
 608       , inl_act    :: Activation     -- Says during which phases inlining is allowed
 609       , inl_rule   :: RuleMatchInfo  -- Should the function be treated like a constructor?
 610     } deriving( Eq, Data, Typeable )
 611 \end{code}
 612
 613 Note [InlinePragma]
 614 ~~~~~~~~~~~~~~~~~~~
 615 This data type mirrors what you can write in an INLINE or NOINLINE pragma in
 616 the source program.
 617
 618 If you write nothing at all, you get defaultInlinePragma:
 619    inl_inline = False
 620    inl_act    = AlwaysActive
 621    inl_rule   = FunLike
 622
 623 It's not possible to get that combination by *writing* something, so
 624 if an Id has defaultInlinePragma it means the user didn't specify anything.
 625
 626 If inl_inline = True, then the Id should have an InlineRule unfolding.
 627
 628 Note [CONLIKE pragma]
 629 ~~~~~~~~~~~~~~~~~~~~~
 630 The ConLike constructor of a RuleMatchInfo is aimed at the following.
 631 Consider first
 632     {-# RULE "r/cons" forall a as. r (a:as) = f (a+1) #-}
 633     g b bs = let x = b:bs in ..x...x...(r x)...
 634 Now, the rule applies to the (r x) term, because GHC "looks through"
 635 the definition of 'x' to see that it is (b:bs).
 636
 637 Now consider
 638     {-# RULE "r/f" forall v. r (f v) = f (v+1) #-}
 639     g v = let x = f v in ..x...x...(r x)...
 640 Normally the (r x) would *not* match the rule, because GHC would be
 641 scared about duplicating the redex (f v), so it does not "look
 642 through" the bindings.
 643
 644 However the CONLIKE modifier says to treat 'f' like a constructor in
 645 this situation, and "look through" the unfolding for x.  So (r x)
 646 fires, yielding (f (v+1)).
 647
 648 This is all controlled with a user-visible pragma:
 649      {-# NOINLINE CONLIKE [1] f #-}
 650
 651 The main effects of CONLIKE are:
 652
 653     - The occurrence analyser (OccAnal) and simplifier (Simplify) treat
 654       CONLIKE thing like constructors, by ANF-ing them
 655
 656     - New function coreUtils.exprIsExpandable is like exprIsCheap, but
 657       additionally spots applications of CONLIKE functions
 658
 659     - A CoreUnfolding has a field that caches exprIsExpandable
 660
 661     - The rule matcher consults this field.  See
 662       Note [Expanding variables] in Rules.lhs.
 663
 664 \begin{code}
 665 isConLike :: RuleMatchInfo -> Bool
 666 isConLike ConLike = True
 667 isConLike _            = False
 668
 669 isFunLike :: RuleMatchInfo -> Bool
 670 isFunLike FunLike = True
 671 isFunLike _            = False
 672
 673 defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma
 674   :: InlinePragma
 675 defaultInlinePragma = InlinePragma { inl_act = AlwaysActive
 676                                    , inl_rule = FunLike
 677                                    , inl_inline = False
 678                                    , inl_sat = Nothing }
 679
 680 alwaysInlinePragma = defaultInlinePragma { inl_inline = True }
 681 neverInlinePragma  = defaultInlinePragma { inl_act    = NeverActive }
 682
 683 -- A DFun has an always-active inline activation so that
 684 -- exprIsConApp_maybe can "see" its unfolding
 685 -- (However, its actual Unfolding is a DFunUnfolding, which is
 686 --  never inlined other than via exprIsConApp_maybe.)
 687 dfunInlinePragma   = defaultInlinePragma { inl_act  = AlwaysActive
 688                                          , inl_rule = ConLike }
 689
 690 isDefaultInlinePragma :: InlinePragma -> Bool
 691 isDefaultInlinePragma (InlinePragma { inl_act = activation
 692                                     , inl_rule = match_info
 693                                     , inl_inline = inline })
 694   = not inline && isAlwaysActive activation && isFunLike match_info
 695
 696 isInlinePragma :: InlinePragma -> Bool
 697 isInlinePragma prag = inl_inline prag
 698
 699 inlinePragmaSat :: InlinePragma -> Maybe Arity
 700 inlinePragmaSat = inl_sat
 701
 702 inlinePragmaActivation :: InlinePragma -> Activation
 703 inlinePragmaActivation (InlinePragma { inl_act = activation }) = activation
 704
 705 inlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo
 706 inlinePragmaRuleMatchInfo (InlinePragma { inl_rule = info }) = info
 707
 708 setInlinePragmaActivation :: InlinePragma -> Activation -> InlinePragma
 709 setInlinePragmaActivation prag activation = prag { inl_act = activation }
 710
 711 setInlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo -> InlinePragma
 712 setInlinePragmaRuleMatchInfo prag info = prag { inl_rule = info }
 713
 714 instance Outputable Activation where
 715    ppr AlwaysActive     = brackets (ptext (sLit "ALWAYS"))
 716    ppr NeverActive      = brackets (ptext (sLit "NEVER"))
 717    ppr (ActiveBefore n) = brackets (char '~' <> int n)
 718    ppr (ActiveAfter n)  = brackets (int n)
 719
 720 instance Outputable RuleMatchInfo where
 721    ppr ConLike = ptext (sLit "CONLIKE")
 722    ppr FunLike = ptext (sLit "FUNLIKE")
 723
 724 instance Outputable InlinePragma where
 725   ppr (InlinePragma { inl_inline = inline, inl_act = activation
 726                     , inl_rule = info, inl_sat = mb_arity })
 727     = pp_inl_act (inline, activation) <+> pp_sat <+> pp_info
 728     where
 729       pp_inl_act (False, AlwaysActive)  = empty -- defaultInlinePragma
 730       pp_inl_act (False, NeverActive)   = ptext (sLit "NOINLINE")
 731       pp_inl_act (False, act)           = ptext (sLit "NOINLINE") <> ppr act
 732       pp_inl_act (True,  AlwaysActive)  = ptext (sLit "INLINE")
 733       pp_inl_act (True,  act)           = ptext (sLit "INLINE") <> ppr act
 734
 735       pp_sat | Just ar <- mb_arity = parens (ptext (sLit "sat-args=") <> int ar)
 736              | otherwise           = empty
 737       pp_info | isFunLike info = empty
 738               | otherwise      = ppr info
 739
 740 isActive :: CompilerPhase -> Activation -> Bool
 741 isActive _ NeverActive      = False
 742 isActive _ AlwaysActive     = True
 743 isActive p (ActiveAfter n)  = p <= n
 744 isActive p (ActiveBefore n) = p >  n
 745
 746 isNeverActive, isAlwaysActive, isEarlyActive :: Activation -> Bool
 747 isNeverActive NeverActive = True
 748 isNeverActive _           = False
 749
 750 isAlwaysActive AlwaysActive = True
 751 isAlwaysActive _            = False
 752
 753 isEarlyActive AlwaysActive      = True
 754 isEarlyActive (ActiveBefore {}) = True
 755 isEarlyActive _                 = False
 756 \end{code}
 757