BasicTypes.lhs 28.1 KB
Newer Older
sof's avatar
sof committed
1
%
Simon Marlow's avatar
Simon Marlow committed
2
% (c) The University of Glasgow 2006
3
% (c) The GRASP/AQUA Project, Glasgow University, 1997-1998
sof's avatar
sof committed
4
5
6
7
8
9
10
11
12
13
14
15
16
%
\section[BasicTypes]{Miscellanous types}

This module defines a miscellaneously collection of very simple
types that

\begin{itemize}
\item have no other obvious home
\item don't depend on any other complicated types
\item are used in more than one "part" of the compiler
\end{itemize}

\begin{code}
17
18
{-# LANGUAGE DeriveDataTypeable #-}

sof's avatar
sof committed
19
module BasicTypes(
20
	Version, bumpVersion, initialVersion,
21

22
23
24
	Arity,
	
	Alignment,
25

26
        FunctionOrData(..),
27
	
Ian Lynagh's avatar
Ian Lynagh committed
28
	WarningTxt(..),
29

30
	Fixity(..), FixityDirection(..),
31
	defaultFixity, maxPrecedence, 
32
	negateFixity, funTyFixity,
33
	compareFixity,
34

35
36
	IPName(..), ipNameName, mapIPName,

37
	RecFlag(..), isRec, isNonRec, boolToRecFlag,
38

39
40
	RuleName,

41
42
	TopLevelFlag(..), isTopLevel, isNotTopLevel,

43
44
	OverlapFlag(..), 

45
46
	Boxity(..), isBoxed, 

batterseapower's avatar
batterseapower committed
47
48
        TupleSort(..), tupleSortBoxity, boxityNormalTupleSort,
        tupleParens,
49

50
	OccInfo(..), seqOccInfo, zapFragileOcc, isOneOcc, 
51
52
	isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker, isNoOcc,
        strongLoopBreaker, weakLoopBreaker, 
53

54
	InsideLam, insideLam, notInsideLam,
55
	OneBranch, oneBranch, notOneBranch,
56
	InterestingCxt,
57

58
59
        EP(..),

60
61
	HsBang(..), isBanged, isMarkedUnboxed, 
        StrictnessMark(..), isMarkedStrict,
62

63
64
	DefMethSpec(..),

65
66
67
        CompilerPhase(..), PhaseNum,
        Activation(..), isActive, isActiveIn,
        isNeverActive, isAlwaysActive, isEarlyActive,
68
        RuleMatchInfo(..), isConLike, isFunLike, 
69
70
71
        InlineSpec(..), 
        InlinePragma(..), defaultInlinePragma, alwaysInlinePragma, 
        neverInlinePragma, dfunInlinePragma, 
72
73
	isDefaultInlinePragma, 
        isInlinePragma, isInlinablePragma, isAnyInlinePragma,
74
        inlinePragmaSpec, inlinePragmaSat,
75
76
        inlinePragmaActivation, inlinePragmaRuleMatchInfo,
        setInlinePragmaActivation, setInlinePragmaRuleMatchInfo,
77

78
79
	SuccessFlag(..), succeeded, failed, successIf,
	
80
	FractionalLit(..), negateFractionalLit, integralFractionalLit
sof's avatar
sof committed
81
82
   ) where

83
import FastString
sof's avatar
sof committed
84
import Outputable
85
86

import Data.Data hiding (Fixity)
87
import Data.Function (on)
88
89
\end{code}

sof's avatar
sof committed
90
91
92
93
94
95
96
97
98
99
%************************************************************************
%*									*
\subsection[Arity]{Arity}
%*									*
%************************************************************************

\begin{code}
type Arity = Int
\end{code}

100
101
102
103
104
105
106
107
108
109
%************************************************************************
%*									*
\subsection[Alignment]{Alignment}
%*									*
%************************************************************************

\begin{code}
type Alignment = Int -- align to next N-byte boundary (N must be a power of 2).
\end{code}

110
111
112
113
114
115
116
117
%************************************************************************
%*									*
\subsection[FunctionOrData]{FunctionOrData}
%*									*
%************************************************************************

\begin{code}
data FunctionOrData = IsFunction | IsData
118
    deriving (Eq, Ord, Data, Typeable)
119
120
121
122
123
124

instance Outputable FunctionOrData where
    ppr IsFunction = text "(function)"
    ppr IsData     = text "(data)"
\end{code}

sof's avatar
sof committed
125
126
127
128
129
130
131
132
133

%************************************************************************
%*									*
\subsection[Version]{Module and identifier version numbers}
%*									*
%************************************************************************

\begin{code}
type Version = Int
134

135
136
bumpVersion :: Version -> Version 
bumpVersion v = v+1
137
138
139

initialVersion :: Version
initialVersion = 1
sof's avatar
sof committed
140
141
\end{code}

142
143
144
145
146
147
148
149
%************************************************************************
%*									*
		Deprecations
%*									*
%************************************************************************


\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
150
-- reason/explanation from a WARNING or DEPRECATED pragma
151
152
data WarningTxt = WarningTxt [FastString]
                | DeprecatedTxt [FastString]
153
    deriving (Eq, Data, Typeable)
Ian Lynagh's avatar
Ian Lynagh committed
154
155

instance Outputable WarningTxt where
156
157
158
    ppr (WarningTxt    ws) = doubleQuotes (vcat (map ftext ws))
    ppr (DeprecatedTxt ds) = text "Deprecated:" <+>
                             doubleQuotes (vcat (map ftext ds))
159
\end{code}
sof's avatar
sof committed
160

161
162
163
164
165
166
167
168
169
170
%************************************************************************
%*									*
\subsection{Implicit parameter identity}
%*									*
%************************************************************************

The @IPName@ type is here because it is used in TypeRep (i.e. very
early in the hierarchy), but also in HsSyn.

\begin{code}
171
newtype IPName name = IPName name	-- ?x
batterseapower's avatar
batterseapower committed
172
173
174
175
  deriving( Eq, Data, Typeable )

instance Functor IPName where
    fmap = mapIPName
176
177

ipNameName :: IPName name -> name
178
ipNameName (IPName n) = n
179
180

mapIPName :: (a->b) -> IPName a -> IPName b
181
mapIPName f (IPName n) = IPName (f n)
182
183

instance Outputable name => Outputable (IPName name) where
184
    ppr (IPName n) = char '?' <> ppr n -- Ordinary implicit parameters
185
186
\end{code}

187
188
189
190
191
192
193
194
195
%************************************************************************
%*									*
		Rules
%*									*
%************************************************************************

\begin{code}
type RuleName = FastString
\end{code}
196

sof's avatar
sof committed
197
198
199
200
201
202
203
%************************************************************************
%*									*
\subsection[Fixity]{Fixity info}
%*									*
%************************************************************************

\begin{code}
204
------------------------
sof's avatar
sof committed
205
data Fixity = Fixity Int FixityDirection
206
  deriving (Data, Typeable)
sof's avatar
sof committed
207
208

instance Outputable Fixity where
209
    ppr (Fixity prec dir) = hcat [ppr dir, space, int prec]
sof's avatar
sof committed
210

211
212
213
214
215
instance Eq Fixity where		-- Used to determine if two fixities conflict
  (Fixity p1 dir1) == (Fixity p2 dir2) = p1==p2 && dir1 == dir2

------------------------
data FixityDirection = InfixL | InfixR | InfixN 
216
		     deriving (Eq, Data, Typeable)
217

sof's avatar
sof committed
218
instance Outputable FixityDirection where
Ian Lynagh's avatar
Ian Lynagh committed
219
220
221
    ppr InfixL = ptext (sLit "infixl")
    ppr InfixR = ptext (sLit "infixr")
    ppr InfixN = ptext (sLit "infix")
sof's avatar
sof committed
222

223
------------------------
224
225
226
maxPrecedence :: Int
maxPrecedence = 9
defaultFixity :: Fixity
sof's avatar
sof committed
227
defaultFixity = Fixity maxPrecedence InfixL
228

229
230
231
232
negateFixity, funTyFixity :: Fixity
-- Wired-in fixities
negateFixity = Fixity 6 InfixL 	-- Fixity of unary negate
funTyFixity  = Fixity 0	InfixR	-- Fixity of '->'
sof's avatar
sof committed
233
234
\end{code}

235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
Consider

\begin{verbatim}
	a `op1` b `op2` c
\end{verbatim}
@(compareFixity op1 op2)@ tells which way to arrange appication, or
whether there's an error.

\begin{code}
compareFixity :: Fixity -> Fixity
	      -> (Bool,		-- Error please
		  Bool)		-- Associate to the right: a op1 (b op2 c)
compareFixity (Fixity prec1 dir1) (Fixity prec2 dir2)
  = case prec1 `compare` prec2 of
	GT -> left
	LT -> right
	EQ -> case (dir1, dir2) of
			(InfixR, InfixR) -> right
			(InfixL, InfixL) -> left
			_		 -> error_please
  where
    right	 = (False, True)
    left         = (False, False)
    error_please = (True,  False)
\end{code}

sof's avatar
sof committed
261

262
263
264
265
266
267
268
269
270
271
%************************************************************************
%*									*
\subsection[Top-level/local]{Top-level/not-top level flag}
%*									*
%************************************************************************

\begin{code}
data TopLevelFlag
  = TopLevel
  | NotTopLevel
272
273
274
275
276
277
278
279

isTopLevel, isNotTopLevel :: TopLevelFlag -> Bool

isNotTopLevel NotTopLevel = True
isNotTopLevel TopLevel    = False

isTopLevel TopLevel	= True
isTopLevel NotTopLevel  = False
280
281

instance Outputable TopLevelFlag where
Ian Lynagh's avatar
Ian Lynagh committed
282
283
  ppr TopLevel    = ptext (sLit "<TopLevel>")
  ppr NotTopLevel = ptext (sLit "<NotTopLevel>")
284
285
\end{code}

286

287
288
%************************************************************************
%*									*
batterseapower's avatar
batterseapower committed
289
		Boxity flag
290
291
292
293
294
295
296
%*									*
%************************************************************************

\begin{code}
data Boxity
  = Boxed
  | Unboxed
297
  deriving( Eq, Data, Typeable )
298
299
300
301
302
303
304

isBoxed :: Boxity -> Bool
isBoxed Boxed   = True
isBoxed Unboxed = False
\end{code}


305
306
%************************************************************************
%*									*
307
		Recursive/Non-Recursive flag
308
309
310
%*									*
%************************************************************************

311
\begin{code}
sof's avatar
sof committed
312
313
data RecFlag = Recursive 
	     | NonRecursive
314
	     deriving( Eq, Data, Typeable )
sof's avatar
sof committed
315

316
317
318
isRec :: RecFlag -> Bool
isRec Recursive    = True
isRec NonRecursive = False
sof's avatar
sof committed
319

320
321
322
isNonRec :: RecFlag -> Bool
isNonRec Recursive    = False
isNonRec NonRecursive = True
323
324
325
326
327
328

boolToRecFlag :: Bool -> RecFlag
boolToRecFlag True  = Recursive
boolToRecFlag False = NonRecursive

instance Outputable RecFlag where
Ian Lynagh's avatar
Ian Lynagh committed
329
330
  ppr Recursive    = ptext (sLit "Recursive")
  ppr NonRecursive = ptext (sLit "NonRecursive")
331
332
333
\end{code}

%************************************************************************
334
335
336
337
338
339
340
%*									*
		Instance overlap flag
%*									*
%************************************************************************

\begin{code}
data OverlapFlag
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
  -- | This instance must not overlap another
  = NoOverlap { isSafeOverlap :: Bool }

  -- | Silently ignore this instance if you find a 
  -- more specific one that matches the constraint
  -- you are trying to resolve
  --
  -- Example: constraint (Foo [Int])
  -- 	    instances  (Foo [Int])
  --		       (Foo [a])	OverlapOk
  -- Since the second instance has the OverlapOk flag,
  -- the first instance will be chosen (otherwise 
  -- its ambiguous which to choose)
  | OverlapOk { isSafeOverlap :: Bool }

  -- | Like OverlapOk, but also ignore this instance 
  -- if it doesn't match the constraint you are
  -- trying to resolve, but could match if the type variables
  -- in the constraint were instantiated
  --
  -- Example: constraint (Foo [b])
  --	    instances  (Foo [Int])	Incoherent
  --		       (Foo [a])
  -- Without the Incoherent flag, we'd complain that
  -- instantiating 'b' would change which instance 
  -- was chosen
  | Incoherent { isSafeOverlap :: Bool }
368
  deriving( Eq )
369
370

instance Outputable OverlapFlag where
371
372
373
   ppr (NoOverlap  b) = empty <+> pprSafeOverlap b
   ppr (OverlapOk  b) = ptext (sLit "[overlap ok]") <+> pprSafeOverlap b
   ppr (Incoherent b) = ptext (sLit "[incoherent]") <+> pprSafeOverlap b
374

375
376
377
pprSafeOverlap :: Bool -> SDoc
pprSafeOverlap True  = ptext $ sLit "[safe]"
pprSafeOverlap False = empty
378
379
380
\end{code}

%************************************************************************
381
382
383
384
385
386
%*									*
		Tuples
%*									*
%************************************************************************

\begin{code}
batterseapower's avatar
batterseapower committed
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
data TupleSort
  = BoxedTuple
  | UnboxedTuple
  | FactTuple
  deriving( Eq, Data, Typeable )

tupleSortBoxity :: TupleSort -> Boxity
tupleSortBoxity BoxedTuple   = Boxed
tupleSortBoxity UnboxedTuple = Unboxed
tupleSortBoxity FactTuple    = Boxed

boxityNormalTupleSort :: Boxity -> TupleSort
boxityNormalTupleSort Boxed   = BoxedTuple
boxityNormalTupleSort Unboxed = UnboxedTuple

tupleParens :: TupleSort -> SDoc -> SDoc
tupleParens BoxedTuple   p = parens p
tupleParens FactTuple    p = parens p -- The user can't write fact tuples directly, we overload the (,,) syntax
tupleParens UnboxedTuple p = ptext (sLit "(#") <+> p <+> ptext (sLit "#)")
sof's avatar
sof committed
406
\end{code}
407

408
409
410
411
412
413
414
%************************************************************************
%*									*
\subsection[Generic]{Generic flag}
%*									*
%************************************************************************

This is the "Embedding-Projection pair" datatype, it contains 
415
two pieces of code (normally either RenamedExpr's or Id's)
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
If we have a such a pair (EP from to), the idea is that 'from' and 'to'
represents functions of type 

	from :: T -> Tring
	to   :: Tring -> T

And we should have 

	to (from x) = x

T and Tring are arbitrary, but typically T is the 'main' type while
Tring is the 'representation' type.  (This just helps us remember 
whether to use 'from' or 'to'.

\begin{code}
data EP a = EP { fromEP :: a,	-- :: T -> Tring
		 toEP   :: a }	-- :: Tring -> T
\end{code}

Embedding-projection pairs are used in several places:

First of all, each type constructor has an EP associated with it, the
code in EP converts (datatype T) from T to Tring and back again.

Secondly, when we are filling in Generic methods (in the typechecker, 
tcMethodBinds), we are constructing bimaps by induction on the structure
of the type of the method signature.

444
445
446
447
448
449
450
451
452
453
454
455
456

%************************************************************************
%*									*
\subsection{Occurrence information}
%*									*
%************************************************************************

This data type is used exclusively by the simplifier, but it appears in a
SubstResult, which is currently defined in VarEnv, which is pretty near
the base of the module hierarchy.  So it seemed simpler to put the
defn of OccInfo here, safely at the bottom

\begin{code}
batterseapower's avatar
batterseapower committed
457
-- | Identifier occurrence information
458
data OccInfo 
batterseapower's avatar
batterseapower committed
459
  = NoOccInfo		-- ^ There are many occurrences, or unknown occurences
460

batterseapower's avatar
batterseapower committed
461
  | IAmDead		-- ^ Marks unused variables.  Sometimes useful for
462
463
			-- lambda and case-bound variables.

batterseapower's avatar
batterseapower committed
464
  | OneOcc
465
466
	!InsideLam
 	!OneBranch
batterseapower's avatar
batterseapower committed
467
	!InterestingCxt -- ^ Occurs exactly once, not inside a rule
468

batterseapower's avatar
batterseapower committed
469
470
  -- | This identifier breaks a loop of mutually recursive functions. The field
  -- marks whether it is only a loop breaker due to a reference in a rule
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
471
  | IAmALoopBreaker	-- Note [LoopBreaker OccInfo]
472
	!RulesOnly
473

474
475
type RulesOnly = Bool
\end{code}
476

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
477
478
Note [LoopBreaker OccInfo]
~~~~~~~~~~~~~~~~~~~~~~~~~~
479
480
   IAmALoopBreaker True  <=> A "weak" or rules-only loop breaker
   		   	     Do not preInlineUnconditionally
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
481

482
483
484
485
   IAmALoopBreaker False <=> A "strong" loop breaker
                             Do not inline at all

See OccurAnal Note [Weak loop breakers]
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
486

487
488

\begin{code}
489
490
isNoOcc :: OccInfo -> Bool
isNoOcc NoOccInfo = True
491
isNoOcc _         = False
492

493
seqOccInfo :: OccInfo -> ()
494
495
496
497
498
499
seqOccInfo occ = occ `seq` ()

-----------------
type InterestingCxt = Bool	-- True <=> Function: is applied
				--	    Data value: scrutinised by a case with
				--			at least one non-DEFAULT branch
500

501
-----------------
502
503
504
type InsideLam = Bool	-- True <=> Occurs inside a non-linear lambda
			-- Substituting a redex for this occurrence is
			-- dangerous because it might duplicate work.
505
insideLam, notInsideLam :: InsideLam
506
507
508
insideLam    = True
notInsideLam = False

509
-----------------
510
511
type OneBranch = Bool	-- True <=> Occurs in only one case branch
			--	so no code-duplication issue to worry about
512
oneBranch, notOneBranch :: OneBranch
513
514
515
oneBranch    = True
notOneBranch = False

516
517
518
strongLoopBreaker, weakLoopBreaker :: OccInfo
strongLoopBreaker = IAmALoopBreaker False
weakLoopBreaker   = IAmALoopBreaker True
519

520
521
522
isWeakLoopBreaker :: OccInfo -> Bool
isWeakLoopBreaker (IAmALoopBreaker _) = True
isWeakLoopBreaker _                   = False
523

524
525
526
isStrongLoopBreaker :: OccInfo -> Bool
isStrongLoopBreaker (IAmALoopBreaker False) = True   -- Loop-breaker that breaks a non-rule cycle
isStrongLoopBreaker _                       = False
527

528
529
isDeadOcc :: OccInfo -> Bool
isDeadOcc IAmDead = True
530
isDeadOcc _       = False
531

532
isOneOcc :: OccInfo -> Bool
533
534
isOneOcc (OneOcc {}) = True
isOneOcc _           = False
535

536
537
538
zapFragileOcc :: OccInfo -> OccInfo
zapFragileOcc (OneOcc {}) = NoOccInfo
zapFragileOcc occ         = occ
539
540
541
542
543
\end{code}

\begin{code}
instance Outputable OccInfo where
  -- only used for debugging; never parsed.  KSW 1999-07
544
  ppr NoOccInfo  	   = empty
Ian Lynagh's avatar
Ian Lynagh committed
545
546
  ppr (IAmALoopBreaker ro) = ptext (sLit "LoopBreaker") <> if ro then char '!' else empty
  ppr IAmDead		   = ptext (sLit "Dead")
547
  ppr (OneOcc inside_lam one_branch int_cxt)
Ian Lynagh's avatar
Ian Lynagh committed
548
	= ptext (sLit "Once") <> pp_lam <> pp_br <> pp_args
549
550
551
552
553
554
555
	where
	  pp_lam | inside_lam = char 'L'
		 | otherwise  = empty
	  pp_br  | one_branch = empty
		 | otherwise  = char '*'
	  pp_args | int_cxt   = char '!'
		  | otherwise = empty
556
557
558
559
560

instance Show OccInfo where
  showsPrec p occ = showsPrecSDoc p (ppr occ)
\end{code}

561
562
%************************************************************************
%*									*
563
		Strictness indication
564
565
566
567
568
569
570
%*									*
%************************************************************************

The strictness annotations on types in data type declarations
e.g. 	data T = MkT !Int !(Bool,Bool)

\begin{code}
571
572
573
574
-------------------------
-- HsBang describes what the *programmer* wrote
-- This info is retained in the DataCon.dcStrictMarks field
data HsBang = HsNoBang	
575

576
	    | HsStrict	
577

578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
	    | HsUnpack	       -- {-# UNPACK #-} ! (GHC extension, meaning "unbox")

	    | HsUnpackFailed   -- An UNPACK pragma that we could not make 
	      		       -- use of, because the type isn't unboxable; 
                               -- equivalant to HsStrict except for checkValidDataCon
  deriving (Eq, Data, Typeable)

instance Outputable HsBang where
    ppr HsNoBang       = empty
    ppr HsStrict       = char '!'
    ppr HsUnpack       = ptext (sLit "{-# UNPACK #-} !")
    ppr HsUnpackFailed = ptext (sLit "{-# UNPACK (failed) #-} !")

isBanged :: HsBang -> Bool
isBanged HsNoBang = False
isBanged _        = True

isMarkedUnboxed :: HsBang -> Bool
isMarkedUnboxed HsUnpack = True
isMarkedUnboxed _        = False

-------------------------
-- StrictnessMark is internal only, used to indicate strictness 
-- of the DataCon *worker* fields
data StrictnessMark = MarkedStrict | NotMarkedStrict	
603
604

instance Outputable StrictnessMark where
Ian Lynagh's avatar
Ian Lynagh committed
605
  ppr MarkedStrict     = ptext (sLit "!")
606
607
608
609
610
  ppr NotMarkedStrict  = empty

isMarkedStrict :: StrictnessMark -> Bool
isMarkedStrict NotMarkedStrict = False
isMarkedStrict _               = True   -- All others are strict
611
\end{code}
612
613


614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
%************************************************************************
%*									*
		Default method specfication
%*									*
%************************************************************************

The DefMethSpec enumeration just indicates what sort of default method
is used for a class. It is generated from source code, and present in 
interface files; it is converted to Class.DefMeth before begin put in a 
Class object.

\begin{code}
data DefMethSpec = NoDM        -- No default method
                 | VanillaDM   -- Default method given with polymorphic code
                 | GenericDM   -- Default method given with generic code

instance Outputable DefMethSpec where
  ppr NoDM      = empty
  ppr VanillaDM = ptext (sLit "{- Has default method -}")
  ppr GenericDM = ptext (sLit "{- Has generic default method -}")
\end{code}

636
637
638
639
640
641
642
643
644
%************************************************************************
%*									*
\subsection{Success flag}
%*									*
%************************************************************************

\begin{code}
data SuccessFlag = Succeeded | Failed

Ian Lynagh's avatar
Ian Lynagh committed
645
instance Outputable SuccessFlag where
Ian Lynagh's avatar
Ian Lynagh committed
646
647
    ppr Succeeded = ptext (sLit "Succeeded")
    ppr Failed    = ptext (sLit "Failed")
Ian Lynagh's avatar
Ian Lynagh committed
648

649
650
651
652
653
654
655
656
657
658
659
660
661
successIf :: Bool -> SuccessFlag
successIf True  = Succeeded
successIf False = Failed

succeeded, failed :: SuccessFlag -> Bool
succeeded Succeeded = True
succeeded Failed    = False

failed Succeeded = False
failed Failed    = True
\end{code}


662
663
664
665
666
667
668
669
670
%************************************************************************
%*									*
\subsection{Activation}
%*									*
%************************************************************************

When a rule or inlining is active

\begin{code}
671
672
673
674
675
676
677
678
679
680
681
type PhaseNum = Int  -- Compilation phase
                     -- Phases decrease towards zero
                     -- Zero is the last phase

data CompilerPhase
  = Phase PhaseNum
  | InitialPhase    -- The first phase -- number = infinity!

instance Outputable CompilerPhase where
   ppr (Phase n)    = int n
   ppr InitialPhase = ptext (sLit "InitialPhase")
682
683
684

data Activation = NeverActive
		| AlwaysActive
685
686
                | ActiveBefore PhaseNum -- Active only *before* this phase
                | ActiveAfter PhaseNum  -- Active in this phase and later
687
		deriving( Eq, Data, Typeable )	-- Eq used in comparing rules in HsDecls
688

689
data RuleMatchInfo = ConLike 			-- See Note [CONLIKE pragma]
690
                   | FunLike
691
692
                   deriving( Eq, Data, Typeable, Show )
	-- Show needed for Lexer.x
693

694
695
data InlinePragma  	     -- Note [InlinePragma]
  = InlinePragma
696
      { inl_inline :: InlineSpec
697

698
699
      , inl_sat    :: Maybe Arity    -- Just n <=> Inline only when applied to n 
      		      	    	     --            explicit (non-type, non-dictionary) args
700
701
702
703
704
				     --   That is, inl_sat describes the number of *source-code*
                                     --   arguments the thing must be applied to.  We add on the 
                                     --   number of implicit, dictionary arguments when making
			             --   the InlineRule, and don't look at inl_sat further

705
      , inl_act    :: Activation     -- Says during which phases inlining is allowed
706

707
      , inl_rule   :: RuleMatchInfo  -- Should the function be treated like a constructor?
708
    } deriving( Eq, Data, Typeable )
709
710
711
712
713
714
715
716

data InlineSpec   -- What the user's INLINE pragama looked like
  = Inline
  | Inlinable
  | NoInline
  | EmptyInlineSpec
  deriving( Eq, Data, Typeable, Show )
	-- Show needed for Lexer.x
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
\end{code}

Note [InlinePragma]
~~~~~~~~~~~~~~~~~~~
This data type mirrors what you can write in an INLINE or NOINLINE pragma in 
the source program.

If you write nothing at all, you get defaultInlinePragma:
   inl_inline = False
   inl_act    = AlwaysActive
   inl_rule   = FunLike

It's not possible to get that combination by *writing* something, so 
if an Id has defaultInlinePragma it means the user didn't specify anything.

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
732
733
If inl_inline = True, then the Id should have an InlineRule unfolding.

734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
Note [CONLIKE pragma]
~~~~~~~~~~~~~~~~~~~~~
The ConLike constructor of a RuleMatchInfo is aimed at the following.
Consider first
    {-# RULE "r/cons" forall a as. r (a:as) = f (a+1) #-}
    g b bs = let x = b:bs in ..x...x...(r x)...
Now, the rule applies to the (r x) term, because GHC "looks through" 
the definition of 'x' to see that it is (b:bs).

Now consider
    {-# RULE "r/f" forall v. r (f v) = f (v+1) #-}
    g v = let x = f v in ..x...x...(r x)...
Normally the (r x) would *not* match the rule, because GHC would be
scared about duplicating the redex (f v), so it does not "look
through" the bindings.  

However the CONLIKE modifier says to treat 'f' like a constructor in
this situation, and "look through" the unfolding for x.  So (r x)
fires, yielding (f (v+1)).

This is all controlled with a user-visible pragma:
     {-# NOINLINE CONLIKE [1] f #-}

The main effects of CONLIKE are:

    - The occurrence analyser (OccAnal) and simplifier (Simplify) treat
      CONLIKE thing like constructors, by ANF-ing them

    - New function coreUtils.exprIsExpandable is like exprIsCheap, but
      additionally spots applications of CONLIKE functions

    - A CoreUnfolding has a field that caches exprIsExpandable

    - The rule matcher consults this field.  See
      Note [Expanding variables] in Rules.lhs.

\begin{code}
771
772
773
774
775
776
777
778
isConLike :: RuleMatchInfo -> Bool
isConLike ConLike = True
isConLike _            = False

isFunLike :: RuleMatchInfo -> Bool
isFunLike FunLike = True
isFunLike _            = False

779
780
781
782
isEmptyInlineSpec :: InlineSpec -> Bool
isEmptyInlineSpec EmptyInlineSpec = True
isEmptyInlineSpec _               = False

783
784
defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma
  :: InlinePragma
785
786
defaultInlinePragma = InlinePragma { inl_act = AlwaysActive
                                   , inl_rule = FunLike
787
                                   , inl_inline = EmptyInlineSpec
788
789
                                   , inl_sat = Nothing }

790
alwaysInlinePragma = defaultInlinePragma { inl_inline = Inline }
791
neverInlinePragma  = defaultInlinePragma { inl_act    = NeverActive }
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
792

793
794
795
inlinePragmaSpec :: InlinePragma -> InlineSpec
inlinePragmaSpec = inl_inline

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
796
797
798
799
800
801
-- A DFun has an always-active inline activation so that 
-- exprIsConApp_maybe can "see" its unfolding
-- (However, its actual Unfolding is a DFunUnfolding, which is
--  never inlined other than via exprIsConApp_maybe.)
dfunInlinePragma   = defaultInlinePragma { inl_act  = AlwaysActive
                                         , inl_rule = ConLike }
802
803

isDefaultInlinePragma :: InlinePragma -> Bool
804
805
806
isDefaultInlinePragma (InlinePragma { inl_act = activation
                                    , inl_rule = match_info
                                    , inl_inline = inline })
807
  = isEmptyInlineSpec inline && isAlwaysActive activation && isFunLike match_info
808
809

isInlinePragma :: InlinePragma -> Bool
810
811
812
isInlinePragma prag = case inl_inline prag of
                        Inline -> True
                        _      -> False
813

814
815
816
817
818
isInlinablePragma :: InlinePragma -> Bool
isInlinablePragma prag = case inl_inline prag of
                           Inlinable -> True
                           _         -> False

819
820
821
822
823
824
825
isAnyInlinePragma :: InlinePragma -> Bool
-- INLINE or INLINABLE
isAnyInlinePragma prag = case inl_inline prag of
                        Inline    -> True
                        Inlinable -> True
                        _         -> False
 
826
827
828
inlinePragmaSat :: InlinePragma -> Maybe Arity
inlinePragmaSat = inl_sat

829
inlinePragmaActivation :: InlinePragma -> Activation
830
inlinePragmaActivation (InlinePragma { inl_act = activation }) = activation
831
832

inlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo
833
inlinePragmaRuleMatchInfo (InlinePragma { inl_rule = info }) = info
834
835

setInlinePragmaActivation :: InlinePragma -> Activation -> InlinePragma
836
setInlinePragmaActivation prag activation = prag { inl_act = activation }
837
838

setInlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo -> InlinePragma
839
setInlinePragmaRuleMatchInfo prag info = prag { inl_rule = info }
840

841
instance Outputable Activation where
842
843
   ppr AlwaysActive     = brackets (ptext (sLit "ALWAYS"))
   ppr NeverActive      = brackets (ptext (sLit "NEVER"))
844
845
   ppr (ActiveBefore n) = brackets (char '~' <> int n)
   ppr (ActiveAfter n)  = brackets (int n)
846
847
848
849
850

instance Outputable RuleMatchInfo where
   ppr ConLike = ptext (sLit "CONLIKE")
   ppr FunLike = ptext (sLit "FUNLIKE")

851
852
853
854
855
856
instance Outputable InlineSpec where
   ppr Inline          = ptext (sLit "INLINE")
   ppr NoInline        = ptext (sLit "NOINLINE")
   ppr Inlinable       = ptext (sLit "INLINABLE")
   ppr EmptyInlineSpec = empty

857
instance Outputable InlinePragma where
858
859
  ppr (InlinePragma { inl_inline = inline, inl_act = activation
                    , inl_rule = info, inl_sat = mb_arity })
860
    = ppr inline <> pp_act inline activation <+> pp_sat <+> pp_info 
861
    where
862
863
864
      pp_act Inline   AlwaysActive = empty	
      pp_act NoInline NeverActive  = empty
      pp_act _        act          = ppr act
865

866
      pp_sat | Just ar <- mb_arity = parens (ptext (sLit "sat-args=") <> int ar)
867
             | otherwise           = empty
868
869
      pp_info | isFunLike info = empty
              | otherwise      = ppr info
870

871
isActive :: CompilerPhase -> Activation -> Bool
872
873
874
875
876
877
878
879
880
881
isActive InitialPhase AlwaysActive      = True
isActive InitialPhase (ActiveBefore {}) = True
isActive InitialPhase _                 = False
isActive (Phase p)    act               = isActiveIn p act

isActiveIn :: PhaseNum -> Activation -> Bool
isActiveIn _ NeverActive      = False
isActiveIn _ AlwaysActive     = True
isActiveIn p (ActiveAfter n)  = p <= n
isActiveIn p (ActiveBefore n) = p >  n
882

883
isNeverActive, isAlwaysActive, isEarlyActive :: Activation -> Bool
884
isNeverActive NeverActive = True
885
isNeverActive _           = False
886
887

isAlwaysActive AlwaysActive = True
888
isAlwaysActive _            = False
889
890
891
892

isEarlyActive AlwaysActive      = True
isEarlyActive (ActiveBefore {}) = True
isEarlyActive _		        = False
sof's avatar
sof committed
893
\end{code}
894

895
896
897


\begin{code}
898
899
900
-- Used (instead of Rational) to represent exactly the floating point literal that we
-- encountered in the user's source program. This allows us to pretty-print exactly what
-- the user wrote, which is important e.g. for floating point numbers that can't represented
901
902
903
904
905
-- as Doubles (we used to via Double for pretty-printing). See also #2245.
data FractionalLit
  = FL { fl_text :: String         -- How the value was written in the source
       , fl_value :: Rational      -- Numeric value of the literal
       }
batterseapower's avatar
batterseapower committed
906
907
  deriving (Data, Typeable, Show)
  -- The Show instance is required for the derived Lexer.x:Token instance when DEBUG is on
908

909
910
911
912
913
914
915
negateFractionalLit :: FractionalLit -> FractionalLit
negateFractionalLit (FL { fl_text = '-':text, fl_value = value }) = FL { fl_text = text, fl_value = negate value }
negateFractionalLit (FL { fl_text = text, fl_value = value }) = FL { fl_text = '-':text, fl_value = negate value }

integralFractionalLit :: Integer -> FractionalLit
integralFractionalLit i = FL { fl_text = show i, fl_value = fromInteger i }

916
917
918
919
920
921
922
923
-- Comparison operations are needed when grouping literals
-- for compiling pattern-matching (module MatchLit)

instance Eq FractionalLit where
  (==) = (==) `on` fl_value

instance Ord FractionalLit where
  compare = compare `on` fl_value
924
925
926

instance Outputable FractionalLit where
  ppr = text . fl_text
927
\end{code}