Id.lhs 23.6 KB
Newer Older
1
%
Simon Marlow's avatar
Simon Marlow committed
2
% (c) The University of Glasgow 2006
3
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
5
6
7
%
\section[Id]{@Ids@: Value and constructor identifiers}

\begin{code}
batterseapower's avatar
batterseapower committed
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
-- |
-- #name_types#
-- GHC uses several kinds of name internally:
--
-- * 'OccName.OccName': see "OccName#name_types"
--
-- * 'RdrName.RdrName': see "RdrName#name_types"
--
-- * 'Name.Name': see "Name#name_types"
--
-- * 'Id.Id' represents names that not only have a 'Name.Name' but also a 'TypeRep.Type' and some additional
--   details (a 'IdInfo.IdInfo' and one of 'Var.LocalIdDetails' or 'IdInfo.GlobalIdDetails') that
--   are added, modified and inspected by various compiler passes. These 'Var.Var' names may either 
--   be global or local, see "Var#globalvslocal"
--
-- * 'Var.Var': see "Var#name_types"
24
module Id (
25
        -- * The main types
26
	Id, DictId,
27

28
29
	-- ** Simple construction
	mkGlobalId, mkVanillaGlobal, mkVanillaGlobalWithInfo,
30
	mkLocalId, mkLocalIdWithInfo, mkExportedLocalId,
31
	mkSysLocal, mkSysLocalM, mkUserLocal, mkUserLocalM,
32
	mkTemplateLocals, mkTemplateLocalsNum, mkTemplateLocal,
33
	mkWorkerId, mkWiredInIdName,
34

35
	-- ** Taking an Id apart
36
37
	idName, idType, idUnique, idInfo, idDetails,
	isId, idPrimRep,
38
	recordSelectorFieldLabel,
39

40
	-- ** Modifying an Id
41
42
43
44
	setIdName, setIdUnique, Id.setIdType, 
	setIdExported, setIdNotExported, 
	globaliseId, localiseId, 
	setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo,
45
	zapLamIdInfo, zapDemandIdInfo, zapFragileIdInfo, transferPolyIdInfo,
46
	
47

48
	-- ** Predicates on Ids
49
	isImplicitId, isDeadBinder, isDictId, isStrictId,
50
	isExportedId, isLocalId, isGlobalId,
51
	isRecordSelector, isNaughtyRecordSelector,
52
	isClassOpId_maybe, isDFunId,
53
	isPrimOpId, isPrimOpId_maybe, 
54
	isFCallId, isFCallId_maybe,
55
	isDataConWorkId, isDataConWorkId_maybe, isDataConId_maybe, idDataCon,
56
        isConLikeId, isBottomingId, idIsFrom,
57
        isTickBoxOp, isTickBoxOp_maybe,
58
	hasNoBinding, 
59

60
	-- ** Inline pragma stuff
61
62
	idInlinePragma, setInlinePragma, modifyInlinePragma,
        idInlineActivation, setInlineActivation, idRuleMatchInfo,
63

batterseapower's avatar
batterseapower committed
64
	-- ** One-shot lambdas
65
66
	isOneShotBndr, isOneShotLambda, isStateHackType,
	setOneShotLambda, clearOneShotLambda,
67

batterseapower's avatar
batterseapower committed
68
69
	-- ** Reading 'IdInfo' fields
	idArity, 
70
71
	idDemandInfo, idDemandInfo_maybe,
	idStrictness, idStrictness_maybe, 
72
	idUnfolding, realIdUnfolding,
batterseapower's avatar
batterseapower committed
73
74
75
76
77
78
	idSpecialisation, idCoreRules, idHasRules,
	idCafInfo,
	idLBVarInfo,
	idOccInfo,

	-- ** Writing 'IdInfo' fields
79
	setIdUnfoldingLazily,
80
	setIdUnfolding,
81
	setIdArity,
82
83
	setIdDemandInfo, 
	setIdStrictness, zapIdStrictness,
84
	setIdSpecialisation,
85
	setIdCafInfo,
86
	setIdOccInfo, zapIdOccInfo,
87

88
    ) where
89

90
#include "HsVersions.h"
sof's avatar
sof committed
91

92
import CoreSyn ( CoreRule, Unfolding( NoUnfolding ) )
93
94

