99e6de645482c9bc6cd100f8ff61ef55d82df440
[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 ConTag, fIRST_TAG,
23
24 Arity, RepArity,
25
26 Alignment,
27
28 FunctionOrData(..),
29
30 WarningTxt(..),
31
32 Fixity(..), FixityDirection(..),
33 defaultFixity, maxPrecedence, minPrecedence,
34 negateFixity, funTyFixity,
35 compareFixity,
36
37 RecFlag(..), isRec, isNonRec, boolToRecFlag,
38 Origin(..), isGenerated,
39
40 RuleName,
41
42 TopLevelFlag(..), isTopLevel, isNotTopLevel,
43
44 OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe,
45 hasOverlappingFlag, hasOverlappableFlag,
46
47 Boxity(..), isBoxed,
48
49 TupleSort(..), tupleSortBoxity, boxityNormalTupleSort,
50 tupleParens,
51
52 -- ** The OneShotInfo type
53 OneShotInfo(..),
54 noOneShotInfo, hasNoOneShotInfo, isOneShotInfo,
55 bestOneShot, worstOneShot,
56
57 OccInfo(..), seqOccInfo, zapFragileOcc, isOneOcc,
58 isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker, isNoOcc,
59 strongLoopBreaker, weakLoopBreaker,
60
61 InsideLam, insideLam, notInsideLam,
62 OneBranch, oneBranch, notOneBranch,
63 InterestingCxt,
64
65 EP(..),
66
67 DefMethSpec(..),
68 SwapFlag(..), flipSwap, unSwap, isSwapped,
69
70 CompilerPhase(..), PhaseNum,
71 Activation(..), isActive, isActiveIn,
72 isNeverActive, isAlwaysActive, isEarlyActive,
73 RuleMatchInfo(..), isConLike, isFunLike,
74 InlineSpec(..), isEmptyInlineSpec,
75 InlinePragma(..), defaultInlinePragma, alwaysInlinePragma,
76 neverInlinePragma, dfunInlinePragma,
77 isDefaultInlinePragma,
78 isInlinePragma, isInlinablePragma, isAnyInlinePragma,
79 inlinePragmaSpec, inlinePragmaSat,
80 inlinePragmaActivation, inlinePragmaRuleMatchInfo,
81 setInlinePragmaActivation, setInlinePragmaRuleMatchInfo,
82
83 SuccessFlag(..), succeeded, failed, successIf,
84
85 FractionalLit(..), negateFractionalLit, integralFractionalLit,
86
87 HValue(..)
88 ) where
89
90 import FastString
91 import Outputable
92 import SrcLoc ( Located,unLoc )
93
94 import Data.Data hiding (Fixity)
95 import Data.Function (on)
96 import GHC.Exts (Any)
97
98 {-
99 ************************************************************************
100 * *
101 \subsection[Arity]{Arity}
102 * *
103 ************************************************************************
104 -}
105
106 -- | The number of value arguments that can be applied to a value before it does
107 -- "real work". So:
108 -- fib 100 has arity 0
109 -- \x -> fib x has arity 1
110 type Arity = Int
111
112 -- | The number of represented arguments that can be applied to a value before it does
113 -- "real work". So:
114 -- fib 100 has representation arity 0
115 -- \x -> fib x has representation arity 1
116 -- \(# x, y #) -> fib (x + y) has representation arity 2
117 type RepArity = Int
118
119 {-
120 ************************************************************************
121 * *
122 Constructor tags
123 * *
124 ************************************************************************
125 -}
126
127 -- | Type of the tags associated with each constructor possibility
128 type ConTag = Int
129
130 fIRST_TAG :: ConTag
131 -- ^ Tags are allocated from here for real constructors
132 fIRST_TAG = 1
133
134 {-
135 ************************************************************************
136 * *
137 \subsection[Alignment]{Alignment}
138 * *
139 ************************************************************************
140 -}
141
142 type Alignment = Int -- align to next N-byte boundary (N must be a power of 2).
143
144 {-
145 ************************************************************************
146 * *
147 One-shot information
148 * *
149 ************************************************************************
150 -}
151
152 -- | If the 'Id' is a lambda-bound variable then it may have lambda-bound
153 -- variable info. Sometimes we know whether the lambda binding this variable
154 -- is a \"one-shot\" lambda; that is, whether it is applied at most once.
155 --
156 -- This information may be useful in optimisation, as computations may
157 -- safely be floated inside such a lambda without risk of duplicating
158 -- work.
159 data OneShotInfo
160 = NoOneShotInfo -- ^ No information
161 | ProbOneShot -- ^ The lambda is probably applied at most once
162 -- See Note [Computing one-shot info, and ProbOneShot] in OccurAnl
163 | OneShotLam -- ^ The lambda is applied at most once.
164 deriving (Eq)
165
166 -- | It is always safe to assume that an 'Id' has no lambda-bound variable information
167 noOneShotInfo :: OneShotInfo
168 noOneShotInfo = NoOneShotInfo
169
170 isOneShotInfo, hasNoOneShotInfo :: OneShotInfo -> Bool
171 isOneShotInfo OneShotLam = True
172 isOneShotInfo _ = False
173
174 hasNoOneShotInfo NoOneShotInfo = True
175 hasNoOneShotInfo _ = False
176
177 worstOneShot, bestOneShot :: OneShotInfo -> OneShotInfo -> OneShotInfo
178 worstOneShot NoOneShotInfo _ = NoOneShotInfo
179 worstOneShot ProbOneShot NoOneShotInfo = NoOneShotInfo
180 worstOneShot ProbOneShot _ = ProbOneShot
181 worstOneShot OneShotLam os = os
182
183 bestOneShot NoOneShotInfo os = os
184 bestOneShot ProbOneShot OneShotLam = OneShotLam
185 bestOneShot ProbOneShot _ = ProbOneShot
186 bestOneShot OneShotLam _ = OneShotLam
187
188 pprOneShotInfo :: OneShotInfo -> SDoc
189 pprOneShotInfo NoOneShotInfo = empty
190 pprOneShotInfo ProbOneShot = ptext (sLit "ProbOneShot")
191 pprOneShotInfo OneShotLam = ptext (sLit "OneShot")
192
193 instance Outputable OneShotInfo where
194 ppr = pprOneShotInfo
195
196 {-
197 ************************************************************************
198 * *
199 Swap flag
200 * *
201 ************************************************************************
202 -}
203
204 data SwapFlag
205 = NotSwapped -- Args are: actual, expected
206 | IsSwapped -- Args are: expected, actual
207
208 instance Outputable SwapFlag where
209 ppr IsSwapped = ptext (sLit "Is-swapped")
210 ppr NotSwapped = ptext (sLit "Not-swapped")
211
212 flipSwap :: SwapFlag -> SwapFlag
213 flipSwap IsSwapped = NotSwapped
214 flipSwap NotSwapped = IsSwapped
215
216 isSwapped :: SwapFlag -> Bool
217 isSwapped IsSwapped = True
218 isSwapped NotSwapped = False
219
220 unSwap :: SwapFlag -> (a->a->b) -> a -> a -> b
221 unSwap NotSwapped f a b = f a b
222 unSwap IsSwapped f a b = f b a
223
224 {-
225 ************************************************************************
226 * *
227 \subsection[FunctionOrData]{FunctionOrData}
228 * *
229 ************************************************************************
230 -}
231
232 data FunctionOrData = IsFunction | IsData
233 deriving (Eq, Ord, Data, Typeable)
234
235 instance Outputable FunctionOrData where
236 ppr IsFunction = text "(function)"
237 ppr IsData = text "(data)"
238
239 {-
240 ************************************************************************
241 * *
242 \subsection[Version]{Module and identifier version numbers}
243 * *
244 ************************************************************************
245 -}
246
247 type Version = Int
248
249 bumpVersion :: Version -> Version
250 bumpVersion v = v+1
251
252 initialVersion :: Version
253 initialVersion = 1
254
255 {-
256 ************************************************************************
257 * *
258 Deprecations
259 * *
260 ************************************************************************
261 -}
262
263 -- reason/explanation from a WARNING or DEPRECATED pragma
264 data WarningTxt = WarningTxt [Located FastString]
265 | DeprecatedTxt [Located FastString]
266 deriving (Eq, Data, Typeable)
267
268 instance Outputable WarningTxt where
269 ppr (WarningTxt ws) = doubleQuotes (vcat (map (ftext . unLoc) ws))
270 ppr (DeprecatedTxt ds) = text "Deprecated:" <+>
271 doubleQuotes (vcat (map (ftext . unLoc) ds))
272
273 {-
274 ************************************************************************
275 * *
276 Rules
277 * *
278 ************************************************************************
279 -}
280
281 type RuleName = FastString
282
283 {-
284 ************************************************************************
285 * *
286 \subsection[Fixity]{Fixity info}
287 * *
288 ************************************************************************
289 -}
290
291 ------------------------
292 data Fixity = Fixity Int FixityDirection
293 deriving (Data, Typeable)
294
295 instance Outputable Fixity where
296 ppr (Fixity prec dir) = hcat [ppr dir, space, int prec]
297
298 instance Eq Fixity where -- Used to determine if two fixities conflict
299 (Fixity p1 dir1) == (Fixity p2 dir2) = p1==p2 && dir1 == dir2
300
301 ------------------------
302 data FixityDirection = InfixL | InfixR | InfixN
303 deriving (Eq, Data, Typeable)
304
305 instance Outputable FixityDirection where
306 ppr InfixL = ptext (sLit "infixl")
307 ppr InfixR = ptext (sLit "infixr")
308 ppr InfixN = ptext (sLit "infix")
309
310 ------------------------
311 maxPrecedence, minPrecedence :: Int
312 maxPrecedence = 9
313 minPrecedence = 0
314
315 defaultFixity :: Fixity
316 defaultFixity = Fixity maxPrecedence InfixL
317
318 negateFixity, funTyFixity :: Fixity
319 -- Wired-in fixities
320 negateFixity = Fixity 6 InfixL -- Fixity of unary negate
321 funTyFixity = Fixity 0 InfixR -- Fixity of '->'
322
323 {-
324 Consider
325
326 \begin{verbatim}
327 a `op1` b `op2` c
328 \end{verbatim}
329 @(compareFixity op1 op2)@ tells which way to arrange appication, or
330 whether there's an error.
331 -}
332
333 compareFixity :: Fixity -> Fixity
334 -> (Bool, -- Error please
335 Bool) -- Associate to the right: a op1 (b op2 c)
336 compareFixity (Fixity prec1 dir1) (Fixity prec2 dir2)
337 = case prec1 `compare` prec2 of
338 GT -> left
339 LT -> right
340 EQ -> case (dir1, dir2) of
341 (InfixR, InfixR) -> right
342 (InfixL, InfixL) -> left
343 _ -> error_please
344 where
345 right = (False, True)
346 left = (False, False)
347 error_please = (True, False)
348
349 {-
350 ************************************************************************
351 * *
352 \subsection[Top-level/local]{Top-level/not-top level flag}
353 * *
354 ************************************************************************
355 -}
356
357 data TopLevelFlag
358 = TopLevel
359 | NotTopLevel
360
361 isTopLevel, isNotTopLevel :: TopLevelFlag -> Bool
362
363 isNotTopLevel NotTopLevel = True
364 isNotTopLevel TopLevel = False
365
366 isTopLevel TopLevel = True
367 isTopLevel NotTopLevel = False
368
369 instance Outputable TopLevelFlag where
370 ppr TopLevel = ptext (sLit "<TopLevel>")
371 ppr NotTopLevel = ptext (sLit "<NotTopLevel>")
372
373 {-
374 ************************************************************************
375 * *
376 Boxity flag
377 * *
378 ************************************************************************
379 -}
380
381 data Boxity
382 = Boxed
383 | Unboxed
384 deriving( Eq, Data, Typeable )
385
386 isBoxed :: Boxity -> Bool
387 isBoxed Boxed = True
388 isBoxed Unboxed = False
389
390 {-
391 ************************************************************************
392 * *
393 Recursive/Non-Recursive flag
394 * *
395 ************************************************************************
396 -}
397
398 data RecFlag = Recursive
399 | NonRecursive
400 deriving( Eq, Data, Typeable )
401
402 isRec :: RecFlag -> Bool
403 isRec Recursive = True
404 isRec NonRecursive = False
405
406 isNonRec :: RecFlag -> Bool
407 isNonRec Recursive = False
408 isNonRec NonRecursive = True
409
410 boolToRecFlag :: Bool -> RecFlag
411 boolToRecFlag True = Recursive
412 boolToRecFlag False = NonRecursive
413
414 instance Outputable RecFlag where
415 ppr Recursive = ptext (sLit "Recursive")
416 ppr NonRecursive = ptext (sLit "NonRecursive")
417
418 {-
419 ************************************************************************
420 * *
421 Code origin
422 * *
423 ************************************************************************
424 -}
425
426 data Origin = FromSource
427 | Generated
428 deriving( Eq, Data, Typeable )
429
430 isGenerated :: Origin -> Bool
431 isGenerated Generated = True
432 isGenerated FromSource = False
433
434 instance Outputable Origin where
435 ppr FromSource = ptext (sLit "FromSource")
436 ppr Generated = ptext (sLit "Generated")
437
438 {-
439 ************************************************************************
440 * *
441 Instance overlap flag
442 * *
443 ************************************************************************
444 -}
445
446 -- | The semantics allowed for overlapping instances for a particular
447 -- instance. See Note [Safe Haskell isSafeOverlap] (in `InstEnv.lhs`) for a
448 -- explanation of the `isSafeOverlap` field.
449 data OverlapFlag = OverlapFlag
450 { overlapMode :: OverlapMode
451 , isSafeOverlap :: Bool
452 } deriving (Eq, Data, Typeable)
453
454 setOverlapModeMaybe :: OverlapFlag -> Maybe OverlapMode -> OverlapFlag
455 setOverlapModeMaybe f Nothing = f
456 setOverlapModeMaybe f (Just m) = f { overlapMode = m }
457
458 hasOverlappableFlag :: OverlapMode -> Bool
459 hasOverlappableFlag mode =
460 case mode of
461 Overlappable -> True
462 Overlaps -> True
463 Incoherent -> True
464 _ -> False
465
466 hasOverlappingFlag :: OverlapMode -> Bool
467 hasOverlappingFlag mode =
468 case mode of
469 Overlapping -> True
470 Overlaps -> True
471 Incoherent -> True
472 _ -> False
473
474 data OverlapMode -- See Note [Rules for instance lookup] in InstEnv
475 = NoOverlap
476 -- ^ This instance must not overlap another `NoOverlap` instance.
477 -- However, it may be overlapped by `Overlapping` instances,
478 -- and it may overlap `Overlappable` instances.
479
480
481 | Overlappable
482 -- ^ Silently ignore this instance if you find a
483 -- more specific one that matches the constraint
484 -- you are trying to resolve
485 --
486 -- Example: constraint (Foo [Int])
487 -- instance Foo [Int]
488 -- instance {-# OVERLAPPABLE #-} Foo [a]
489 --
490 -- Since the second instance has the Overlappable flag,
491 -- the first instance will be chosen (otherwise
492 -- its ambiguous which to choose)
493
494
495 | Overlapping
496 -- ^ Silently ignore any more general instances that may be
497 -- used to solve the constraint.
498 --
499 -- Example: constraint (Foo [Int])
500 -- instance {-# OVERLAPPING #-} Foo [Int]
501 -- instance Foo [a]
502 --
503 -- Since the first instance has the Overlapping flag,
504 -- the second---more general---instance will be ignored (otherwise
505 -- it is ambiguous which to choose)
506
507
508 | Overlaps
509 -- ^ Equivalent to having both `Overlapping` and `Overlappable` flags.
510
511 | Incoherent
512 -- ^ Behave like Overlappable and Overlapping, and in addition pick
513 -- an an arbitrary one if there are multiple matching candidates, and
514 -- don't worry about later instantiation
515 --
516 -- Example: constraint (Foo [b])
517 -- instance {-# INCOHERENT -} Foo [Int]
518 -- instance Foo [a]
519 -- Without the Incoherent flag, we'd complain that
520 -- instantiating 'b' would change which instance
521 -- was chosen. See also note [Incoherent instances] in InstEnv
522
523 deriving (Eq, Data, Typeable)
524
525
526 instance Outputable OverlapFlag where
527 ppr flag = ppr (overlapMode flag) <+> pprSafeOverlap (isSafeOverlap flag)
528
529 instance Outputable OverlapMode where
530 ppr NoOverlap = empty
531 ppr Overlappable = ptext (sLit "[overlappable]")
532 ppr Overlapping = ptext (sLit "[overlapping]")
533 ppr Overlaps = ptext (sLit "[overlap ok]")
534 ppr Incoherent = ptext (sLit "[incoherent]")
535
536 pprSafeOverlap :: Bool -> SDoc
537 pprSafeOverlap True = ptext $ sLit "[safe]"
538 pprSafeOverlap False = empty
539
540 {-
541 ************************************************************************
542 * *
543 Tuples
544 * *
545 ************************************************************************
546 -}
547
548 data TupleSort
549 = BoxedTuple
550 | UnboxedTuple
551 | ConstraintTuple
552 deriving( Eq, Data, Typeable )
553
554 tupleSortBoxity :: TupleSort -> Boxity
555 tupleSortBoxity BoxedTuple = Boxed
556 tupleSortBoxity UnboxedTuple = Unboxed
557 tupleSortBoxity ConstraintTuple = Boxed
558
559 boxityNormalTupleSort :: Boxity -> TupleSort
560 boxityNormalTupleSort Boxed = BoxedTuple
561 boxityNormalTupleSort Unboxed = UnboxedTuple
562
563 tupleParens :: TupleSort -> SDoc -> SDoc
564 tupleParens BoxedTuple p = parens p
565 tupleParens ConstraintTuple p = parens p -- The user can't write fact tuples
566 -- directly, we overload the (,,) syntax
567 tupleParens UnboxedTuple p = ptext (sLit "(#") <+> p <+> ptext (sLit "#)")
568
569 {-
570 ************************************************************************
571 * *
572 \subsection[Generic]{Generic flag}
573 * *
574 ************************************************************************
575
576 This is the "Embedding-Projection pair" datatype, it contains
577 two pieces of code (normally either RenamedExpr's or Id's)
578 If we have a such a pair (EP from to), the idea is that 'from' and 'to'
579 represents functions of type
580
581 from :: T -> Tring
582 to :: Tring -> T
583
584 And we should have
585
586 to (from x) = x
587
588 T and Tring are arbitrary, but typically T is the 'main' type while
589 Tring is the 'representation' type. (This just helps us remember
590 whether to use 'from' or 'to'.
591 -}
592
593 data EP a = EP { fromEP :: a, -- :: T -> Tring
594 toEP :: a } -- :: Tring -> T
595
596 {-
597 Embedding-projection pairs are used in several places:
598
599 First of all, each type constructor has an EP associated with it, the
600 code in EP converts (datatype T) from T to Tring and back again.
601
602 Secondly, when we are filling in Generic methods (in the typechecker,
603 tcMethodBinds), we are constructing bimaps by induction on the structure
604 of the type of the method signature.
605
606
607 ************************************************************************
608 * *
609 \subsection{Occurrence information}
610 * *
611 ************************************************************************
612
613 This data type is used exclusively by the simplifier, but it appears in a
614 SubstResult, which is currently defined in VarEnv, which is pretty near
615 the base of the module hierarchy. So it seemed simpler to put the
616 defn of OccInfo here, safely at the bottom
617 -}
618
619 -- | Identifier occurrence information
620 data OccInfo
621 = NoOccInfo -- ^ There are many occurrences, or unknown occurrences
622
623 | IAmDead -- ^ Marks unused variables. Sometimes useful for
624 -- lambda and case-bound variables.
625
626 | OneOcc
627 !InsideLam
628 !OneBranch
629 !InterestingCxt -- ^ Occurs exactly once, not inside a rule
630
631 -- | This identifier breaks a loop of mutually recursive functions. The field
632 -- marks whether it is only a loop breaker due to a reference in a rule
633 | IAmALoopBreaker -- Note [LoopBreaker OccInfo]
634 !RulesOnly
635
636 deriving (Eq)
637
638 type RulesOnly = Bool
639
640 {-
641 Note [LoopBreaker OccInfo]
642 ~~~~~~~~~~~~~~~~~~~~~~~~~~
643 IAmALoopBreaker True <=> A "weak" or rules-only loop breaker
644 Do not preInlineUnconditionally
645
646 IAmALoopBreaker False <=> A "strong" loop breaker
647 Do not inline at all
648
649 See OccurAnal Note [Weak loop breakers]
650 -}
651
652 isNoOcc :: OccInfo -> Bool
653 isNoOcc NoOccInfo = True
654 isNoOcc _ = False
655
656 seqOccInfo :: OccInfo -> ()
657 seqOccInfo occ = occ `seq` ()
658
659 -----------------
660 type InterestingCxt = Bool -- True <=> Function: is applied
661 -- Data value: scrutinised by a case with
662 -- at least one non-DEFAULT branch
663
664 -----------------
665 type InsideLam = Bool -- True <=> Occurs inside a non-linear lambda
666 -- Substituting a redex for this occurrence is
667 -- dangerous because it might duplicate work.
668 insideLam, notInsideLam :: InsideLam
669 insideLam = True
670 notInsideLam = False
671
672 -----------------
673 type OneBranch = Bool -- True <=> Occurs in only one case branch
674 -- so no code-duplication issue to worry about
675 oneBranch, notOneBranch :: OneBranch
676 oneBranch = True
677 notOneBranch = False
678
679 strongLoopBreaker, weakLoopBreaker :: OccInfo
680 strongLoopBreaker = IAmALoopBreaker False
681 weakLoopBreaker = IAmALoopBreaker True
682
683 isWeakLoopBreaker :: OccInfo -> Bool
684 isWeakLoopBreaker (IAmALoopBreaker _) = True
685 isWeakLoopBreaker _ = False
686
687 isStrongLoopBreaker :: OccInfo -> Bool
688 isStrongLoopBreaker (IAmALoopBreaker False) = True -- Loop-breaker that breaks a non-rule cycle
689 isStrongLoopBreaker _ = False
690
691 isDeadOcc :: OccInfo -> Bool
692 isDeadOcc IAmDead = True
693 isDeadOcc _ = False
694
695 isOneOcc :: OccInfo -> Bool
696 isOneOcc (OneOcc {}) = True
697 isOneOcc _ = False
698
699 zapFragileOcc :: OccInfo -> OccInfo
700 zapFragileOcc (OneOcc {}) = NoOccInfo
701 zapFragileOcc occ = occ
702
703 instance Outputable OccInfo where
704 -- only used for debugging; never parsed. KSW 1999-07
705 ppr NoOccInfo = empty
706 ppr (IAmALoopBreaker ro) = ptext (sLit "LoopBreaker") <> if ro then char '!' else empty
707 ppr IAmDead = ptext (sLit "Dead")
708 ppr (OneOcc inside_lam one_branch int_cxt)
709 = ptext (sLit "Once") <> pp_lam <> pp_br <> pp_args
710 where
711 pp_lam | inside_lam = char 'L'
712 | otherwise = empty
713 pp_br | one_branch = empty
714 | otherwise = char '*'
715 pp_args | int_cxt = char '!'
716 | otherwise = empty
717
718 {-
719 ************************************************************************
720 * *
721 Default method specfication
722 * *
723 ************************************************************************
724
725 The DefMethSpec enumeration just indicates what sort of default method
726 is used for a class. It is generated from source code, and present in
727 interface files; it is converted to Class.DefMeth before begin put in a
728 Class object.
729 -}
730
731 data DefMethSpec = NoDM -- No default method
732 | VanillaDM -- Default method given with polymorphic code
733 | GenericDM -- Default method given with generic code
734 deriving Eq
735
736 instance Outputable DefMethSpec where
737 ppr NoDM = empty
738 ppr VanillaDM = ptext (sLit "{- Has default method -}")
739 ppr GenericDM = ptext (sLit "{- Has generic default method -}")
740
741 {-
742 ************************************************************************
743 * *
744 \subsection{Success flag}
745 * *
746 ************************************************************************
747 -}
748
749 data SuccessFlag = Succeeded | Failed
750
751 instance Outputable SuccessFlag where
752 ppr Succeeded = ptext (sLit "Succeeded")
753 ppr Failed = ptext (sLit "Failed")
754
755 successIf :: Bool -> SuccessFlag
756 successIf True = Succeeded
757 successIf False = Failed
758
759 succeeded, failed :: SuccessFlag -> Bool
760 succeeded Succeeded = True
761 succeeded Failed = False
762
763 failed Succeeded = False
764 failed Failed = True
765
766 {-
767 ************************************************************************
768 * *
769 \subsection{Activation}
770 * *
771 ************************************************************************
772
773 When a rule or inlining is active
774 -}
775
776 type PhaseNum = Int -- Compilation phase
777 -- Phases decrease towards zero
778 -- Zero is the last phase
779
780 data CompilerPhase
781 = Phase PhaseNum
782 | InitialPhase -- The first phase -- number = infinity!
783
784 instance Outputable CompilerPhase where
785 ppr (Phase n) = int n
786 ppr InitialPhase = ptext (sLit "InitialPhase")
787
788 data Activation = NeverActive
789 | AlwaysActive
790 | ActiveBefore PhaseNum -- Active only *before* this phase
791 | ActiveAfter PhaseNum -- Active in this phase and later
792 deriving( Eq, Data, Typeable ) -- Eq used in comparing rules in HsDecls
793
794 data RuleMatchInfo = ConLike -- See Note [CONLIKE pragma]
795 | FunLike
796 deriving( Eq, Data, Typeable, Show )
797 -- Show needed for Lexer.x
798
799 data InlinePragma -- Note [InlinePragma]
800 = InlinePragma
801 { inl_inline :: InlineSpec
802
803 , inl_sat :: Maybe Arity -- Just n <=> Inline only when applied to n
804 -- explicit (non-type, non-dictionary) args
805 -- That is, inl_sat describes the number of *source-code*
806 -- arguments the thing must be applied to. We add on the
807 -- number of implicit, dictionary arguments when making
808 -- the InlineRule, and don't look at inl_sat further
809
810 , inl_act :: Activation -- Says during which phases inlining is allowed
811
812 , inl_rule :: RuleMatchInfo -- Should the function be treated like a constructor?
813 } deriving( Eq, Data, Typeable )
814
815 data InlineSpec -- What the user's INLINE pragma looked like
816 = Inline
817 | Inlinable
818 | NoInline
819 | EmptyInlineSpec -- Used in a place-holder InlinePragma in SpecPrag or IdInfo,
820 -- where there isn't any real inline pragma at all
821 deriving( Eq, Data, Typeable, Show )
822 -- Show needed for Lexer.x
823
824 {-
825 Note [InlinePragma]
826 ~~~~~~~~~~~~~~~~~~~
827 This data type mirrors what you can write in an INLINE or NOINLINE pragma in
828 the source program.
829
830 If you write nothing at all, you get defaultInlinePragma:
831 inl_inline = False
832 inl_act = AlwaysActive
833 inl_rule = FunLike
834
835 It's not possible to get that combination by *writing* something, so
836 if an Id has defaultInlinePragma it means the user didn't specify anything.
837
838 If inl_inline = True, then the Id should have an InlineRule unfolding.
839
840 Note [CONLIKE pragma]
841 ~~~~~~~~~~~~~~~~~~~~~
842 The ConLike constructor of a RuleMatchInfo is aimed at the following.
843 Consider first
844 {-# RULE "r/cons" forall a as. r (a:as) = f (a+1) #-}
845 g b bs = let x = b:bs in ..x...x...(r x)...
846 Now, the rule applies to the (r x) term, because GHC "looks through"
847 the definition of 'x' to see that it is (b:bs).
848
849 Now consider
850 {-# RULE "r/f" forall v. r (f v) = f (v+1) #-}
851 g v = let x = f v in ..x...x...(r x)...
852 Normally the (r x) would *not* match the rule, because GHC would be
853 scared about duplicating the redex (f v), so it does not "look
854 through" the bindings.
855
856 However the CONLIKE modifier says to treat 'f' like a constructor in
857 this situation, and "look through" the unfolding for x. So (r x)
858 fires, yielding (f (v+1)).
859
860 This is all controlled with a user-visible pragma:
861 {-# NOINLINE CONLIKE [1] f #-}
862
863 The main effects of CONLIKE are:
864
865 - The occurrence analyser (OccAnal) and simplifier (Simplify) treat
866 CONLIKE thing like constructors, by ANF-ing them
867
868 - New function coreUtils.exprIsExpandable is like exprIsCheap, but
869 additionally spots applications of CONLIKE functions
870
871 - A CoreUnfolding has a field that caches exprIsExpandable
872
873 - The rule matcher consults this field. See
874 Note [Expanding variables] in Rules.lhs.
875 -}
876
877 isConLike :: RuleMatchInfo -> Bool
878 isConLike ConLike = True
879 isConLike _ = False
880
881 isFunLike :: RuleMatchInfo -> Bool
882 isFunLike FunLike = True
883 isFunLike _ = False
884
885 isEmptyInlineSpec :: InlineSpec -> Bool
886 isEmptyInlineSpec EmptyInlineSpec = True
887 isEmptyInlineSpec _ = False
888
889 defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma
890 :: InlinePragma
891 defaultInlinePragma = InlinePragma { inl_act = AlwaysActive
892 , inl_rule = FunLike
893 , inl_inline = EmptyInlineSpec
894 , inl_sat = Nothing }
895
896 alwaysInlinePragma = defaultInlinePragma { inl_inline = Inline }
897 neverInlinePragma = defaultInlinePragma { inl_act = NeverActive }
898
899 inlinePragmaSpec :: InlinePragma -> InlineSpec
900 inlinePragmaSpec = inl_inline
901
902 -- A DFun has an always-active inline activation so that
903 -- exprIsConApp_maybe can "see" its unfolding
904 -- (However, its actual Unfolding is a DFunUnfolding, which is
905 -- never inlined other than via exprIsConApp_maybe.)
906 dfunInlinePragma = defaultInlinePragma { inl_act = AlwaysActive
907 , inl_rule = ConLike }
908
909 isDefaultInlinePragma :: InlinePragma -> Bool
910 isDefaultInlinePragma (InlinePragma { inl_act = activation
911 , inl_rule = match_info
912 , inl_inline = inline })
913 = isEmptyInlineSpec inline && isAlwaysActive activation && isFunLike match_info
914
915 isInlinePragma :: InlinePragma -> Bool
916 isInlinePragma prag = case inl_inline prag of
917 Inline -> True
918 _ -> False
919
920 isInlinablePragma :: InlinePragma -> Bool
921 isInlinablePragma prag = case inl_inline prag of
922 Inlinable -> True
923 _ -> False
924
925 isAnyInlinePragma :: InlinePragma -> Bool
926 -- INLINE or INLINABLE
927 isAnyInlinePragma prag = case inl_inline prag of
928 Inline -> True
929 Inlinable -> True
930 _ -> False
931
932 inlinePragmaSat :: InlinePragma -> Maybe Arity
933 inlinePragmaSat = inl_sat
934
935 inlinePragmaActivation :: InlinePragma -> Activation
936 inlinePragmaActivation (InlinePragma { inl_act = activation }) = activation
937
938 inlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo
939 inlinePragmaRuleMatchInfo (InlinePragma { inl_rule = info }) = info
940
941 setInlinePragmaActivation :: InlinePragma -> Activation -> InlinePragma
942 setInlinePragmaActivation prag activation = prag { inl_act = activation }
943
944 setInlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo -> InlinePragma
945 setInlinePragmaRuleMatchInfo prag info = prag { inl_rule = info }
946
947 instance Outputable Activation where
948 ppr AlwaysActive = brackets (ptext (sLit "ALWAYS"))
949 ppr NeverActive = brackets (ptext (sLit "NEVER"))
950 ppr (ActiveBefore n) = brackets (char '~' <> int n)
951 ppr (ActiveAfter n) = brackets (int n)
952
953 instance Outputable RuleMatchInfo where
954 ppr ConLike = ptext (sLit "CONLIKE")
955 ppr FunLike = ptext (sLit "FUNLIKE")
956
957 instance Outputable InlineSpec where
958 ppr Inline = ptext (sLit "INLINE")
959 ppr NoInline = ptext (sLit "NOINLINE")
960 ppr Inlinable = ptext (sLit "INLINABLE")
961 ppr EmptyInlineSpec = empty
962
963 instance Outputable InlinePragma where
964 ppr (InlinePragma { inl_inline = inline, inl_act = activation
965 , inl_rule = info, inl_sat = mb_arity })
966 = ppr inline <> pp_act inline activation <+> pp_sat <+> pp_info
967 where
968 pp_act Inline AlwaysActive = empty
969 pp_act NoInline NeverActive = empty
970 pp_act _ act = ppr act
971
972 pp_sat | Just ar <- mb_arity = parens (ptext (sLit "sat-args=") <> int ar)
973 | otherwise = empty
974 pp_info | isFunLike info = empty
975 | otherwise = ppr info
976
977 isActive :: CompilerPhase -> Activation -> Bool
978 isActive InitialPhase AlwaysActive = True
979 isActive InitialPhase (ActiveBefore {}) = True
980 isActive InitialPhase _ = False
981 isActive (Phase p) act = isActiveIn p act
982
983 isActiveIn :: PhaseNum -> Activation -> Bool
984 isActiveIn _ NeverActive = False
985 isActiveIn _ AlwaysActive = True
986 isActiveIn p (ActiveAfter n) = p <= n
987 isActiveIn p (ActiveBefore n) = p > n
988
989 isNeverActive, isAlwaysActive, isEarlyActive :: Activation -> Bool
990 isNeverActive NeverActive = True
991 isNeverActive _ = False
992
993 isAlwaysActive AlwaysActive = True
994 isAlwaysActive _ = False
995
996 isEarlyActive AlwaysActive = True
997 isEarlyActive (ActiveBefore {}) = True
998 isEarlyActive _ = False
999
1000 -- Used (instead of Rational) to represent exactly the floating point literal that we
1001 -- encountered in the user's source program. This allows us to pretty-print exactly what
1002 -- the user wrote, which is important e.g. for floating point numbers that can't represented
1003 -- as Doubles (we used to via Double for pretty-printing). See also #2245.
1004 data FractionalLit
1005 = FL { fl_text :: String -- How the value was written in the source
1006 , fl_value :: Rational -- Numeric value of the literal
1007 }
1008 deriving (Data, Typeable, Show)
1009 -- The Show instance is required for the derived Lexer.x:Token instance when DEBUG is on
1010
1011 negateFractionalLit :: FractionalLit -> FractionalLit
1012 negateFractionalLit (FL { fl_text = '-':text, fl_value = value }) = FL { fl_text = text, fl_value = negate value }
1013 negateFractionalLit (FL { fl_text = text, fl_value = value }) = FL { fl_text = '-':text, fl_value = negate value }
1014
1015 integralFractionalLit :: Integer -> FractionalLit
1016 integralFractionalLit i = FL { fl_text = show i, fl_value = fromInteger i }
1017
1018 -- Comparison operations are needed when grouping literals
1019 -- for compiling pattern-matching (module MatchLit)
1020
1021 instance Eq FractionalLit where
1022 (==) = (==) `on` fl_value
1023
1024 instance Ord FractionalLit where
1025 compare = compare `on` fl_value
1026
1027 instance Outputable FractionalLit where
1028 ppr = text . fl_text
1029
1030 newtype HValue = HValue Any