CLabel.hs 26.9 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
-----------------------------------------------------------------------------
--
-- Object-file symbols (called CLabel for histerical raisins).
--
-- (c) The University of Glasgow 2004
--
-----------------------------------------------------------------------------

module CLabel (
	CLabel,	-- abstract type

	mkClosureLabel,
	mkSRTLabel,
	mkSRTDescLabel,
	mkInfoTableLabel,
	mkEntryLabel,
	mkSlowEntryLabel,
	mkConEntryLabel,
	mkStaticConEntryLabel,
	mkRednCountsLabel,
	mkConInfoTableLabel,
	mkStaticInfoTableLabel,
	mkApEntryLabel,
	mkApInfoTableLabel,
25
26
27
28
29
30
31
32
33
34
	mkClosureTableLabel,

	mkLocalClosureLabel,
	mkLocalInfoTableLabel,
	mkLocalEntryLabel,
	mkLocalConEntryLabel,
	mkLocalStaticConEntryLabel,
	mkLocalConInfoTableLabel,
	mkLocalStaticInfoTableLabel,
	mkLocalClosureTableLabel,
35
36
37
38
39
40

	mkReturnPtLabel,
	mkReturnInfoLabel,
	mkAltLabel,
	mkDefaultLabel,
	mkBitmapLabel,
41
	mkStringLitLabel,
42
43
44
45
46
47
48

	mkAsmTempLabel,

	mkModuleInitLabel,
	mkPlainModuleInitLabel,

	mkSplitMarkerLabel,
49
	mkDirty_MUT_VAR_Label,
50
51
52
53
54
	mkUpdInfoLabel,
	mkSeqInfoLabel,
	mkIndStaticInfoLabel,
        mkMainCapabilityLabel,
	mkMAP_FROZEN_infoLabel,
55
	mkMAP_DIRTY_infoLabel,
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
        mkEMPTY_MVAR_infoLabel,

	mkTopTickyCtrLabel,
        mkCAFBlackHoleInfoTableLabel,
        mkSECAFBlackHoleInfoTableLabel,
	mkRtsPrimOpLabel,
	mkRtsSlowTickyCtrLabel,

	moduleRegdLabel,

	mkSelectorInfoLabel,
	mkSelectorEntryLabel,

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

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

83
84
	mkRtsApFastLabel,

85
86
87
88
	mkForeignLabel,

	mkCCLabel, mkCCSLabel,

89
90
91
92
93
        DynamicLinkerLabelInfo(..),
        mkDynamicLinkerLabel,
        dynamicLinkerLabelInfo,
        
        mkPicBaseLabel,
94
        mkDeadStripPreventer,
95

96
97
	infoLblToEntryLbl, entryLblToInfoLbl,
	needsCDecl, isAsmTemp, externallyVisibleCLabel,
98
	CLabelType(..), labelType, labelDynamic,
99
100
101
102
103
104
105

	pprCLabel
    ) where


#include "HsVersions.h"

106
import StaticFlags	( opt_Static, opt_DoTickyProfiling )
Simon Marlow's avatar
Simon Marlow committed
107
import Packages		( isDllName )
108
import DataCon		( ConTag )
Simon Marlow's avatar
Simon Marlow committed
109
110
import PackageConfig	( PackageId )
import Module		( Module, modulePackageId )
111
import Name		( Name, isExternalName )
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
import Unique		( pprUnique, Unique )
import PrimOp		( PrimOp )
import Config		( cLeadingUnderscore )
import CostCentre	( CostCentre, CostCentreStack )
import Outputable
import FastString

-- -----------------------------------------------------------------------------
-- 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

149
150
151
152
  | DynIdLabel			-- like IdLabel, but in a separate package,
	Name			-- and might therefore need a dynamic
	IdLabelInfo		-- reference.