import IdInfo
Simon Marlow's avatar
Simon Marlow committed
95
import BasicTypes
96
97

-- Imported and re-exported 
98
import Var( Var, Id, DictId,
99
100
            idInfo, idDetails, globaliseId,
            isId, isLocalId, isGlobalId, isExportedId )
Simon Marlow's avatar
Simon Marlow committed
101
import qualified Var
102

Simon Marlow's avatar
Simon Marlow committed
103
104
import TyCon
import Type
batterseapower's avatar
batterseapower committed
105
import TysPrim
Simon Marlow's avatar
Simon Marlow committed
106
import DataCon
107
import Demand
Simon Marlow's avatar
Simon Marlow committed
108
109
import Name
import Module
twanvl's avatar
twanvl committed
110
111
112
import Class
import PrimOp
import ForeignCall
Simon Marlow's avatar
Simon Marlow committed
113
114
import Maybes
import SrcLoc
115
import Outputable
Simon Marlow's avatar
Simon Marlow committed
116
import Unique
117
import UniqSupply
Simon Marlow's avatar
Simon Marlow committed
118
import FastString
119
import Util( count )
Simon Marlow's avatar
Simon Marlow committed
120
import StaticFlags
121

122
-- infixl so you can say (id `set` a `set` b)
123
124
infixl 	1 `setIdUnfoldingLazily`,
	  `setIdUnfolding`,
125
	  `setIdArity`,
126
	  `setIdOccInfo`,
127
128
	  `setIdDemandInfo`,
	  `setIdStrictness`,
129
	  `setIdSpecialisation`,
130
	  `setInlinePragma`,
131
	  `setInlineActivation`,
132
	  `idCafInfo`
133
\end{code}
batterseapower's avatar
batterseapower committed
134

135
136
137
138
139
140
141
142
143
144
145
%************************************************************************
%*									*
\subsection{Basic Id manipulation}
%*									*
%************************************************************************

\begin{code}
idName   :: Id -> Name
idName    = Var.varName

idUnique :: Id -> Unique
146
idUnique  = Var.varUnique
147
148

idType   :: Id -> Kind
149
idType    = Var.varType
batterseapower's avatar
batterseapower committed
150
151
152
153

idPrimRep :: Id -> PrimRep
idPrimRep id = typePrimRep (idType id)

154
setIdName :: Id -> Name -> Id
155
setIdName = Var.setVarName
156

batterseapower's avatar
batterseapower committed
157
setIdUnique :: Id -> Unique -> Id
158
setIdUnique = Var.setVarUnique
batterseapower's avatar
batterseapower committed
159
160
161

-- | Not only does this set the 'Id' 'Type', it also evaluates the type to try and
-- reduce space usage
162
163
setIdType :: Id -> Type -> Id
setIdType id ty = seqType ty `seq` Var.setVarType id ty
164

165
setIdExported :: Id -> Id
166
setIdExported = Var.setIdExported
167

168
setIdNotExported :: Id -> Id
169
setIdNotExported = Var.setIdNotExported
170

171
172
173
174
175
176
177
178
179
180
181
localiseId :: Id -> Id
-- Make an with the same unique and type as the 
-- incoming Id, but with an *Internal* Name and *LocalId* flavour
localiseId id 
  | isLocalId id && isInternalName name
  = id
  | otherwise
  = mkLocalIdWithInfo (localiseName name) (idType id) (idInfo id)
  where
    name = idName id

182
lazySetIdInfo :: Id -> IdInfo -> Id
183
lazySetIdInfo = Var.lazySetIdInfo
184
185
186
187
188
189
190
191
192
193
194
195
196

setIdInfo :: Id -> IdInfo -> Id
setIdInfo id info = seqIdInfo info `seq` (lazySetIdInfo id info)
        -- Try to avoid spack leaks by seq'ing

modifyIdInfo :: (IdInfo -> IdInfo) -> Id -> Id
modifyIdInfo fn id = setIdInfo id (fn (idInfo id))

-- maybeModifyIdInfo tries to avoid unnecesary thrashing
maybeModifyIdInfo :: Maybe IdInfo -> Id -> Id
maybeModifyIdInfo (Just new_info) id = lazySetIdInfo id new_info
maybeModifyIdInfo Nothing	  id = id
\end{code}
197

