CLabel.hs 29 KB
Newer Older
1
2
3
4
5
6
7
{-# OPTIONS -w #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
-- for details

8
9
10
11
-----------------------------------------------------------------------------
--
-- Object-file symbols (called CLabel for histerical raisins).
--
Simon Marlow's avatar
Simon Marlow committed
12
-- (c) The University of Glasgow 2004-2006
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
--
-----------------------------------------------------------------------------

module CLabel (
	CLabel,	-- abstract type

	mkClosureLabel,
	mkSRTLabel,
	mkInfoTableLabel,
	mkEntryLabel,
	mkSlowEntryLabel,
	mkConEntryLabel,
	mkStaticConEntryLabel,
	mkRednCountsLabel,
	mkConInfoTableLabel,
	mkStaticInfoTableLabel,
29
	mkLargeSRTLabel,
30
31
	mkApEntryLabel,
	mkApInfoTableLabel,
32
33
34
35
36
37
38
39
40
41
	mkClosureTableLabel,

	mkLocalClosureLabel,
	mkLocalInfoTableLabel,
	mkLocalEntryLabel,
	mkLocalConEntryLabel,
	mkLocalStaticConEntryLabel,
	mkLocalConInfoTableLabel,
	mkLocalStaticInfoTableLabel,
	mkLocalClosureTableLabel,
42
43
44
45
46
47

	mkReturnPtLabel,
	mkReturnInfoLabel,
	mkAltLabel,
	mkDefaultLabel,
	mkBitmapLabel,
48
	mkStringLitLabel,
49
50
51
52
53
54
55

	mkAsmTempLabel,

	mkModuleInitLabel,
	mkPlainModuleInitLabel,

	mkSplitMarkerLabel,
56
	mkDirty_MUT_VAR_Label,
57
58
59
60
	mkUpdInfoLabel,
	mkIndStaticInfoLabel,
        mkMainCapabilityLabel,
	mkMAP_FROZEN_infoLabel,
61
	mkMAP_DIRTY_infoLabel,
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
        mkEMPTY_MVAR_infoLabel,

	mkTopTickyCtrLabel,
        mkCAFBlackHoleInfoTableLabel,
	mkRtsPrimOpLabel,
	mkRtsSlowTickyCtrLabel,

	moduleRegdLabel,

	mkSelectorInfoLabel,
	mkSelectorEntryLabel,

	mkRtsInfoLabel,
	mkRtsEntryLabel,
	mkRtsRetInfoLabel,
	mkRtsRetLabel,
	mkRtsCodeLabel,
	mkRtsDataLabel,

	mkRtsInfoLabelFS,
	mkRtsEntryLabelFS,
	mkRtsRetInfoLabelFS,
	mkRtsRetLabelFS,
	mkRtsCodeLabelFS,
	mkRtsDataLabelFS,

88
89
	mkRtsApFastLabel,

90
	mkForeignLabel,
91
        addLabelSize,
92
        foreignLabelStdcallInfo,
93
94
95

	mkCCLabel, mkCCSLabel,

96
97
98
99
100
        DynamicLinkerLabelInfo(..),
        mkDynamicLinkerLabel,
        dynamicLinkerLabelInfo,
        
        mkPicBaseLabel,
101
        mkDeadStripPreventer,
102

andy@galois.com's avatar
andy@galois.com committed
103
104
105
        mkHpcTicksLabel,
        mkHpcModuleNameLabel,

106
	infoLblToEntryLbl, entryLblToInfoLbl,
107
	needsCDecl, isAsmTemp, maybeAsmTemp, externallyVisibleCLabel,
108
        isMathFun,
109
	CLabelType(..), labelType, labelDynamic,
110
111
112
113

	pprCLabel
    ) where

114
115
#include "HsVersions.h"

Simon Marlow's avatar
Simon Marlow committed
116
117
118
119
120
121
122
123
124
125
import StaticFlags
import Packages
import DataCon
import PackageConfig
import Module
import Name
import Unique
import PrimOp
import Config
import CostCentre
126
127
import Outputable
import FastString
128
import DynFlags
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167

-- -----------------------------------------------------------------------------
-- The CLabel type

{-
CLabel is an abstract type that supports the following operations:

  - Pretty printing

  - In a C file, does it need to be declared before use?  (i.e. is it
    guaranteed to be already in scope in the places we need to refer to it?)

  - If it needs to be declared, what type (code or data) should it be
    declared to have?

  - Is it visible outside this object file or not?

  - Is it "dynamic" (see details below)

  - Eq and Ord, so that we can make sets of CLabels (currently only
    used in outputting C as far as I can tell, to avoid generating
    more than one declaration for any given label).

  - Converting an info table label into an entry label.
-}

data CLabel
  = IdLabel	    		-- A family of labels related to the
	Name			-- definition of a particular Id or Con
	IdLabelInfo

  | CaseLabel			-- A family of labels related to a particular
				-- case expression.
	{-# UNPACK #-} !Unique	-- Unique says which case expression
	CaseLabelInfo

  | AsmTempLabel 
	{-# UNPACK #-} !Unique

168
169
170
  | StringLitLabel
	{-# UNPACK #-} !Unique

171
172
173
174
175
176
177
178
179
  | ModuleInitLabel 
	Module			-- the module name
	String			-- its "way"
	-- at some point we might want some kind of version number in
	-- the module init label, to guard against compiling modules in
	-- the wrong order.  We can't use the interface file version however,
	-- because we don't always recompile modules which depend on a module
	-- whose version has changed.

180
181
  | PlainModuleInitLabel	-- without the vesrion & way info
	Module
182
183
184
185
186
187
188
189
190
191
192
193
194
195

  | ModuleRegdLabel

  | RtsLabel RtsLabelInfo

  | ForeignLabel FastString	-- a 'C' (or otherwise foreign) label
	(Maybe Int) 		-- possible '@n' suffix for stdcall functions
		-- When generating C, the '@n' suffix is omitted, but when
		-- generating assembler we must add it to the label.
	Bool			-- True <=> is dynamic

  | CC_Label  CostCentre
  | CCS_Label CostCentreStack

196
197
198
199
200
201
202
203
204
205
206
207
208
      -- Dynamic Linking in the NCG:
      -- generated and used inside the NCG only,
      -- see module PositionIndependentCode for details.
      
  | DynamicLinkerLabel DynamicLinkerLabelInfo CLabel
        -- special variants of a label used for dynamic linking

  | PicBaseLabel                -- a label used as a base for PIC calculations
                                -- on some platforms.
                                -- It takes the form of a local numeric
                                -- assembler label '1'; it is pretty-printed
                                -- as 1b, referring to the previous definition
                                -- of 1: in the assembler source file.
209

210
211
212
  | DeadStripPreventer CLabel
    -- label before an info table to prevent excessive dead-stripping on darwin

andy@galois.com's avatar
andy@galois.com committed
213
214
215
  | HpcTicksLabel Module       -- Per-module table of tick locations
  | HpcModuleNameLabel         -- Per-module name of the module for Hpc

216
217
218
  | LargeSRTLabel           -- Label of an StgLargeSRT
        {-# UNPACK #-} !Unique

219
220
221
  | LargeBitmapLabel        -- A bitmap (function or case return)
        {-# UNPACK #-} !Unique

222
223
224
225
226
  deriving (Eq, Ord)

data IdLabelInfo
  = Closure		-- Label for closure
  | SRT                 -- Static reference table
227
  | InfoTable		-- Info tables for closures; always read-only
228
229
230
231
232
233
234
  | Entry		-- entry point
  | Slow		-- slow entry point

  | RednCounts		-- Label of place to keep Ticky-ticky  info for 
			-- this Id

  | ConEntry	  	-- constructor entry point
235
  | ConInfoTable 		-- corresponding info table
236
  | StaticConEntry  	-- static constructor entry point
237
  | StaticInfoTable   	-- corresponding info table
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252

  | ClosureTable	-- table of closures for Enum tycons

  deriving (Eq, Ord)


data CaseLabelInfo
  = CaseReturnPt
  | CaseReturnInfo
  | CaseAlt ConTag
  | CaseDefault
  deriving (Eq, Ord)


data RtsLabelInfo
253
  = RtsSelectorInfoTable Bool{-updatable-} Int{-offset-}	-- Selector thunks
254
255
  | RtsSelectorEntry   Bool{-updatable-} Int{-offset-}

256
  | RtsApInfoTable Bool{-updatable-} Int{-arity-}	        -- AP thunks
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
  | RtsApEntry   Bool{-updatable-} Int{-arity-}

  | RtsPrimOp PrimOp

  | RtsInfo       LitString	-- misc rts info tables
  | RtsEntry      LitString	-- misc rts entry points
  | RtsRetInfo    LitString	-- misc rts ret info tables
  | RtsRet        LitString	-- misc rts return points
  | RtsData       LitString	-- misc rts data bits, eg CHARLIKE_closure
  | RtsCode       LitString	-- misc rts code

  | RtsInfoFS     FastString	-- misc rts info tables
  | RtsEntryFS    FastString	-- misc rts entry points
  | RtsRetInfoFS  FastString	-- misc rts ret info tables
  | RtsRetFS      FastString	-- misc rts return points
  | RtsDataFS     FastString	-- misc rts data bits, eg CHARLIKE_closure
  | RtsCodeFS     FastString	-- misc rts code

275
276
  | RtsApFast	LitString	-- _fast versions of generic apply

277
278
279
280
281
282
  | RtsSlowTickyCtr String

  deriving (Eq, Ord)
	-- NOTE: Eq on LitString compares the pointer only, so this isn't
	-- a real equality.

283
284
285
286
287
288
289
290
data DynamicLinkerLabelInfo
  = CodeStub            -- MachO: Lfoo$stub, ELF: foo@plt
  | SymbolPtr           -- MachO: Lfoo$non_lazy_ptr, Windows: __imp_foo
  | GotSymbolPtr        -- ELF: foo@got
  | GotSymbolOffset     -- ELF: foo@gotoff
  
  deriving (Eq, Ord)
  
291
292
293
-- -----------------------------------------------------------------------------
-- Constructing CLabels

294
295
296
297
298
299
300
301
302
303
304
-- These are always local:
mkSRTLabel		name 	= IdLabel name  SRT
mkSlowEntryLabel      	name 	= IdLabel name  Slow
mkRednCountsLabel     	name 	= IdLabel name  RednCounts

-- These have local & (possibly) external variants:
mkLocalClosureLabel	name 	= IdLabel name  Closure
mkLocalInfoTableLabel  	name 	= IdLabel name  InfoTable
mkLocalEntryLabel	name 	= IdLabel name  Entry
mkLocalClosureTableLabel name	= IdLabel name ClosureTable

305
306
307
308
309
310
311
312
313
314
mkClosureLabel name             = IdLabel name Closure
mkInfoTableLabel name           = IdLabel name InfoTable
mkEntryLabel name               = IdLabel name Entry
mkClosureTableLabel name        = IdLabel name ClosureTable
mkLocalConInfoTableLabel    con = IdLabel con ConInfoTable
mkLocalConEntryLabel	    con = IdLabel con ConEntry
mkLocalStaticInfoTableLabel con = IdLabel con StaticInfoTable
mkLocalStaticConEntryLabel  con = IdLabel con StaticConEntry
mkConInfoTableLabel name        = IdLabel    name ConInfoTable
mkStaticInfoTableLabel name     = IdLabel    name StaticInfoTable
315

316
317
mkConEntryLabel name            = IdLabel name ConEntry
mkStaticConEntryLabel name      = IdLabel name StaticConEntry
318

319
mkLargeSRTLabel	uniq 	= LargeSRTLabel uniq
320
mkBitmapLabel	uniq 	= LargeBitmapLabel uniq
321
322
323
324
325
326

mkReturnPtLabel uniq		= CaseLabel uniq CaseReturnPt
mkReturnInfoLabel uniq		= CaseLabel uniq CaseReturnInfo
mkAltLabel      uniq tag	= CaseLabel uniq (CaseAlt tag)
mkDefaultLabel  uniq 		= CaseLabel uniq CaseDefault

327
mkStringLitLabel		= StringLitLabel
328
329
mkAsmTempLabel :: Uniquable a => a -> CLabel
mkAsmTempLabel a		= AsmTempLabel (getUnique a)
330

331
332
mkModuleInitLabel :: Module -> String -> CLabel
mkModuleInitLabel mod way        = ModuleInitLabel mod way
333

334
335
mkPlainModuleInitLabel :: Module -> CLabel
mkPlainModuleInitLabel mod       = PlainModuleInitLabel mod
336
337
338

	-- Some fixed runtime system labels

Ian Lynagh's avatar
Ian Lynagh committed
339
340
341
342
343
344
345
346
347
348
349
mkSplitMarkerLabel		= RtsLabel (RtsCode (sLit "__stg_split_marker"))
mkDirty_MUT_VAR_Label		= RtsLabel (RtsCode (sLit "dirty_MUT_VAR"))
mkUpdInfoLabel			= RtsLabel (RtsInfo (sLit "stg_upd_frame"))
mkIndStaticInfoLabel		= RtsLabel (RtsInfo (sLit "stg_IND_STATIC"))
mkMainCapabilityLabel		= RtsLabel (RtsData (sLit "MainCapability"))
mkMAP_FROZEN_infoLabel		= RtsLabel (RtsInfo (sLit "stg_MUT_ARR_PTRS_FROZEN0"))
mkMAP_DIRTY_infoLabel		= RtsLabel (RtsInfo (sLit "stg_MUT_ARR_PTRS_DIRTY"))
mkEMPTY_MVAR_infoLabel		= RtsLabel (RtsInfo (sLit "stg_EMPTY_MVAR"))

mkTopTickyCtrLabel		= RtsLabel (RtsData (sLit "top_ct"))
mkCAFBlackHoleInfoTableLabel	= RtsLabel (RtsInfo (sLit "stg_CAF_BLACKHOLE"))
350
351
352
353
mkRtsPrimOpLabel primop		= RtsLabel (RtsPrimOp primop)

moduleRegdLabel			= ModuleRegdLabel

354
mkSelectorInfoLabel  upd off	= RtsLabel (RtsSelectorInfoTable upd off)
355
356
mkSelectorEntryLabel upd off	= RtsLabel (RtsSelectorEntry   upd off)

357
mkApInfoTableLabel  upd off	= RtsLabel (RtsApInfoTable upd off)
358
359
360
361
362
363
364
mkApEntryLabel upd off		= RtsLabel (RtsApEntry   upd off)

	-- Foreign labels

mkForeignLabel :: FastString -> Maybe Int -> Bool -> CLabel
mkForeignLabel str mb_sz  is_dynamic = ForeignLabel str mb_sz is_dynamic

365
366
367
368
369
370
addLabelSize :: CLabel -> Int -> CLabel
addLabelSize (ForeignLabel str _ is_dynamic) sz
  = ForeignLabel str (Just sz) is_dynamic
addLabelSize label _
  = label

371
372
373
374
foreignLabelStdcallInfo :: CLabel -> Maybe Int
foreignLabelStdcallInfo (ForeignLabel _ info _) = info
foreignLabelStdcallInfo _lbl = Nothing

375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
	-- Cost centres etc.

mkCCLabel	cc		= CC_Label cc
mkCCSLabel	ccs		= CCS_Label ccs

mkRtsInfoLabel      str = RtsLabel (RtsInfo      str)
mkRtsEntryLabel     str = RtsLabel (RtsEntry     str)
mkRtsRetInfoLabel   str = RtsLabel (RtsRetInfo   str)
mkRtsRetLabel       str = RtsLabel (RtsRet       str)
mkRtsCodeLabel      str = RtsLabel (RtsCode      str)
mkRtsDataLabel      str = RtsLabel (RtsData      str)

mkRtsInfoLabelFS    str = RtsLabel (RtsInfoFS    str)
mkRtsEntryLabelFS   str = RtsLabel (RtsEntryFS   str)
mkRtsRetInfoLabelFS str = RtsLabel (RtsRetInfoFS str)
mkRtsRetLabelFS     str = RtsLabel (RtsRetFS     str)
mkRtsCodeLabelFS    str = RtsLabel (RtsCodeFS    str)
mkRtsDataLabelFS    str = RtsLabel (RtsDataFS    str)

394
395
mkRtsApFastLabel str = RtsLabel (RtsApFast str)

396
397
398
mkRtsSlowTickyCtrLabel :: String -> CLabel
mkRtsSlowTickyCtrLabel pat = RtsLabel (RtsSlowTickyCtr pat)

andy@galois.com's avatar
andy@galois.com committed
399
400
401
402
403
        -- Coverage

mkHpcTicksLabel                = HpcTicksLabel
mkHpcModuleNameLabel           = HpcModuleNameLabel

404
405
406
407
408
409
410
411
412
413
414
415
416
417
        -- Dynamic linking
        
mkDynamicLinkerLabel :: DynamicLinkerLabelInfo -> CLabel -> CLabel
mkDynamicLinkerLabel = DynamicLinkerLabel

dynamicLinkerLabelInfo :: CLabel -> Maybe (DynamicLinkerLabelInfo, CLabel)
dynamicLinkerLabelInfo (DynamicLinkerLabel info lbl) = Just (info, lbl)
dynamicLinkerLabelInfo _ = Nothing

        -- Position independent code
        
mkPicBaseLabel :: CLabel
mkPicBaseLabel = PicBaseLabel

418
419
420
mkDeadStripPreventer :: CLabel -> CLabel
mkDeadStripPreventer lbl = DeadStripPreventer lbl

421
-- -----------------------------------------------------------------------------
Ian Lynagh's avatar
Ian Lynagh committed
422
-- Converting between info labels and entry/ret labels.
423
424

infoLblToEntryLbl :: CLabel -> CLabel 
425
426
427
infoLblToEntryLbl (IdLabel n InfoTable) = IdLabel n Entry
infoLblToEntryLbl (IdLabel n ConInfoTable) = IdLabel n ConEntry
infoLblToEntryLbl (IdLabel n StaticInfoTable) = IdLabel n StaticConEntry
428
429
430
431
432
433
434
435
infoLblToEntryLbl (CaseLabel n CaseReturnInfo) = CaseLabel n CaseReturnPt
infoLblToEntryLbl (RtsLabel (RtsInfo s)) = RtsLabel (RtsEntry s)
infoLblToEntryLbl (RtsLabel (RtsRetInfo s)) = RtsLabel (RtsRet s)
infoLblToEntryLbl (RtsLabel (RtsInfoFS s)) = RtsLabel (RtsEntryFS s)
infoLblToEntryLbl (RtsLabel (RtsRetInfoFS s)) = RtsLabel (RtsRetFS s)
infoLblToEntryLbl _ = panic "CLabel.infoLblToEntryLbl"

entryLblToInfoLbl :: CLabel -> CLabel 
436
437
438
entryLblToInfoLbl (IdLabel n Entry) = IdLabel n InfoTable
entryLblToInfoLbl (IdLabel n ConEntry) = IdLabel n ConInfoTable
entryLblToInfoLbl (IdLabel n StaticConEntry) = IdLabel n StaticInfoTable
439
440
441
442
443
444
445
446
447
entryLblToInfoLbl (CaseLabel n CaseReturnPt) = CaseLabel n CaseReturnInfo
entryLblToInfoLbl (RtsLabel (RtsEntry s)) = RtsLabel (RtsInfo s)
entryLblToInfoLbl (RtsLabel (RtsRet s)) = RtsLabel (RtsRetInfo s)
entryLblToInfoLbl (RtsLabel (RtsEntryFS s)) = RtsLabel (RtsInfoFS s)
entryLblToInfoLbl (RtsLabel (RtsRetFS s)) = RtsLabel (RtsRetInfoFS s)
entryLblToInfoLbl l = pprPanic "CLabel.entryLblToInfoLbl" (pprCLabel l)

-- -----------------------------------------------------------------------------
-- Does a CLabel need declaring before use or not?
448
449
--
-- See wiki:Commentary/Compiler/Backends/PprC#Prototypes
450
451
452
453
454
455

needsCDecl :: CLabel -> Bool
  -- False <=> it's pre-declared; don't bother
  -- don't bother declaring SRT & Bitmap labels, we always make sure
  -- they are defined before use.
needsCDecl (IdLabel _ SRT)		= False
456
needsCDecl (LargeSRTLabel _)		= False
457
needsCDecl (LargeBitmapLabel _)		= False
458
needsCDecl (IdLabel _ _)		= True
459
needsCDecl (CaseLabel _ _)	        = True
460
461
needsCDecl (ModuleInitLabel _ _)	= True
needsCDecl (PlainModuleInitLabel _)	= True
462
463
needsCDecl ModuleRegdLabel		= False

464
needsCDecl (StringLitLabel _)		= False
465
466
needsCDecl (AsmTempLabel _)		= False
needsCDecl (RtsLabel _)			= False
467
needsCDecl l@(ForeignLabel _ _ _)	= not (isMathFun l)
468
469
needsCDecl (CC_Label _)			= True
needsCDecl (CCS_Label _)		= True
andy@galois.com's avatar
andy@galois.com committed
470
471
needsCDecl (HpcTicksLabel _)            = True
needsCDecl HpcModuleNameLabel           = False
472
473
474
475
476
477
478

-- Whether the label is an assembler temporary:

isAsmTemp  :: CLabel -> Bool    -- is a local temporary for native code generation
isAsmTemp (AsmTempLabel _) = True
isAsmTemp _ 	    	   = False

479
480
481
482
maybeAsmTemp :: CLabel -> Maybe Unique
maybeAsmTemp (AsmTempLabel uq) = Just uq
maybeAsmTemp _ 	    	       = Nothing

483
484
485
486
487
488
489
-- some labels have C prototypes in scope when compiling via C, because
-- they are builtin to the C compiler.  For these labels we avoid
-- generating our own C prototypes.
isMathFun :: CLabel -> Bool
isMathFun (ForeignLabel fs _ _) = fs `elem` math_funs
  where
  math_funs = [
Ian Lynagh's avatar
Ian Lynagh committed
490
491
492
493
494
495
496
497
        (fsLit "pow"),    (fsLit "sin"),   (fsLit "cos"),
        (fsLit "tan"),    (fsLit "sinh"),  (fsLit "cosh"),
        (fsLit "tanh"),   (fsLit "asin"),  (fsLit "acos"),
        (fsLit "atan"),   (fsLit "log"),   (fsLit "exp"),
        (fsLit "sqrt"),   (fsLit "powf"),  (fsLit "sinf"),
        (fsLit "cosf"),   (fsLit "tanf"),  (fsLit "sinhf"),
        (fsLit "coshf"),  (fsLit "tanhf"), (fsLit "asinf"),
        (fsLit "acosf"),  (fsLit "atanf"), (fsLit "logf"),
498
499
500
501
502
503
504
505
506
507
        (fsLit "expf"),   (fsLit "sqrtf"), (fsLit "frexp"),
        (fsLit "modf"),   (fsLit "ilogb"), (fsLit "copysign"),
        (fsLit "remainder"), (fsLit "nextafter"), (fsLit "logb"),
        (fsLit "cbrt"),   (fsLit "atanh"), (fsLit "asinh"),
        (fsLit "acosh"),  (fsLit "lgamma"),(fsLit "hypot"),
        (fsLit "erfc"),   (fsLit "erf"),   (fsLit "trunc"),
        (fsLit "round"),  (fsLit "fmod"),  (fsLit "floor"),
        (fsLit "fabs"),   (fsLit "ceil"),  (fsLit "log10"),
        (fsLit "ldexp"),  (fsLit "atan2"), (fsLit "rint")
    ]
508
509
isMathFun _ = False

510
511
512
513
514
515
516
517
518
-- -----------------------------------------------------------------------------
-- Is a CLabel visible outside this object file or not?

-- From the point of view of the code generator, a name is
-- externally visible if it has to be declared as exported
-- in the .o file's symbol table; that is, made non-static.

externallyVisibleCLabel :: CLabel -> Bool -- not C "static"
externallyVisibleCLabel (CaseLabel _ _)	   = False
519
externallyVisibleCLabel (StringLitLabel _) = False
520
externallyVisibleCLabel (AsmTempLabel _)   = False
521
522
externallyVisibleCLabel (ModuleInitLabel _ _) = True
externallyVisibleCLabel (PlainModuleInitLabel _)= True
523
524
525
externallyVisibleCLabel ModuleRegdLabel    = False
externallyVisibleCLabel (RtsLabel _)	   = True
externallyVisibleCLabel (ForeignLabel _ _ _) = True
526
527
externallyVisibleCLabel (IdLabel name SRT)   = False
                         -- SRTs don't need to be external
528
externallyVisibleCLabel (IdLabel name _)     = isExternalName name
529
530
externallyVisibleCLabel (CC_Label _)	   = True
externallyVisibleCLabel (CCS_Label _)	   = True
531
externallyVisibleCLabel (DynamicLinkerLabel _ _)  = False
andy@galois.com's avatar
andy@galois.com committed
532
533
externallyVisibleCLabel (HpcTicksLabel _)   = True
externallyVisibleCLabel HpcModuleNameLabel      = False
534
535
externallyVisibleCLabel (LargeBitmapLabel _) = False
externallyVisibleCLabel (LargeSRTLabel _) = False
536
537
538
539
540
541
542
543
544
545
546

-- -----------------------------------------------------------------------------
-- Finding the "type" of a CLabel 

-- For generating correct types in label declarations:

data CLabelType
  = CodeLabel
  | DataLabel

labelType :: CLabel -> CLabelType
547
548
labelType (RtsLabel (RtsSelectorInfoTable _ _)) = DataLabel
labelType (RtsLabel (RtsApInfoTable _ _))       = DataLabel
549
550
551
552
553
554
555
556
557
558
559
560
labelType (RtsLabel (RtsData _))              = DataLabel
labelType (RtsLabel (RtsCode _))              = CodeLabel
labelType (RtsLabel (RtsInfo _))              = DataLabel
labelType (RtsLabel (RtsEntry _))             = CodeLabel
labelType (RtsLabel (RtsRetInfo _))           = DataLabel
labelType (RtsLabel (RtsRet _))               = CodeLabel
labelType (RtsLabel (RtsDataFS _))            = DataLabel
labelType (RtsLabel (RtsCodeFS _))            = CodeLabel
labelType (RtsLabel (RtsInfoFS _))            = DataLabel
labelType (RtsLabel (RtsEntryFS _))           = CodeLabel
labelType (RtsLabel (RtsRetInfoFS _))         = DataLabel
labelType (RtsLabel (RtsRetFS _))             = CodeLabel
561
labelType (RtsLabel (RtsApFast _))            = CodeLabel
562
labelType (CaseLabel _ CaseReturnInfo)        = DataLabel
563
labelType (CaseLabel _ _)	              = CodeLabel
564
565
labelType (ModuleInitLabel _ _)               = CodeLabel
labelType (PlainModuleInitLabel _)            = CodeLabel
566
567
labelType (LargeSRTLabel _)                   = DataLabel
labelType (LargeBitmapLabel _)                = DataLabel
568

569
570
571
572
labelType (IdLabel _ info) = idInfoLabelType info
labelType _        = DataLabel

idInfoLabelType info =
573
  case info of
574
    InfoTable  	  -> DataLabel
575
    Closure    	  -> DataLabel
576
577
    ConInfoTable  -> DataLabel
    StaticInfoTable -> DataLabel
578
    ClosureTable  -> DataLabel
579
580
-- krc: aie! a ticky counter label is data
    RednCounts    -> DataLabel
581
582
583
584
585
586
587
588
589
590
591
    _	          -> CodeLabel


-- -----------------------------------------------------------------------------
-- Does a CLabel need dynamic linkage?

-- When referring to data in code, we need to know whether
-- that data resides in a DLL or not. [Win32 only.]
-- @labelDynamic@ returns @True@ if the label is located
-- in a DLL, be it a data reference or not.

592
593
labelDynamic :: PackageId -> CLabel -> Bool
labelDynamic this_pkg lbl =
594
  case lbl of
595
596
   RtsLabel _  	     -> not opt_Static && (this_pkg /= rtsPackageId) -- i.e., is the RTS in a DLL or not?
   IdLabel n k       -> isDllName this_pkg n
597
#if mingw32_TARGET_OS
598
   ForeignLabel _ _ d  -> d
599
600
601
602
603
#else
   -- On Mac OS X and on ELF platforms, false positives are OK,
   -- so we claim that all foreign imports come from dynamic libraries
   ForeignLabel _ _ _ -> True
#endif
604
605
   ModuleInitLabel m _    -> not opt_Static && this_pkg /= (modulePackageId m)
   PlainModuleInitLabel m -> not opt_Static && this_pkg /= (modulePackageId m)
606
607
   
   -- Note that DynamicLinkerLabels do NOT require dynamic linking themselves.
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
   _ 		     -> False

{-
OLD?: These GRAN functions are needed for spitting out GRAN_FETCH() at the
right places. It is used to detect when the abstractC statement of an
CCodeBlock actually contains the code for a slow entry point.  -- HWL

We need at least @Eq@ for @CLabels@, because we want to avoid
duplicate declarations in generating C (see @labelSeenTE@ in
@PprAbsC@).
-}

-----------------------------------------------------------------------------
-- Printing out CLabels.

{-
Convention:

      <name>_<type>

where <name> is <Module>_<name> for external names and <unique> for
internal names. <type> is one of the following:

	 info			Info table
	 srt			Static reference table
	 srtd			Static reference table descriptor
	 entry			Entry code (function, closure)
	 slow			Slow entry code (if any)
	 ret			Direct return address	 
	 vtbl			Vector table
	 <n>_alt		Case alternative (tag n)
	 dflt			Default case alternative
	 btm			Large bitmap vector
	 closure		Static closure
	 con_entry		Dynamic Constructor entry code
	 con_info		Dynamic Constructor info table
	 static_entry		Static Constructor entry code
	 static_info		Static Constructor info table
	 sel_info		Selector info table
	 sel_entry		Selector entry code
	 cc			Cost centre
	 ccs			Cost centre stack

Many of these distinctions are only for documentation reasons.  For
example, _ret is only distinguished from _entry to make it easy to
tell whether a code fragment is a return point or a closure/function
entry.
-}

Simon Marlow's avatar
Simon Marlow committed
657
658
659
instance Outputable CLabel where
  ppr = pprCLabel

660
661
662
663
664
665
666
667
668
pprCLabel :: CLabel -> SDoc

#if ! OMIT_NATIVE_CODEGEN
pprCLabel (AsmTempLabel u)
  =  getPprStyle $ \ sty ->
     if asmStyle sty then 
	ptext asmTempLabelPrefix <> pprUnique u
     else
	char '_' <> pprUnique u
669
670
671
672
673

pprCLabel (DynamicLinkerLabel info lbl)
   = pprDynamicLinkerAsmLabel info lbl
   
pprCLabel PicBaseLabel
Ian Lynagh's avatar
Ian Lynagh committed
674
   = ptext (sLit "1b")
675
676
   
pprCLabel (DeadStripPreventer lbl)
Ian Lynagh's avatar
Ian Lynagh committed
677
   = pprCLabel lbl <> ptext (sLit "_dsp")
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
#endif

pprCLabel lbl = 
#if ! OMIT_NATIVE_CODEGEN
    getPprStyle $ \ sty ->
    if asmStyle sty then 
	maybe_underscore (pprAsmCLbl lbl)
    else
#endif
       pprCLbl lbl

maybe_underscore doc
  | underscorePrefix = pp_cSEP <> doc
  | otherwise        = doc

693
#ifdef mingw32_TARGET_OS
694
695
696
697
-- In asm mode, we need to put the suffix on a stdcall ForeignLabel.
-- (The C compiler does this itself).
pprAsmCLbl (ForeignLabel fs (Just sz) _)
   = ftext fs <> char '@' <> int sz
698
#endif
699
700
701
pprAsmCLbl lbl
   = pprCLbl lbl

702
pprCLbl (StringLitLabel u)
Ian Lynagh's avatar
Ian Lynagh committed
703
  = pprUnique u <> ptext (sLit "_str")
704

705
pprCLbl (CaseLabel u CaseReturnPt)
Ian Lynagh's avatar
Ian Lynagh committed
706
  = hcat [pprUnique u, ptext (sLit "_ret")]
707
pprCLbl (CaseLabel u CaseReturnInfo)
Ian Lynagh's avatar
Ian Lynagh committed
708
  = hcat [pprUnique u, ptext (sLit "_info")]
709
pprCLbl (CaseLabel u (CaseAlt tag))
Ian Lynagh's avatar
Ian Lynagh committed
710
  = hcat [pprUnique u, pp_cSEP, int tag, ptext (sLit "_alt")]
711
pprCLbl (CaseLabel u CaseDefault)
Ian Lynagh's avatar
Ian Lynagh committed
712
  = hcat [pprUnique u, ptext (sLit "_dflt")]
713

Ian Lynagh's avatar
Ian Lynagh committed
714
715
pprCLbl (LargeSRTLabel u)  = pprUnique u <> pp_cSEP <> ptext (sLit "srtd")
pprCLbl (LargeBitmapLabel u)  = text "b" <> pprUnique u <> pp_cSEP <> ptext (sLit "btm")
716
717
718
719
-- Some bitsmaps for tuple constructors have a numeric tag (e.g. '7')
-- until that gets resolved we'll just force them to start
-- with a letter so the label will be legal assmbly code.
        
720

721
722
723
724
725
pprCLbl (RtsLabel (RtsCode str))   = ptext str
pprCLbl (RtsLabel (RtsData str))   = ptext str
pprCLbl (RtsLabel (RtsCodeFS str)) = ftext str
pprCLbl (RtsLabel (RtsDataFS str)) = ftext str

Ian Lynagh's avatar
Ian Lynagh committed
726
pprCLbl (RtsLabel (RtsApFast str)) = ptext str <> ptext (sLit "_fast")
727

728
pprCLbl (RtsLabel (RtsSelectorInfoTable upd_reqd offset))
Ian Lynagh's avatar
Ian Lynagh committed
729
  = hcat [ptext (sLit "stg_sel_"), text (show offset),
730
		ptext (if upd_reqd 
Ian Lynagh's avatar
Ian Lynagh committed
731
732
			then (sLit "_upd_info") 
			else (sLit "_noupd_info"))
733
734
735
	]

pprCLbl (RtsLabel (RtsSelectorEntry upd_reqd offset))
Ian Lynagh's avatar
Ian Lynagh committed
736
  = hcat [ptext (sLit "stg_sel_"), text (show offset),
737
		ptext (if upd_reqd 
Ian Lynagh's avatar
Ian Lynagh committed
738
739
			then (sLit "_upd_entry") 
			else (sLit "_noupd_entry"))
740
741
	]

742
pprCLbl (RtsLabel (RtsApInfoTable upd_reqd arity))
Ian Lynagh's avatar
Ian Lynagh committed
743
  = hcat [ptext (sLit "stg_ap_"), text (show arity),
744
		ptext (if upd_reqd 
Ian Lynagh's avatar
Ian Lynagh committed
745
746
			then (sLit "_upd_info") 
			else (sLit "_noupd_info"))
747
748
749
	]

pprCLbl (RtsLabel (RtsApEntry upd_reqd arity))
Ian Lynagh's avatar
Ian Lynagh committed
750
  = hcat [ptext (sLit "stg_ap_"), text (show arity),
751
		ptext (if upd_reqd 
Ian Lynagh's avatar
Ian Lynagh committed
752
753
			then (sLit "_upd_entry") 
			else (sLit "_noupd_entry"))
754
755
756
	]

pprCLbl (RtsLabel (RtsInfo fs))
Ian Lynagh's avatar
Ian Lynagh committed
757
  = ptext fs <> ptext (sLit "_info")
758
759

pprCLbl (RtsLabel (RtsEntry fs))
Ian Lynagh's avatar
Ian Lynagh committed
760
  = ptext fs <> ptext (sLit "_entry")
761
762

pprCLbl (RtsLabel (RtsRetInfo fs))
Ian Lynagh's avatar
Ian Lynagh committed
763
  = ptext fs <> ptext (sLit "_info")
764
765

pprCLbl (RtsLabel (RtsRet fs))
Ian Lynagh's avatar
Ian Lynagh committed
766
  = ptext fs <> ptext (sLit "_ret")
767
768

pprCLbl (RtsLabel (RtsInfoFS fs))
Ian Lynagh's avatar
Ian Lynagh committed
769
  = ftext fs <> ptext (sLit "_info")
770
771

pprCLbl (RtsLabel (RtsEntryFS fs))
Ian Lynagh's avatar
Ian Lynagh committed
772
  = ftext fs <> ptext (sLit "_entry")
773
774

pprCLbl (RtsLabel (RtsRetInfoFS fs))
Ian Lynagh's avatar
Ian Lynagh committed
775
  = ftext fs <> ptext (sLit "_info")
776
777

pprCLbl (RtsLabel (RtsRetFS fs))
Ian Lynagh's avatar
Ian Lynagh committed
778
  = ftext fs <> ptext (sLit "_ret")
779
780

pprCLbl (RtsLabel (RtsPrimOp primop)) 
Ian Lynagh's avatar
Ian Lynagh committed
781
  = ppr primop <> ptext (sLit "_fast")
782
783

pprCLbl (RtsLabel (RtsSlowTickyCtr pat)) 
Ian Lynagh's avatar
Ian Lynagh committed
784
  = ptext (sLit "SLOW_CALL_") <> text pat <> ptext (sLit "_ctr")
785
786

pprCLbl ModuleRegdLabel
Ian Lynagh's avatar
Ian Lynagh committed
787
  = ptext (sLit "_module_registered")
788
789
790
791

pprCLbl (ForeignLabel str _ _)
  = ftext str

792
pprCLbl (IdLabel name  flavor) = ppr name <> ppIdFlavor flavor
793
794
795
796

pprCLbl (CC_Label cc) 		= ppr cc
pprCLbl (CCS_Label ccs) 	= ppr ccs

797
pprCLbl (ModuleInitLabel mod way)
Ian Lynagh's avatar
Ian Lynagh committed
798
   = ptext (sLit "__stginit_") <> ppr mod
799
	<> char '_' <> text way
800
pprCLbl (PlainModuleInitLabel mod)
Ian Lynagh's avatar
Ian Lynagh committed
801
   = ptext (sLit "__stginit_") <> ppr mod
802

andy@galois.com's avatar
andy@galois.com committed
803
pprCLbl (HpcTicksLabel mod)
Ian Lynagh's avatar
Ian Lynagh committed
804
  = ptext (sLit "_hpc_tickboxes_")  <> ppr mod <> ptext (sLit "_hpc")
andy@galois.com's avatar
andy@galois.com committed
805

andy@galois.com's avatar
andy@galois.com committed
806
pprCLbl HpcModuleNameLabel
Ian Lynagh's avatar
Ian Lynagh committed
807
  = ptext (sLit "_hpc_module_name_str")
andy@galois.com's avatar
andy@galois.com committed
808

809
810
811
ppIdFlavor :: IdLabelInfo -> SDoc
ppIdFlavor x = pp_cSEP <>
	       (case x of
Ian Lynagh's avatar
Ian Lynagh committed
812
813
814
815
816
817
818
819
820
821
822
		       Closure	    	-> ptext (sLit "closure")
		       SRT		-> ptext (sLit "srt")
		       InfoTable    	-> ptext (sLit "info")
		       Entry	    	-> ptext (sLit "entry")
		       Slow	    	-> ptext (sLit "slow")
		       RednCounts	-> ptext (sLit "ct")
		       ConEntry	    	-> ptext (sLit "con_entry")
		       ConInfoTable    	-> ptext (sLit "con_info")
		       StaticConEntry  	-> ptext (sLit "static_entry")
		       StaticInfoTable 	-> ptext (sLit "static_info")
		       ClosureTable     -> ptext (sLit "closure_tbl")
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
		      )


pp_cSEP = char '_'

-- -----------------------------------------------------------------------------
-- Machine-dependent knowledge about labels.

underscorePrefix :: Bool   -- leading underscore on assembler labels?
underscorePrefix = (cLeadingUnderscore == "YES")

asmTempLabelPrefix :: LitString  -- for formatting labels
asmTempLabelPrefix =
#if alpha_TARGET_OS
     {- The alpha assembler likes temporary labels to look like $L123
	instead of L123.  (Don't toss the L, because then Lf28
	turns into $f28.)
     -}
Ian Lynagh's avatar
Ian Lynagh committed
841
     (sLit "$")
842
#elif darwin_TARGET_OS
Ian Lynagh's avatar
Ian Lynagh committed
843
     (sLit "L")
844
#else
Ian Lynagh's avatar
Ian Lynagh committed
845
     (sLit ".L")
846
#endif
847
848
849

pprDynamicLinkerAsmLabel :: DynamicLinkerLabelInfo -> CLabel -> SDoc

850
851
852
853
854
855
856
857
#if x86_64_TARGET_ARCH && darwin_TARGET_OS
pprDynamicLinkerAsmLabel GotSymbolPtr lbl
  = pprCLabel lbl <> text "@GOTPCREL"
pprDynamicLinkerAsmLabel GotSymbolOffset lbl
  = pprCLabel lbl
pprDynamicLinkerAsmLabel _ _
  = panic "pprDynamicLinkerAsmLabel"
#elif darwin_TARGET_OS
858
859
pprDynamicLinkerAsmLabel CodeStub lbl
  = char 'L' <> pprCLabel lbl <> text "$stub"
860
861
862
863
pprDynamicLinkerAsmLabel SymbolPtr lbl
  = char 'L' <> pprCLabel lbl <> text "$non_lazy_ptr"
pprDynamicLinkerAsmLabel _ _
  = panic "pprDynamicLinkerAsmLabel"
864
865
866
867
868
#elif powerpc_TARGET_ARCH && linux_TARGET_OS
pprDynamicLinkerAsmLabel CodeStub lbl
  = pprCLabel lbl <> text "@plt"
pprDynamicLinkerAsmLabel SymbolPtr lbl
  = text ".LC_" <> pprCLabel lbl
869
870
pprDynamicLinkerAsmLabel _ _
  = panic "pprDynamicLinkerAsmLabel"
871
872
873
874
875
876
877
#elif x86_64_TARGET_ARCH && linux_TARGET_OS
pprDynamicLinkerAsmLabel CodeStub lbl
  = pprCLabel lbl <> text "@plt"
pprDynamicLinkerAsmLabel GotSymbolPtr lbl
  = pprCLabel lbl <> text "@gotpcrel"
pprDynamicLinkerAsmLabel GotSymbolOffset lbl
  = pprCLabel lbl
878
879
pprDynamicLinkerAsmLabel SymbolPtr lbl
  = text ".LC_" <> pprCLabel lbl
880
881
882
#elif linux_TARGET_OS
pprDynamicLinkerAsmLabel CodeStub lbl
  = pprCLabel lbl <> text "@plt"
883
884
pprDynamicLinkerAsmLabel SymbolPtr lbl
  = text ".LC_" <> pprCLabel lbl
885
886
887
888
889
890
891
pprDynamicLinkerAsmLabel GotSymbolPtr lbl
  = pprCLabel lbl <> text "@got"
pprDynamicLinkerAsmLabel GotSymbolOffset lbl
  = pprCLabel lbl <> text "@gotoff"
#elif mingw32_TARGET_OS
pprDynamicLinkerAsmLabel SymbolPtr lbl
  = text "__imp_" <> pprCLabel lbl
892
893
894
pprDynamicLinkerAsmLabel _ _
  = panic "pprDynamicLinkerAsmLabel"
#else
895
896
pprDynamicLinkerAsmLabel _ _
  = panic "pprDynamicLinkerAsmLabel"
897
#endif