153
154
155
156
157
158
159
160
  | CaseLabel			-- A family of labels related to a particular
				-- case expression.
	{-# UNPACK #-} !Unique	-- Unique says which case expression
	CaseLabelInfo

  | AsmTempLabel 
	{-# UNPACK #-} !Unique

161
162
163
  | StringLitLabel
	{-# UNPACK #-} !Unique

164
165
166
  | ModuleInitLabel 
	Module			-- the module name
	String			-- its "way"
167
	Bool			-- True <=> is in a different package
168
169
170
171
172
173
	-- 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.

174
175
176
  | PlainModuleInitLabel	-- without the vesrion & way info
	Module
	Bool			-- True <=> is in a different package
177
178
179
180
181
182
183
184
185
186
187
188
189
190

  | 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

191
192
193
194
195
196
197
198
199
200
201
202
203
      -- 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.
204

205
206
207
  | DeadStripPreventer CLabel
    -- label before an info table to prevent excessive dead-stripping on darwin

208
209
210
211
212
213
  deriving (Eq, Ord)

data IdLabelInfo
  = Closure		-- Label for closure
  | SRT                 -- Static reference table
  | SRTDesc             -- Static reference table descriptor
214
  | InfoTable		-- Info tables for closures; always read-only
215
216
217
218
219
220
221
222
223
  | Entry		-- entry point
  | Slow		-- slow entry point

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

  | Bitmap		-- A bitmap (function or case return)

  | ConEntry	  	-- constructor entry point
224
  | ConInfoTable 		-- corresponding info table
225
  | StaticConEntry  	-- static constructor entry point
226
  | StaticInfoTable   	-- corresponding info table
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241

  | ClosureTable	-- table of closures for Enum tycons

  deriving (Eq, Ord)


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


data RtsLabelInfo
242
  = RtsSelectorInfoTable Bool{-updatable-} Int{-offset-}	-- Selector thunks
243
244
  | RtsSelectorEntry   Bool{-updatable-} Int{-offset-}

245
  | RtsApInfoTable Bool{-updatable-} Int{-arity-}	        -- AP thunks
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
  | 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

264
265
  | RtsApFast	LitString	-- _fast versions of generic apply

266
267
268
269
270
271
  | RtsSlowTickyCtr String

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

272
273
274
275
276
277
278
279
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)
  
280
281
282
-- -----------------------------------------------------------------------------
-- Constructing CLabels

283
284
285
286
287
288
289
290
291
292
293
294
295
-- These are always local:
mkSRTLabel		name 	= IdLabel name  SRT
mkSRTDescLabel		name 	= IdLabel name  SRTDesc
mkSlowEntryLabel      	name 	= IdLabel name  Slow
mkBitmapLabel   	name 	= IdLabel name  Bitmap
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

Simon Marlow's avatar
Simon Marlow committed
296
297
mkClosureLabel this_pkg name
  | isDllName this_pkg name = DynIdLabel    name Closure
298
  | otherwise             = IdLabel name Closure
299

Simon Marlow's avatar
Simon Marlow committed
300
301
mkInfoTableLabel this_pkg name
  | isDllName this_pkg name = DynIdLabel    name InfoTable
302
  | otherwise		 = IdLabel name InfoTable
303

Simon Marlow's avatar
Simon Marlow committed
304
305
mkEntryLabel this_pkg name
  | isDllName this_pkg name = DynIdLabel    name Entry
306
  | otherwise             = IdLabel name Entry
307

Simon Marlow's avatar
Simon Marlow committed
308
309
mkClosureTableLabel this_pkg name
  | isDllName this_pkg name = DynIdLabel    name ClosureTable
310
  | otherwise             = IdLabel name ClosureTable
311
312
313
314
315
316
317
318
319
320
321
322

mkLocalConInfoTableLabel     con = IdLabel con ConInfoTable
mkLocalConEntryLabel	     con = IdLabel con ConEntry
mkLocalStaticInfoTableLabel  con = IdLabel con StaticInfoTable
mkLocalStaticConEntryLabel   con = IdLabel con StaticConEntry

mkConInfoTableLabel name False = IdLabel    name ConInfoTable
mkConInfoTableLabel name True  = DynIdLabel name ConInfoTable

mkStaticInfoTableLabel name False = IdLabel    name StaticInfoTable
mkStaticInfoTableLabel name True  = DynIdLabel name StaticInfoTable

Simon Marlow's avatar
Simon Marlow committed
323
324
mkConEntryLabel this_pkg name
  | isDllName this_pkg name = DynIdLabel    name ConEntry
325
  | otherwise             = IdLabel name ConEntry
326

Simon Marlow's avatar
Simon Marlow committed
327
328
mkStaticConEntryLabel this_pkg name
  | isDllName this_pkg name = DynIdLabel    name StaticConEntry
329
  | otherwise             = IdLabel name StaticConEntry
330
331
332
333
334
335
336


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

337
mkStringLitLabel		= StringLitLabel
338
339
mkAsmTempLabel 			= AsmTempLabel

Simon Marlow's avatar
Simon Marlow committed
340
341
342
mkModuleInitLabel :: PackageId -> Module -> String -> CLabel
mkModuleInitLabel this_pkg mod way
  = ModuleInitLabel mod way $! modulePackageId mod /= this_pkg
343

Simon Marlow's avatar
Simon Marlow committed
344
345
346
mkPlainModuleInitLabel :: PackageId -> Module -> CLabel
mkPlainModuleInitLabel this_pkg mod
  = PlainModuleInitLabel mod $! modulePackageId mod /= this_pkg
347
348
349
350

	-- Some fixed runtime system labels

mkSplitMarkerLabel		= RtsLabel (RtsCode SLIT("__stg_split_marker"))
351
mkDirty_MUT_VAR_Label		= RtsLabel (RtsCode SLIT("dirty_MUT_VAR"))
352
353
354
355
mkUpdInfoLabel			= RtsLabel (RtsInfo SLIT("stg_upd_frame"))
mkSeqInfoLabel			= RtsLabel (RtsInfo SLIT("stg_seq_frame"))
mkIndStaticInfoLabel		= RtsLabel (RtsInfo SLIT("stg_IND_STATIC"))
mkMainCapabilityLabel		= RtsLabel (RtsData SLIT("MainCapability"))
356
mkMAP_FROZEN_infoLabel		= RtsLabel (RtsInfo SLIT("stg_MUT_ARR_PTRS_FROZEN0"))
357
mkMAP_DIRTY_infoLabel		= RtsLabel (RtsInfo SLIT("stg_MUT_ARR_PTRS_DIRTY"))
358
359
360
361
362
363
364
365
366
367
368
369
mkEMPTY_MVAR_infoLabel		= RtsLabel (RtsInfo SLIT("stg_EMPTY_MVAR"))

mkTopTickyCtrLabel		= RtsLabel (RtsData SLIT("top_ct"))
mkCAFBlackHoleInfoTableLabel	= RtsLabel (RtsInfo SLIT("stg_CAF_BLACKHOLE"))
mkSECAFBlackHoleInfoTableLabel	= if opt_DoTickyProfiling then
                                    RtsLabel (RtsInfo SLIT("stg_SE_CAF_BLACKHOLE"))
                                  else  -- RTS won't have info table unless -ticky is on
                                    panic "mkSECAFBlackHoleInfoTableLabel requires -ticky"
mkRtsPrimOpLabel primop		= RtsLabel (RtsPrimOp primop)

moduleRegdLabel			= ModuleRegdLabel

370
mkSelectorInfoLabel  upd off	= RtsLabel (RtsSelectorInfoTable upd off)
371
372
mkSelectorEntryLabel upd off	= RtsLabel (RtsSelectorEntry   upd off)

373
mkApInfoTableLabel  upd off	= RtsLabel (RtsApInfoTable upd off)
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
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

	-- 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)

400
401
mkRtsApFastLabel str = RtsLabel (RtsApFast str)

402
403
404
mkRtsSlowTickyCtrLabel :: String -> CLabel
mkRtsSlowTickyCtrLabel pat = RtsLabel (RtsSlowTickyCtr pat)

405
406
407
408
409
410
411
412
413
414
415
416
417
418
        -- 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

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

422
423
424
425
-- -----------------------------------------------------------------------------
-- Converting info labels to entry labels.

infoLblToEntryLbl :: CLabel -> CLabel 
426
427
428
429
430
431
infoLblToEntryLbl (IdLabel n InfoTable) = IdLabel n Entry
infoLblToEntryLbl (IdLabel n ConInfoTable) = IdLabel n ConEntry
infoLblToEntryLbl (IdLabel n StaticInfoTable) = IdLabel n StaticConEntry
infoLblToEntryLbl (DynIdLabel n InfoTable) = DynIdLabel n Entry
infoLblToEntryLbl (DynIdLabel n ConInfoTable) = DynIdLabel n ConEntry
infoLblToEntryLbl (DynIdLabel n StaticInfoTable) = DynIdLabel n StaticConEntry
432
433
434
435
436
437
438
439
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 
440
441
442
443
444
445
entryLblToInfoLbl (IdLabel n Entry) = IdLabel n InfoTable
entryLblToInfoLbl (IdLabel n ConEntry) = IdLabel n ConInfoTable
entryLblToInfoLbl (IdLabel n StaticConEntry) = IdLabel n StaticInfoTable
entryLblToInfoLbl (DynIdLabel n Entry) = DynIdLabel n InfoTable
entryLblToInfoLbl (DynIdLabel n ConEntry) = DynIdLabel n ConInfoTable
entryLblToInfoLbl (DynIdLabel n StaticConEntry) = DynIdLabel n StaticInfoTable
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
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?

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
needsCDecl (IdLabel _ SRTDesc)		= False
needsCDecl (IdLabel _ Bitmap)		= False
needsCDecl (IdLabel _ _)		= True
464
needsCDecl (DynIdLabel _ _)		= True
465
needsCDecl (CaseLabel _ _)	        = True
466
467
needsCDecl (ModuleInitLabel _ _ _)	= True
needsCDecl (PlainModuleInitLabel _ _)	= True
468
469
needsCDecl ModuleRegdLabel		= False

470
needsCDecl (StringLitLabel _)		= False
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
needsCDecl (AsmTempLabel _)		= False
needsCDecl (RtsLabel _)			= False
needsCDecl (ForeignLabel _ _ _)		= False
needsCDecl (CC_Label _)			= True
needsCDecl (CCS_Label _)		= True

-- Whether the label is an assembler temporary:

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

-- -----------------------------------------------------------------------------
-- 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
492
externallyVisibleCLabel (StringLitLabel _) = False
493
externallyVisibleCLabel (AsmTempLabel _)   = False
494
495
externallyVisibleCLabel (ModuleInitLabel _ _ _)= True
externallyVisibleCLabel (PlainModuleInitLabel _ _)= True
496
497
498
externallyVisibleCLabel ModuleRegdLabel    = False
externallyVisibleCLabel (RtsLabel _)	   = True
externallyVisibleCLabel (ForeignLabel _ _ _) = True
499
500
externallyVisibleCLabel (IdLabel name _)     = isExternalName name
externallyVisibleCLabel (DynIdLabel name _)  = isExternalName name
501
502
externallyVisibleCLabel (CC_Label _)	   = True
externallyVisibleCLabel (CCS_Label _)	   = True
503
externallyVisibleCLabel (DynamicLinkerLabel _ _)  = False
504
505
506
507
508
509
510
511
512
513
514

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

-- For generating correct types in label declarations:

data CLabelType
  = CodeLabel
  | DataLabel

labelType :: CLabel -> CLabelType
515
516
labelType (RtsLabel (RtsSelectorInfoTable _ _)) = DataLabel
labelType (RtsLabel (RtsApInfoTable _ _))       = DataLabel
517
518
519
520
521
522
523
524
525
526
527
528
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
529
labelType (RtsLabel (RtsApFast _))            = CodeLabel
530
labelType (CaseLabel _ CaseReturnInfo)        = DataLabel
531
labelType (CaseLabel _ _)	              = CodeLabel
532
533
labelType (ModuleInitLabel _ _ _)             = CodeLabel
labelType (PlainModuleInitLabel _ _)          = CodeLabel
534

535
536
537
538
539
labelType (IdLabel _ info) = idInfoLabelType info
labelType (DynIdLabel _ info) = idInfoLabelType info
labelType _        = DataLabel

idInfoLabelType info =
540
  case info of
541
    InfoTable  	  -> DataLabel
542
543
    Closure    	  -> DataLabel
    Bitmap     	  -> DataLabel
544
545
    ConInfoTable  -> DataLabel
    StaticInfoTable -> DataLabel
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
    ClosureTable  -> DataLabel
    _	          -> 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.

labelDynamic :: CLabel -> Bool
labelDynamic lbl = 
  case lbl of
   RtsLabel _  	     -> not opt_Static  -- i.e., is the RTS in a DLL or not?
562
563
   IdLabel n k       -> False
   DynIdLabel n k    -> True
564
#if mingw32_TARGET_OS
565
   ForeignLabel _ _ d  -> d
566
567
568
569
570
#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
571
572
   ModuleInitLabel m _ dyn    -> not opt_Static && dyn
   PlainModuleInitLabel m dyn -> not opt_Static && dyn
573
574
   
   -- Note that DynamicLinkerLabels do NOT require dynamic linking themselves.
575
576
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
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
   _ 		     -> 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
624
625
626
instance Outputable CLabel where
  ppr = pprCLabel

627
628
629
630
631
632
633
634
635
pprCLabel :: CLabel -> SDoc

#if ! OMIT_NATIVE_CODEGEN
pprCLabel (AsmTempLabel u)
  =  getPprStyle $ \ sty ->
     if asmStyle sty then 
	ptext asmTempLabelPrefix <> pprUnique u
     else
	char '_' <> pprUnique u
636
637
638
639
640
641

pprCLabel (DynamicLinkerLabel info lbl)
   = pprDynamicLinkerAsmLabel info lbl
   
pprCLabel PicBaseLabel
   = ptext SLIT("1b")
642
643
644
   
pprCLabel (DeadStripPreventer lbl)
   = pprCLabel lbl <> ptext SLIT("_dsp")
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
#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

660
#ifdef mingw32_TARGET_OS
661
662
663
664
-- 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
665
#endif
666
667
668
pprAsmCLbl lbl
   = pprCLbl lbl

669
670
671
pprCLbl (StringLitLabel u)
  = pprUnique u <> ptext SLIT("_str")

672
673
674
675
676
677
678
679
680
681
682
683
684
685
pprCLbl (CaseLabel u CaseReturnPt)
  = hcat [pprUnique u, ptext SLIT("_ret")]
pprCLbl (CaseLabel u CaseReturnInfo)
  = hcat [pprUnique u, ptext SLIT("_info")]
pprCLbl (CaseLabel u (CaseAlt tag))
  = hcat [pprUnique u, pp_cSEP, int tag, ptext SLIT("_alt")]
pprCLbl (CaseLabel u CaseDefault)
  = hcat [pprUnique u, ptext SLIT("_dflt")]

pprCLbl (RtsLabel (RtsCode str))   = ptext str
pprCLbl (RtsLabel (RtsData str))   = ptext str
pprCLbl (RtsLabel (RtsCodeFS str)) = ftext str
pprCLbl (RtsLabel (RtsDataFS str)) = ftext str

686
687
pprCLbl (RtsLabel (RtsApFast str)) = ptext str <> ptext SLIT("_fast")

688
pprCLbl (RtsLabel (RtsSelectorInfoTable upd_reqd offset))
689
690
691
692
693
694
695
696
697
698
699
700
701
  = hcat [ptext SLIT("stg_sel_"), text (show offset),
		ptext (if upd_reqd 
			then SLIT("_upd_info") 
			else SLIT("_noupd_info"))
	]

pprCLbl (RtsLabel (RtsSelectorEntry upd_reqd offset))
  = hcat [ptext SLIT("stg_sel_"), text (show offset),
		ptext (if upd_reqd 
			then SLIT("_upd_entry") 
			else SLIT("_noupd_entry"))
	]

702
pprCLbl (RtsLabel (RtsApInfoTable upd_reqd arity))
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
  = hcat [ptext SLIT("stg_ap_"), text (show arity),
		ptext (if upd_reqd 
			then SLIT("_upd_info") 
			else SLIT("_noupd_info"))
	]

pprCLbl (RtsLabel (RtsApEntry upd_reqd arity))
  = hcat [ptext SLIT("stg_ap_"), text (show arity),
		ptext (if upd_reqd 
			then SLIT("_upd_entry") 
			else SLIT("_noupd_entry"))
	]

pprCLbl (RtsLabel (RtsInfo fs))
  = ptext fs <> ptext SLIT("_info")

pprCLbl (RtsLabel (RtsEntry fs))
  = ptext fs <> ptext SLIT("_entry")

pprCLbl (RtsLabel (RtsRetInfo fs))
  = ptext fs <> ptext SLIT("_info")

pprCLbl (RtsLabel (RtsRet fs))
  = ptext fs <> ptext SLIT("_ret")

pprCLbl (RtsLabel (RtsInfoFS fs))
  = ftext fs <> ptext SLIT("_info")

pprCLbl (RtsLabel (RtsEntryFS fs))
  = ftext fs <> ptext SLIT("_entry")

pprCLbl (RtsLabel (RtsRetInfoFS fs))
  = ftext fs <> ptext SLIT("_info")

pprCLbl (RtsLabel (RtsRetFS fs))
  = ftext fs <> ptext SLIT("_ret")

pprCLbl (RtsLabel (RtsPrimOp primop)) 
  = ppr primop <> ptext SLIT("_fast")

pprCLbl (RtsLabel (RtsSlowTickyCtr pat)) 
  = ptext SLIT("SLOW_CALL_") <> text pat <> ptext SLIT("_ctr")

pprCLbl ModuleRegdLabel
  = ptext SLIT("_module_registered")

pprCLbl (ForeignLabel str _ _)
  = ftext str

752
753
pprCLbl (IdLabel name  flavor) = ppr name <> ppIdFlavor flavor
pprCLbl (DynIdLabel name  flavor) = ppr name <> ppIdFlavor flavor
754
755
756
757

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

758
pprCLbl (ModuleInitLabel mod way _)	
759
   = ptext SLIT("__stginit_") <> ppr mod
760
	<> char '_' <> text way
761
pprCLbl (PlainModuleInitLabel mod _)	
762
   = ptext SLIT("__stginit_") <> ppr mod
763
764
765
766
767
768
769

ppIdFlavor :: IdLabelInfo -> SDoc
ppIdFlavor x = pp_cSEP <>
	       (case x of
		       Closure	    	-> ptext SLIT("closure")
		       SRT		-> ptext SLIT("srt")
		       SRTDesc		-> ptext SLIT("srtd")
770
		       InfoTable    	-> ptext SLIT("info")
771
772
773
774
775
		       Entry	    	-> ptext SLIT("entry")
		       Slow	    	-> ptext SLIT("slow")
		       RednCounts	-> ptext SLIT("ct")
		       Bitmap		-> ptext SLIT("btm")
		       ConEntry	    	-> ptext SLIT("con_entry")
776
		       ConInfoTable    	-> ptext SLIT("con_info")
777
		       StaticConEntry  	-> ptext SLIT("static_entry")
778
		       StaticInfoTable 	-> ptext SLIT("static_info")
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
		       ClosureTable     -> ptext SLIT("closure_tbl")
		      )


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.)
     -}
     SLIT("$")