198
199
%************************************************************************
%*									*
200
\subsection{Simple Id construction}
201
202
203
%*									*
%************************************************************************

204
205
206
Absolutely all Ids are made by mkId.  It is just like Var.mkId,
but in addition it pins free-tyvar-info onto the Id's type, 
where it can easily be found.
207

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
208
209
210
211
212
213
214
215
216
217
Note [Free type variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~
At one time we cached the free type variables of the type of an Id
at the root of the type in a TyNote.  The idea was to avoid repeating
the free-type-variable calculation.  But it turned out to slow down
the compiler overall. I don't quite know why; perhaps finding free
type variables of an Id isn't all that common whereas applying a 
substitution (which changes the free type variables) is more common.
Anyway, we removed it in March 2008.

218
\begin{code}
batterseapower's avatar
batterseapower committed
219
-- | For an explanation of global vs. local 'Id's, see "Var#globalvslocal"
220
221
mkGlobalId :: IdDetails -> Name -> Type -> IdInfo -> Id
mkGlobalId = Var.mkGlobalVar
222

batterseapower's avatar
batterseapower committed
223
-- | Make a global 'Id' without any extra information at all
224
225
mkVanillaGlobal :: Name -> Type -> Id
mkVanillaGlobal name ty = mkVanillaGlobalWithInfo name ty vanillaIdInfo
226

batterseapower's avatar
batterseapower committed
227
-- | Make a global 'Id' with no global information but some generic 'IdInfo'
228
mkVanillaGlobalWithInfo :: Name -> Type -> IdInfo -> Id
229
mkVanillaGlobalWithInfo = mkGlobalId VanillaId
230

231

batterseapower's avatar
batterseapower committed
232
-- | For an explanation of global vs. local 'Id's, see "Var#globalvslocal"
233
mkLocalId :: Name -> Type -> Id
234
mkLocalId name ty = mkLocalIdWithInfo name ty vanillaIdInfo
235

236
mkLocalIdWithInfo :: Name -> Type -> IdInfo -> Id
237
mkLocalIdWithInfo name ty info = Var.mkLocalVar VanillaId name ty info
batterseapower's avatar
batterseapower committed
238
	-- Note [Free type variables]
239

240
241
-- | Create a local 'Id' that is marked as exported. 
-- This prevents things attached to it from being removed as dead code.
242
mkExportedLocalId :: Name -> Type -> Id
243
mkExportedLocalId name ty = Var.mkExportedLocalVar VanillaId name ty vanillaIdInfo
244
245
246
	-- Note [Free type variables]


247
248
-- | Create a system local 'Id'. These are local 'Id's (see "Var#globalvslocal") 
-- that are created by the compiler out of thin air
249
250
251
mkSysLocal :: FastString -> Unique -> Type -> Id
mkSysLocal fs uniq ty = mkLocalId (mkSystemVarName uniq fs) ty

252
253
254
mkSysLocalM :: MonadUnique m => FastString -> Type -> m Id
mkSysLocalM fs ty = getUniqueM >>= (\uniq -> return (mkSysLocal fs uniq ty))

255

batterseapower's avatar
batterseapower committed
256
-- | Create a user local 'Id'. These are local 'Id's (see "Var#globalvslocal") with a name and location that the user might recognize
257
mkUserLocal :: OccName -> Unique -> Type -> SrcSpan -> Id
258
mkUserLocal occ uniq ty loc = mkLocalId (mkInternalName uniq occ loc) ty
259

260
261
mkUserLocalM :: MonadUnique m => OccName -> Type -> SrcSpan -> m Id
mkUserLocalM occ ty loc = getUniqueM >>= (\uniq -> return (mkUserLocal occ uniq ty loc))
batterseapower's avatar
batterseapower committed
262

263
264
265
mkWiredInIdName :: Module -> FastString -> Unique -> Id -> Name
mkWiredInIdName mod fs uniq id
 = mkWiredInName mod (mkOccNameFS varName fs) uniq (AnId id) UserSyntax
266
\end{code}
267
268
269
270

Make some local @Ids@ for a template @CoreExpr@.  These have bogus
@Uniques@, but that's OK because the templates are supposed to be
instantiated before use.
271
 
272
\begin{code}
batterseapower's avatar
batterseapower committed
273
-- | Workers get local names. "CoreTidy" will externalise these if necessary
274
275
mkWorkerId :: Unique -> Id -> Type -> Id
mkWorkerId uniq unwrkr ty
276
  = mkLocalId (mkDerivedInternalName mkWorkerOcc uniq (getName unwrkr)) ty
277

batterseapower's avatar
batterseapower committed
278
-- | Create a /template local/: a family of system local 'Id's in bijection with @Int@s, typically used in unfoldings
279
280
281
282
mkTemplateLocal :: Int -> Type -> Id
mkTemplateLocal i ty = mkSysLocal (fsLit "tpl") (mkBuiltinUnique i) ty

-- | Create a template local for a series of types
283
mkTemplateLocals :: [Type] -> [Id]
284
mkTemplateLocals = mkTemplateLocalsNum 1
285

286
-- | Create a template local for a series of type, but start from a specified template local
287
mkTemplateLocalsNum :: Int -> [Type] -> [Id]
288
mkTemplateLocalsNum n tys = zipWith mkTemplateLocal [n..] tys
289
290
291
\end{code}


292
293
%************************************************************************
%*									*
294
\subsection{Special Ids}
295
296
297
%*									*
%************************************************************************

298
\begin{code}
batterseapower's avatar
batterseapower committed
299
-- | If the 'Id' is that for a record selector, extract the 'sel_tycon' and label. Panic otherwise
300
recordSelectorFieldLabel :: Id -> (TyCon, FieldLabel)
301
recordSelectorFieldLabel id
302
303
  = case Var.idDetails id of
        RecSelId { sel_tycon = tycon } -> (tycon, idName id)
twanvl's avatar
twanvl committed
304
305
        _ -> panic "recordSelectorFieldLabel"

306
307
308
309
310
isRecordSelector        :: Id -> Bool
isNaughtyRecordSelector :: Id -> Bool
isPrimOpId              :: Id -> Bool
isFCallId               :: Id -> Bool
isDataConWorkId         :: Id -> Bool
311
isDFunId                :: Id -> Bool
twanvl's avatar
twanvl committed
312

313
314
315
316
isClassOpId_maybe       :: Id -> Maybe Class
isPrimOpId_maybe        :: Id -> Maybe PrimOp
isFCallId_maybe         :: Id -> Maybe ForeignCall
isDataConWorkId_maybe   :: Id -> Maybe DataCon
sof's avatar
sof committed
317

318
319
isRecordSelector id = case Var.idDetails id of
                        RecSelId {}  -> True
twanvl's avatar
twanvl committed
320
                        _               -> False
sof's avatar
sof committed
321

322
323
isNaughtyRecordSelector id = case Var.idDetails id of
                        RecSelId { sel_naughty = n } -> n
twanvl's avatar
twanvl committed
324
                        _                               -> False
325

326
isClassOpId_maybe id = case Var.idDetails id of
327
328
329
			ClassOpId cls -> Just cls
			_other        -> Nothing

330
isPrimOpId id = case Var.idDetails id of
twanvl's avatar
twanvl committed
331
332
                        PrimOpId _ -> True
                        _          -> False
333

334
isDFunId id = case Var.idDetails id of
335
336
                        DFunId _ -> True
                        _        -> False
337

338
isPrimOpId_maybe id = case Var.idDetails id of
twanvl's avatar
twanvl committed
339
340
                        PrimOpId op -> Just op
                        _           -> Nothing
341

342
isFCallId id = case Var.idDetails id of
twanvl's avatar
twanvl committed
343
344
                        FCallId _ -> True
                        _         -> False
345

346
isFCallId_maybe id = case Var.idDetails id of
twanvl's avatar
twanvl committed
347
348
                        FCallId call -> Just call
                        _            -> Nothing
349

350
isDataConWorkId id = case Var.idDetails id of
twanvl's avatar
twanvl committed
351
352
                        DataConWorkId _ -> True
                        _               -> False
sof's avatar
sof committed
353

354
isDataConWorkId_maybe id = case Var.idDetails id of
twanvl's avatar
twanvl committed
355
356
                        DataConWorkId con -> Just con
                        _                 -> Nothing
sof's avatar
sof committed
357

358
isDataConId_maybe :: Id -> Maybe DataCon
359
isDataConId_maybe id = case Var.idDetails id of
twanvl's avatar
twanvl committed
360
361
362
                         DataConWorkId con -> Just con
                         DataConWrapId con -> Just con
                         _                 -> Nothing
363

364
idDataCon :: Id -> DataCon
batterseapower's avatar
batterseapower committed
365
-- ^ Get from either the worker or the wrapper 'Id' to the 'DataCon'. Currently used only in the desugarer.
366
--
batterseapower's avatar
batterseapower committed
367
368
-- INVARIANT: @idDataCon (dataConWrapId d) = d@: remember, 'dataConWrapId' can return either the wrapper or the worker
idDataCon id = isDataConId_maybe id `orElse` pprPanic "idDataCon" (ppr id)
369
370


371
372
373
isDictId :: Id -> Bool
isDictId id = isDictTy (idType id)

374
hasNoBinding :: Id -> Bool
batterseapower's avatar
batterseapower committed
375
376
377
-- ^ Returns @True@ of an 'Id' which may not have a
-- binding, even though it is defined in this module.

378
379
-- Data constructor workers used to be things of this kind, but
-- they aren't any more.  Instead, we inject a binding for 
380
381
-- them at the CorePrep stage. 
-- EXCEPT: unboxed tuples, which definitely have no binding
382
hasNoBinding id = case Var.idDetails id of
383
			PrimOpId _  	 -> True	-- See Note [Primop wrappers]
384
385
			FCallId _   	 -> True
			DataConWorkId dc -> isUnboxedTupleCon dc
twanvl's avatar
twanvl committed
386
			_                -> False
387

388
isImplicitId :: Id -> Bool
batterseapower's avatar
batterseapower committed
389
-- ^ 'isImplicitId' tells whether an 'Id's info is implied by other
390
391
-- declarations, so we don't need to put its signature in an interface
-- file, even if it's mentioned in some other interface unfolding.
392
isImplicitId id
393
  = case Var.idDetails id of
394
395
396
397
398
        FCallId {}       -> True
	ClassOpId {}     -> True
        PrimOpId {}      -> True
        DataConWorkId {} -> True
	DataConWrapId {} -> True
399
		-- These are are implied by their type or class decl;
400
		-- remember that all type and class decls appear in the interface file.
401
402
		-- The dfun id is not an implicit Id; it must *not* be omitted, because 
		-- it carries version info for the instance decl
twanvl's avatar
twanvl committed
403
        _               -> False
404
405
406

idIsFrom :: Module -> Id -> Bool
idIsFrom mod id = nameIsLocalOrFrom mod (idName id)
407
408
\end{code}

409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
Note [Primop wrappers]
~~~~~~~~~~~~~~~~~~~~~~
Currently hasNoBinding claims that PrimOpIds don't have a curried
function definition.  But actually they do, in GHC.PrimopWrappers,
which is auto-generated from prelude/primops.txt.pp.  So actually, hasNoBinding
could return 'False' for PrimOpIds.

But we'd need to add something in CoreToStg to swizzle any unsaturated
applications of GHC.Prim.plusInt# to GHC.PrimopWrappers.plusInt#.

Nota Bene: GHC.PrimopWrappers is needed *regardless*, because it's
used by GHCi, which does not implement primops direct at all.



424
425
\begin{code}
isDeadBinder :: Id -> Bool
426
isDeadBinder bndr | isId bndr = isDeadOcc (idOccInfo bndr)
427
		  | otherwise = False	-- TyVars count as not dead
428
429
\end{code}

430
431
432
\begin{code}
isTickBoxOp :: Id -> Bool
isTickBoxOp id = 
433
  case Var.idDetails id of
twanvl's avatar
twanvl committed
434
    TickBoxOpId _    -> True
435
436
437
438
    _                -> False

isTickBoxOp_maybe :: Id -> Maybe TickBoxOp
isTickBoxOp_maybe id = 
439
  case Var.idDetails id of
440
441
442
    TickBoxOpId tick -> Just tick
    _                -> Nothing
\end{code}
443

444
445
%************************************************************************
%*									*
446
\subsection{IdInfo stuff}
447
448
449
%*									*
%************************************************************************

450
\begin{code}
451
452
	---------------------------------
	-- ARITY
453
idArity :: Id -> Arity
454
idArity id = arityInfo (idInfo id)
455

456
457
setIdArity :: Id -> Arity -> Id
setIdArity id arity = modifyIdInfo (`setArityInfo` arity) id
458

459
-- | Returns true if an application to n args would diverge
460
isBottomingId :: Id -> Bool
461
isBottomingId id = isBottomingSig (idStrictness id)
462

463
464
idStrictness_maybe :: Id -> Maybe StrictSig
idStrictness :: Id -> StrictSig
465

466
467
idStrictness_maybe id = strictnessInfo (idInfo id)
idStrictness       id = idStrictness_maybe id `orElse` topSig
468

469
470
setIdStrictness :: Id -> StrictSig -> Id
setIdStrictness id sig = modifyIdInfo (`setStrictnessInfo` Just sig) id
471

472
473
zapIdStrictness :: Id -> Id
zapIdStrictness id = modifyIdInfo (`setStrictnessInfo` Nothing) id
474

batterseapower's avatar
batterseapower committed
475
-- | This predicate says whether the 'Id' has a strict demand placed on it or
476
477
-- has a type such that it can always be evaluated strictly (e.g., an
-- unlifted type, but see the comment for 'isStrictType').  We need to
batterseapower's avatar
batterseapower committed
478
479
480
-- check separately whether the 'Id' has a so-called \"strict type\" because if
-- the demand for the given @id@ hasn't been computed yet but @id@ has a strict
-- type, we still want @isStrictId id@ to be @True@.
481
482
483
isStrictId :: Id -> Bool
isStrictId id
  = ASSERT2( isId id, text "isStrictId: not an id: " <+> ppr id )
484
           (isStrictDmd (idDemandInfo id)) || 
485
           (isStrictType (idType id))
486

487
488
	---------------------------------
	-- UNFOLDING
489
idUnfolding :: Id -> Unfolding
490
491
492
493
494
495
496
497
498
499
-- Do not expose the unfolding of a loop breaker!
idUnfolding id 
  | isNonRuleLoopBreaker (occInfo info) = NoUnfolding
  | otherwise                           = unfoldingInfo info
  where
    info = idInfo id

realIdUnfolding :: Id -> Unfolding
-- Expose the unfolding if there is one, including for loop breakers
realIdUnfolding id = unfoldingInfo (idInfo id)
500

501
502
503
setIdUnfoldingLazily :: Id -> Unfolding -> Id
setIdUnfoldingLazily id unfolding = modifyIdInfo (`setUnfoldingInfoLazily` unfolding) id

504
setIdUnfolding :: Id -> Unfolding -> Id
505
setIdUnfolding id unfolding = modifyIdInfo (`setUnfoldingInfo` unfolding) id
sof's avatar
sof committed
506

507
508
idDemandInfo_maybe :: Id -> Maybe Demand
idDemandInfo       :: Id -> Demand
509

510
511
idDemandInfo_maybe id = demandInfo (idInfo id)
idDemandInfo       id = demandInfo (idInfo id) `orElse` topDmd
512

513
514
setIdDemandInfo :: Id -> Demand -> Id
setIdDemandInfo id dmd = modifyIdInfo (`setDemandInfo` Just dmd) id
515

516
517
	---------------------------------
	-- SPECIALISATION
518
519
520

-- See Note [Specialisations and RULES in IdInfo] in IdInfo.lhs

521
idSpecialisation :: Id -> SpecInfo
522
idSpecialisation id = specInfo (idInfo id)
523

524
525
idCoreRules :: Id -> [CoreRule]
idCoreRules id = specInfoRules (idSpecialisation id)
526

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
527
528
529
idHasRules :: Id -> Bool
idHasRules id = not (isEmptySpecInfo (idSpecialisation id))

530
setIdSpecialisation :: Id -> SpecInfo -> Id
531
setIdSpecialisation id spec_info = modifyIdInfo (`setSpecInfo` spec_info) id
532

533
534
	---------------------------------
	-- CAF INFO
535
idCafInfo :: Id -> CafInfo
536
537
538
539
540
idCafInfo id = cafInfo (idInfo id)

setIdCafInfo :: Id -> CafInfo -> Id
setIdCafInfo id caf_info = modifyIdInfo (`setCafInfo` caf_info) id

541
542
	---------------------------------
	-- Occcurrence INFO
543
544
idOccInfo :: Id -> OccInfo
idOccInfo id = occInfo (idInfo id)
545
546
547

setIdOccInfo :: Id -> OccInfo -> Id
setIdOccInfo id occ_info = modifyIdInfo (`setOccInfo` occ_info) id
548
549
550

zapIdOccInfo :: Id -> Id
zapIdOccInfo b = b `setIdOccInfo` NoOccInfo
551
552
\end{code}

sof's avatar
sof committed
553

554
555
556
557
	---------------------------------
	-- INLINING
The inline pragma tells us to be very keen to inline this Id, but it's still
OK not to if optimisation is switched off.
558
559

\begin{code}
560
idInlinePragma :: Id -> InlinePragma
561
idInlinePragma id = inlinePragInfo (idInfo id)
562

563
setInlinePragma :: Id -> InlinePragma -> Id
564
setInlinePragma id prag = modifyIdInfo (`setInlinePragInfo` prag) id
565

566
modifyInlinePragma :: Id -> (InlinePragma -> InlinePragma) -> Id
567
modifyInlinePragma id fn = modifyIdInfo (\info -> info `setInlinePragInfo` (fn (inlinePragInfo info))) id
568
569
570
571
572

idInlineActivation :: Id -> Activation
idInlineActivation id = inlinePragmaActivation (idInlinePragma id)

setInlineActivation :: Id -> Activation -> Id
573
setInlineActivation id act = modifyInlinePragma id (\prag -> setInlinePragmaActivation prag act)
574
575
576
577
578
579

idRuleMatchInfo :: Id -> RuleMatchInfo
idRuleMatchInfo id = inlinePragmaRuleMatchInfo (idInlinePragma id)

isConLikeId :: Id -> Bool
isConLikeId id = isDataConWorkId id || isConLike (idRuleMatchInfo id)
580
\end{code}
581
582
583
584
585


	---------------------------------
	-- ONE-SHOT LAMBDAS
\begin{code}
586
587
588
idLBVarInfo :: Id -> LBVarInfo
idLBVarInfo id = lbvarInfo (idInfo id)

batterseapower's avatar
batterseapower committed
589
590
591
-- | Returns whether the lambda associated with the 'Id' is certainly applied at most once
-- OR we are applying the \"state hack\" which makes it appear as if theis is the case for
-- lambdas used in @IO@. You should prefer using this over 'isOneShotLambda'
592
593
594
isOneShotBndr :: Id -> Bool
-- This one is the "business end", called externally.
-- Its main purpose is to encapsulate the Horrible State Hack
595
isOneShotBndr id = isOneShotLambda id || isStateHackType (idType id)
596

batterseapower's avatar
batterseapower committed
597
-- | Should we apply the state hack to values of this 'Type'?
598
599
isStateHackType :: Type -> Bool
isStateHackType ty
600
601
602
  | opt_NoStateHack 
  = False
  | otherwise
603
604
  = case splitTyConApp_maybe ty of
	Just (tycon,_) -> tycon == statePrimTyCon
twanvl's avatar
twanvl committed
605
        _              -> False
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
	-- This is a gross hack.  It claims that 
	-- every function over realWorldStatePrimTy is a one-shot
	-- function.  This is pretty true in practice, and makes a big
	-- difference.  For example, consider
	--	a `thenST` \ r -> ...E...
	-- The early full laziness pass, if it doesn't know that r is one-shot
	-- will pull out E (let's say it doesn't mention r) to give
	--	let lvl = E in a `thenST` \ r -> ...lvl...
	-- When `thenST` gets inlined, we end up with
	--	let lvl = E in \s -> case a s of (r, s') -> ...lvl...
	-- and we don't re-inline E.
	--
	-- It would be better to spot that r was one-shot to start with, but
	-- I don't want to rely on that.
	--
	-- Another good example is in fill_in in PrelPack.lhs.  We should be able to
	-- spot that fill_in has arity 2 (and when Keith is done, we will) but we can't yet.


batterseapower's avatar
batterseapower committed
625
626
-- | Returns whether the lambda associated with the 'Id' is certainly applied at most once.
-- You probably want to use 'isOneShotBndr' instead
627
isOneShotLambda :: Id -> Bool
628
629
630
isOneShotLambda id = case idLBVarInfo id of
                       IsOneShotLambda  -> True
                       NoLBVarInfo      -> False
631
632

setOneShotLambda :: Id -> Id
633
setOneShotLambda id = modifyIdInfo (`setLBVarInfo` IsOneShotLambda) id
634
635
636
637
638
639

clearOneShotLambda :: Id -> Id
clearOneShotLambda id 
  | isOneShotLambda id = modifyIdInfo (`setLBVarInfo` NoLBVarInfo) id
  | otherwise	       = id			

batterseapower's avatar
batterseapower committed
640
-- The OneShotLambda functions simply fiddle with the IdInfo flag
641
642
643
-- But watch out: this may change the type of something else
--	f = \x -> e
-- If we change the one-shot-ness of x, f's type changes
644
\end{code}
645
646

\begin{code}
647
648
649
zapInfo :: (IdInfo -> Maybe IdInfo) -> Id -> Id
zapInfo zapper id = maybeModifyIdInfo (zapper (idInfo id)) id

650
zapLamIdInfo :: Id -> Id
651
652
zapLamIdInfo = zapInfo zapLamInfo

twanvl's avatar
twanvl committed
653
zapDemandIdInfo :: Id -> Id
654
zapDemandIdInfo = zapInfo zapDemandInfo
655

656
657
zapFragileIdInfo :: Id -> Id
zapFragileIdInfo = zapInfo zapFragileInfo 
658
\end{code}
659

660
661
Note [transferPolyIdInfo]
~~~~~~~~~~~~~~~~~~~~~~~~~
662
663
664
665
666
This transfer is used in two places: 
	FloatOut (long-distance let-floating)
	SimplUtils.abstractFloats (short-distance let-floating)

Consider the short-distance let-floating:
667
668
669

   f = /\a. let g = rhs in ...

670
Then if we float thus
671
672

   g' = /\a. rhs
673
   f = /\a. ...[g' a/g]....
674

675
676
677
678
we *do not* want to lose g's
  * strictness information
  * arity 
  * inline pragma (though that is bit more debatable)
679
680
681
682
683
684
685
686
  * occurrence info

Mostly this is just an optimisation, but it's *vital* to
transfer the occurrence info.  Consider
   
   NonRec { f = /\a. let Rec { g* = ..g.. } in ... }

where the '*' means 'LoopBreaker'.  Then if we float we must get
687

688
689
690
691
692
693
694
695
   Rec { g'* = /\a. ...(g' a)... }
   NonRec { f = /\a. ...[g' a/g]....}

where g' is also marked as LoopBreaker.  If not, terrible things
can happen if we re-simplify the binding (and the Simplifier does
sometimes simplify a term twice); see Trac #4345.

It's not so simple to retain
696
697
  * worker info
  * rules
698
699
so we simply discard those.  Sooner or later this may bite us.

700
701
702
703
704
705
706
707
If we abstract wrt one or more *value* binders, we must modify the 
arity and strictness info before transferring it.  E.g. 
      f = \x. e
-->
      g' = \y. \x. e
      + substitute (g' y) for g
Notice that g' has an arity one more than the original g

708
\begin{code}
709
710
711
712
713
transferPolyIdInfo :: Id	-- Original Id
		   -> [Var]	-- Abstract wrt these variables
		   -> Id	-- New Id
		   -> Id
transferPolyIdInfo old_id abstract_wrt new_id
714
715
  = modifyIdInfo transfer new_id
  where
716
717
718
719
720
721
    arity_increase = count isId abstract_wrt	-- Arity increases by the
    		     	   			-- number of value binders

    old_info 	    = idInfo old_id
    old_arity       = arityInfo old_info
    old_inline_prag = inlinePragInfo old_info
722
    old_occ_info    = occInfo old_info
723
    new_arity       = old_arity + arity_increase
724
    old_strictness  = strictnessInfo old_info
725
726
    new_strictness  = fmap (increaseStrictSigArity arity_increase) old_strictness

727
    transfer new_info = new_info `setStrictnessInfo` new_strictness
728
729
			         `setArityInfo` new_arity
 			         `setInlinePragInfo` old_inline_prag
730
				 `setOccInfo` old_occ_info
731
\end{code}