#elif darwin_TARGET_OS
     SLIT("L")
#else
     SLIT(".L")
#endif
804
805
806
807
808
809

pprDynamicLinkerAsmLabel :: DynamicLinkerLabelInfo -> CLabel -> SDoc

#if darwin_TARGET_OS
pprDynamicLinkerAsmLabel CodeStub lbl
  = char 'L' <> pprCLabel lbl <> text "$stub"
810
811
812
813
pprDynamicLinkerAsmLabel SymbolPtr lbl
  = char 'L' <> pprCLabel lbl <> text "$non_lazy_ptr"
pprDynamicLinkerAsmLabel _ _
  = panic "pprDynamicLinkerAsmLabel"
814
815
816
817
818
#elif powerpc_TARGET_ARCH && linux_TARGET_OS
pprDynamicLinkerAsmLabel CodeStub lbl
  = pprCLabel lbl <> text "@plt"
pprDynamicLinkerAsmLabel SymbolPtr lbl
  = text ".LC_" <> pprCLabel lbl
819
820
pprDynamicLinkerAsmLabel _ _
  = panic "pprDynamicLinkerAsmLabel"
821
822
823
#elif linux_TARGET_OS
pprDynamicLinkerAsmLabel CodeStub lbl
  = pprCLabel lbl <> text "@plt"
824
825
pprDynamicLinkerAsmLabel SymbolPtr lbl
  = text ".LC_" <> pprCLabel lbl
826
827
828
829
830
831
832
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
833
834
835
pprDynamicLinkerAsmLabel _ _
  = panic "pprDynamicLinkerAsmLabel"
#else
836
837
pprDynamicLinkerAsmLabel _ _
  = panic "pprDynamicLinkerAsmLabel"
838
#endif