CLabel.lhs 16.2 KB
Newer Older
1
%
2 3
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
4
% $Id: CLabel.lhs,v 1.46 2001/04/20 14:54:37 sewardj Exp $
5
%
6
\section[CLabel]{@CLabel@: Information to make C Labels}
7 8

\begin{code}
9
module CLabel (
10 11 12
	CLabel,	-- abstract type

	mkClosureLabel,
13
	mkSRTLabel,
14 15 16 17 18 19
	mkInfoTableLabel,
	mkStdEntryLabel,
	mkFastEntryLabel,
	mkConEntryLabel,
	mkStaticConEntryLabel,
	mkRednCountsLabel,
20
	mkConInfoTableLabel,
21
	mkStaticInfoTableLabel,
22 23
	mkApEntryLabel,
	mkApInfoTableLabel,
24 25

	mkReturnPtLabel,
26
	mkReturnInfoLabel,
27 28 29
	mkVecTblLabel,
	mkAltLabel,
	mkDefaultLabel,
30 31 32
	mkBitmapLabel,

	mkClosureTblLabel,
33 34 35

	mkAsmTempLabel,

36 37
	mkModuleInitLabel,

38
	mkErrorStdEntryLabel,
39 40

	mkStgUpdatePAPLabel,
41
	mkSplitMarkerLabel,
42
	mkUpdInfoLabel,
43 44 45 46 47 48 49 50
	mkSeqInfoLabel,
	mkIndInfoLabel,
	mkIndStaticInfoLabel,
	mkRtsGCEntryLabel,
        mkMainRegTableLabel,
	mkCharlikeClosureLabel,
	mkIntlikeClosureLabel,
	mkMAP_FROZEN_infoLabel,
51
        mkEMPTY_MVAR_infoLabel,
52

53
	mkTopTickyCtrLabel,
54
	mkBlackHoleInfoTableLabel,
55 56
        mkCAFBlackHoleInfoTableLabel,
        mkSECAFBlackHoleInfoTableLabel,
57 58
	mkRtsPrimOpLabel,

59 60
	moduleRegdLabel,

61 62
	mkSelectorInfoLabel,
	mkSelectorEntryLabel,
63

64 65
	mkForeignLabel,

66 67
	mkCC_Label, mkCCS_Label,
	
68
	needsCDecl, isAsmTemp, externallyVisibleCLabel,
69

sof's avatar
sof committed
70
	CLabelType(..), labelType, labelDynamic,
71

72 73 74 75
	pprCLabel
#if ! OMIT_NATIVE_CODEGEN
	, pprCLabel_asm
#endif
76 77
    ) where

sof's avatar
sof committed
78

79
#include "HsVersions.h"
sof's avatar
sof committed
80

81
#if ! OMIT_NATIVE_CODEGEN
sof's avatar
sof committed
82
import {-# SOURCE #-} MachMisc ( underscorePrefix, fmtAsmLbl )
83
#endif
84

85
import CmdLineOpts      ( opt_Static, opt_DoTickyProfiling )
86
import CStrings		( pp_cSEP )
87 88
import DataCon		( ConTag )
import Module		( moduleName, moduleNameFS, 
89
			  Module, isHomeModule )
90
import Name		( Name, getName, isDllName, isExternallyVisibleName )
91
import TyCon		( TyCon )
92
import Unique		( pprUnique, Unique )
93
import PrimOp		( PrimOp )
94
import CostCentre	( CostCentre, CostCentreStack )
95
import Outputable
96 97 98 99 100 101 102 103 104 105
\end{code}

things we want to find out:

* should the labelled things be declared "static" (visible only in this file)?

* should it be declared "const" (read-only text space)?

* does it need declarations at all? (v common Prelude things are pre-declared)

106 107 108
* what type does it have? (for generating accurate enough C declarations
  so that the C compiler won't complain).

109 110
\begin{code}
data CLabel
111
  = IdLabel	    		-- A family of labels related to the
112 113
	Name			-- definition of a particular Id
	IdLabelInfo
114

115 116 117
  | DataConLabel		-- Ditto data constructors
	Name
	DataConLabelInfo
118 119 120 121 122

  | CaseLabel			-- A family of labels related to a particular case expression
	Unique			-- Unique says which case expression
	CaseLabelInfo

123 124 125
  | TyConLabel TyCon		-- currently only one kind of TyconLabel,
				-- a 'Closure Table'.

126 127
  | AsmTempLabel    Unique

rrt's avatar
rrt committed
128
  | ModuleInitLabel Module
129

130 131
  | RtsLabel	    RtsLabelInfo

132 133 134
  | ForeignLabel FAST_STRING Bool  -- a 'C' (or otherwise foreign) label
				   -- Bool <=> is dynamic

135 136
  | CC_Label CostCentre
  | CCS_Label CostCentreStack
137

138
  deriving (Eq, Ord)
139 140 141 142 143
\end{code}

\begin{code}
data IdLabelInfo
  = Closure		-- Label for (static???) closure
144 145

  | SRT                 -- Static reference table
146 147 148

  | InfoTbl		-- Info table for a closure; always read-only

149 150
  | EntryStd		-- Thunk, or "slow", code entry point

151 152 153 154
  | EntryFast Int	-- entry pt when no arg satisfaction chk needed;
			-- Int is the arity of the function (to be
			-- encoded into the name)

155 156 157 158 159 160 161
			-- Ticky-ticky counting
  | RednCounts		-- Label of place to keep reduction-count info for 
			-- this Id
  deriving (Eq, Ord)

data DataConLabelInfo
  = ConEntry		-- the only kind of entry pt for constructors
162 163
  | ConInfoTbl		-- corresponding info table
  | StaticConEntry  	-- static constructor entry point
164 165 166
  | StaticInfoTbl   	-- corresponding info table
  deriving (Eq, Ord)

167
data CaseLabelInfo
168
  = CaseReturnPt
169
  | CaseReturnInfo
170 171 172
  | CaseVecTbl
  | CaseAlt ConTag
  | CaseDefault
173
  | CaseBitmap
174 175 176 177 178
  deriving (Eq, Ord)

data RtsLabelInfo
  = RtsShouldNeverHappenCode

179
  | RtsBlackHoleInfoTbl FAST_STRING  -- black hole with info table name
180

181 182 183 184 185 186
  | RtsUpdInfo            	-- upd_frame_info
  | RtsSeqInfo			-- seq_frame_info
  | RtsGCEntryLabel String 	-- a heap check fail handler, eg  stg_chk_2
  | RtsMainRegTable             -- MainRegTable (??? Capabilities wurble ???)
  | Rts_Closure String		-- misc rts closures, eg CHARLIKE_closure
  | Rts_Info String		-- misc rts itbls, eg MUT_ARR_PTRS_FROZEN_info
187
  | Rts_Code String		-- misc rts code
188 189 190 191 192 193 194 195

  | RtsSelectorInfoTbl Bool{-updatable-} Int{-offset-}	-- Selector thunks
  | RtsSelectorEntry   Bool{-updatable-} Int{-offset-}

  | RtsApInfoTbl Bool{-updatable-} Int{-arity-}	        -- AP thunks
  | RtsApEntry   Bool{-updatable-} Int{-arity-}

  | RtsPrimOp PrimOp
196

197 198
  | RtsTopTickyCtr

199 200
  | RtsModuleRegd

201
  deriving (Eq, Ord)
202 203 204 205 206 207 208

-- Label Type: for generating C declarations.

data CLabelType
  = InfoTblType
  | ClosureType
  | VecTblType
209
  | ClosureTblType
210 211
  | CodeType
  | DataType
212 213 214
\end{code}

\begin{code}
215 216 217 218
mkClosureLabel	      	id 		= IdLabel id  Closure
mkSRTLabel		id		= IdLabel id  SRT
mkInfoTableLabel      	id 		= IdLabel id  InfoTbl
mkStdEntryLabel	      	id 		= IdLabel id  EntryStd
219
mkFastEntryLabel      	id arity	= ASSERT(arity > 0)
220 221 222 223 224 225 226 227 228
					  IdLabel id  (EntryFast arity)

mkRednCountsLabel     	id		= IdLabel id  RednCounts

mkStaticInfoTableLabel  con		= DataConLabel con StaticInfoTbl
mkConInfoTableLabel     con		= DataConLabel con ConInfoTbl
mkConEntryLabel	      	con		= DataConLabel con ConEntry
mkStaticConEntryLabel 	con		= DataConLabel con StaticConEntry

229 230

mkReturnPtLabel uniq		= CaseLabel uniq CaseReturnPt
231
mkReturnInfoLabel uniq		= CaseLabel uniq CaseReturnInfo
232 233 234
mkVecTblLabel   uniq		= CaseLabel uniq CaseVecTbl
mkAltLabel      uniq tag	= CaseLabel uniq (CaseAlt tag)
mkDefaultLabel  uniq 		= CaseLabel uniq CaseDefault
235 236 237
mkBitmapLabel   uniq		= CaseLabel uniq CaseBitmap

mkClosureTblLabel tycon		= TyConLabel tycon
238 239 240

mkAsmTempLabel 			= AsmTempLabel

241 242
mkModuleInitLabel		= ModuleInitLabel

243 244
	-- Some fixed runtime system labels

rrt's avatar
rrt committed
245
mkErrorStdEntryLabel 		= RtsLabel RtsShouldNeverHappenCode
246
mkStgUpdatePAPLabel		= RtsLabel (Rts_Code "stg_update_PAP")
247
mkSplitMarkerLabel		= RtsLabel (Rts_Code "__stg_split_marker")
248
mkUpdInfoLabel			= RtsLabel RtsUpdInfo
249
mkSeqInfoLabel			= RtsLabel RtsSeqInfo
250 251
mkIndInfoLabel			= RtsLabel (Rts_Info "stg_IND_info")
mkIndStaticInfoLabel		= RtsLabel (Rts_Info "stg_IND_STATIC_info")
252 253
mkRtsGCEntryLabel str		= RtsLabel (RtsGCEntryLabel str)
mkMainRegTableLabel		= RtsLabel RtsMainRegTable
254 255 256
mkCharlikeClosureLabel		= RtsLabel (Rts_Closure "stg_CHARLIKE_closure")
mkIntlikeClosureLabel		= RtsLabel (Rts_Closure "stg_INTLIKE_closure")
mkMAP_FROZEN_infoLabel		= RtsLabel (Rts_Info "stg_MUT_ARR_PTRS_FROZEN_info")
257
mkEMPTY_MVAR_infoLabel		= RtsLabel (Rts_Info "stg_EMPTY_MVAR_info")
258

259
mkTopTickyCtrLabel		= RtsLabel RtsTopTickyCtr
260 261
mkBlackHoleInfoTableLabel	= RtsLabel (RtsBlackHoleInfoTbl SLIT("stg_BLACKHOLE_info"))
mkCAFBlackHoleInfoTableLabel	= RtsLabel (RtsBlackHoleInfoTbl SLIT("stg_CAF_BLACKHOLE_info"))
262
mkSECAFBlackHoleInfoTableLabel	= if opt_DoTickyProfiling then
263
                                    RtsLabel (RtsBlackHoleInfoTbl SLIT("stg_SE_CAF_BLACKHOLE_info"))
264 265
                                  else  -- RTS won't have info table unless -ticky is on
                                    panic "mkSECAFBlackHoleInfoTableLabel requires -ticky"
266 267
mkRtsPrimOpLabel primop		= RtsLabel (RtsPrimOp primop)

268 269
moduleRegdLabel			= RtsLabel RtsModuleRegd

270 271 272 273 274 275
mkSelectorInfoLabel  upd off	= RtsLabel (RtsSelectorInfoTbl upd off)
mkSelectorEntryLabel upd off	= RtsLabel (RtsSelectorEntry   upd off)

mkApInfoTableLabel  upd off	= RtsLabel (RtsApInfoTbl upd off)
mkApEntryLabel upd off		= RtsLabel (RtsApEntry   upd off)

276 277 278 279 280
	-- Foreign labels

mkForeignLabel :: FAST_STRING -> Bool -> CLabel
mkForeignLabel str is_dynamic	= ForeignLabel str is_dynamic

281 282 283 284
	-- Cost centres etc.

mkCC_Label	cc		= CC_Label cc
mkCCS_Label	ccs		= CCS_Label ccs
285 286 287 288 289 290 291 292 293 294
\end{code}

\begin{code}
needsCDecl :: CLabel -> Bool	-- False <=> it's pre-declared; don't bother
isAsmTemp  :: CLabel -> Bool    -- is a local temporary for native code generation
externallyVisibleCLabel :: CLabel -> Bool -- not C "static"
\end{code}

@needsCDecl@ is @True@ unless the thing is a deeply-@PreludeCore@-ish
object.  {\em Also:} No need to spit out labels for things generated
295
by the flattener (in @AbsCUtils@)---it is careful to ensure references
296 297 298 299 300 301
to them are always backwards.  These are return-point and vector-table
labels.

Declarations for (non-prelude) @Id@-based things are needed because of
mutual recursion.

302 303
Declarations for direct return points are needed, because they may be
let-no-escapes, which can be recursive.
304

305 306 307 308
\begin{code}
needsCDecl (IdLabel _ _)		= True
needsCDecl (CaseLabel _ CaseReturnPt)	= True
needsCDecl (DataConLabel _ _)		= True
309
needsCDecl (TyConLabel _)		= True
rrt's avatar
rrt committed
310
needsCDecl (ModuleInitLabel _)		= True
311

rrt's avatar
rrt committed
312
needsCDecl (CaseLabel _ _)		= False
313 314
needsCDecl (AsmTempLabel _)		= False
needsCDecl (RtsLabel _)			= False
315
needsCDecl (ForeignLabel _ _)		= False
316 317
needsCDecl (CC_Label _)			= False
needsCDecl (CCS_Label _)		= False
318 319 320
\end{code}

Whether the label is an assembler temporary:
321

322 323 324 325 326 327
\begin{code}
isAsmTemp (AsmTempLabel _) = True
isAsmTemp _ 	    	   = False
\end{code}

C ``static'' or not...
328
From the point of view of the code generator, a name is
329 330 331 332 333 334 335 336
externally visible if it has to be declared as exported
in the .o file's symbol table; that is, made non-static.

\begin{code}
externallyVisibleCLabel (DataConLabel _ _) = True
externallyVisibleCLabel (TyConLabel tc)    = True
externallyVisibleCLabel (CaseLabel _ _)	   = False
externallyVisibleCLabel (AsmTempLabel _)   = False
337 338
externallyVisibleCLabel (ModuleInitLabel _)= True
externallyVisibleCLabel (RtsLabel RtsModuleRegd) = False --hack
339
externallyVisibleCLabel (RtsLabel _)	   = True
340
externallyVisibleCLabel (ForeignLabel _ _) = True
341 342 343 344 345 346
externallyVisibleCLabel (IdLabel id _)     = isExternallyVisibleName id
externallyVisibleCLabel (CC_Label _)	   = False -- not strictly true
externallyVisibleCLabel (CCS_Label _)	   = False -- not strictly true
\end{code}

For generating correct types in label declarations...
347

348
\begin{code}
349
labelType :: CLabel -> CLabelType
350
labelType (RtsLabel (RtsBlackHoleInfoTbl _))  = InfoTblType
351 352
labelType (RtsLabel (RtsSelectorInfoTbl _ _)) = InfoTblType
labelType (RtsLabel (RtsApInfoTbl _ _))       = InfoTblType
353
labelType (RtsLabel RtsUpdInfo)       	      = InfoTblType
354 355 356
labelType (CaseLabel _ CaseReturnInfo)        = InfoTblType
labelType (CaseLabel _ CaseReturnPt)	      = CodeType
labelType (CaseLabel _ CaseVecTbl)            = VecTblType
357
labelType (TyConLabel _)		      = ClosureTblType
rrt's avatar
rrt committed
358
labelType (ModuleInitLabel _ )                = CodeType
359 360 361 362 363 364 365 366 367 368 369 370 371 372

labelType (IdLabel _ info) = 
  case info of
    InfoTbl       -> InfoTblType
    Closure	  -> ClosureType
    _		  -> CodeType

labelType (DataConLabel _ info) = 
  case info of
     ConInfoTbl    -> InfoTblType
     StaticInfoTbl -> InfoTblType
     _		   -> CodeType

labelType _        = DataType
373 374
\end{code}

sof's avatar
sof committed
375 376 377 378 379 380 381 382 383
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.

\begin{code}
labelDynamic :: CLabel -> Bool
labelDynamic lbl = 
  case lbl of
rrt's avatar
rrt committed
384 385 386 387 388 389 390 391
   -- The special case for RtsShouldNeverHappenCode is because the associated address is
   -- NULL, i.e. not a DLL entry point
   RtsLabel RtsShouldNeverHappenCode -> False
   RtsLabel _  	     -> not opt_Static  -- i.e., is the RTS in a DLL or not?
   IdLabel n k       -> isDllName n
   DataConLabel n k  -> isDllName n
   TyConLabel tc     -> isDllName (getName tc)
   ForeignLabel _ d  -> d
392
   ModuleInitLabel m -> (not opt_Static) && (not (isHomeModule m))
rrt's avatar
rrt committed
393
   _ 		     -> False
sof's avatar
sof committed
394 395 396
\end{code}


397
OLD?: These GRAN functions are needed for spitting out GRAN_FETCH() at the
398 399 400 401 402 403 404
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@).

405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429
-----------------------------------------------------------------------------
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
	 entry			Entry code
	 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
430 431
	 cc			Cost centre
	 ccs			Cost centre stack
432

433
\begin{code}
434
-- specialised for PprAsm: saves lots of arg passing in NCG
435
#if ! OMIT_NATIVE_CODEGEN
436
pprCLabel_asm = pprCLabel
437
#endif
438

439
pprCLabel :: CLabel -> SDoc
440

441
#if ! OMIT_NATIVE_CODEGEN
442
pprCLabel (AsmTempLabel u)
443
  = text (fmtAsmLbl (show u))
444
#endif
445

446 447 448
pprCLabel lbl = 
#if ! OMIT_NATIVE_CODEGEN
    getPprStyle $ \ sty ->
449 450 451
    if asmStyle sty && underscorePrefix then
       pp_cSEP <> pprCLbl lbl
    else
452
#endif
453 454 455
       pprCLbl lbl

pprCLbl (CaseLabel u CaseReturnPt)
456 457 458
  = hcat [pprUnique u, pp_cSEP, ptext SLIT("ret")]
pprCLbl (CaseLabel u CaseReturnInfo)
  = hcat [pprUnique u, pp_cSEP, ptext SLIT("info")]
459
pprCLbl (CaseLabel u CaseVecTbl)
460
  = hcat [pprUnique u, pp_cSEP, ptext SLIT("vtbl")]
461
pprCLbl (CaseLabel u (CaseAlt tag))
462
  = hcat [pprUnique u, pp_cSEP, int tag, pp_cSEP, ptext SLIT("alt")]
463
pprCLbl (CaseLabel u CaseDefault)
464 465 466 467
  = hcat [pprUnique u, pp_cSEP, ptext SLIT("dflt")]
pprCLbl (CaseLabel u CaseBitmap)
  = hcat [pprUnique u, pp_cSEP, ptext SLIT("btm")]

rrt's avatar
rrt committed
468 469 470
pprCLbl (RtsLabel RtsShouldNeverHappenCode) = ptext SLIT("NULL")
-- used to be stg_error_entry but Windows can't have DLL entry points as static
-- initialisers, and besides, this ShouldNeverHappen, right?
471

472 473
pprCLbl (RtsLabel RtsUpdInfo)            = ptext SLIT("stg_upd_frame_info")
pprCLbl (RtsLabel RtsSeqInfo)            = ptext SLIT("stg_seq_frame_info")
474 475 476 477 478
pprCLbl (RtsLabel RtsMainRegTable)       = ptext SLIT("MainRegTable")
pprCLbl (RtsLabel (RtsGCEntryLabel str)) = text str
pprCLbl (RtsLabel (Rts_Closure str))     = text str
pprCLbl (RtsLabel (Rts_Info str))        = text str
pprCLbl (RtsLabel (Rts_Code str))        = text str
479

480 481
pprCLbl (RtsLabel RtsTopTickyCtr) = ptext SLIT("top_ct")

482
pprCLbl (RtsLabel (RtsBlackHoleInfoTbl info)) = ptext info
483

484
pprCLbl (RtsLabel (RtsSelectorInfoTbl upd_reqd offset))
485
  = hcat [ptext SLIT("stg_sel_"), text (show offset),
486 487 488 489
		ptext (if upd_reqd 
			then SLIT("_upd_info") 
			else SLIT("_noupd_info"))
	]
490

491
pprCLbl (RtsLabel (RtsSelectorEntry upd_reqd offset))
492
  = hcat [ptext SLIT("stg_sel_"), text (show offset),
493 494 495 496 497 498
		ptext (if upd_reqd 
			then SLIT("_upd_entry") 
			else SLIT("_noupd_entry"))
	]

pprCLbl (RtsLabel (RtsApInfoTbl upd_reqd arity))
499
  = hcat [ptext SLIT("stg_ap_"), text (show arity),
500 501 502 503 504 505
		ptext (if upd_reqd 
			then SLIT("_upd_info") 
			else SLIT("_noupd_info"))
	]

pprCLbl (RtsLabel (RtsApEntry upd_reqd arity))
506
  = hcat [ptext SLIT("stg_ap_"), text (show arity),
507 508 509 510 511 512
		ptext (if upd_reqd 
			then SLIT("_upd_entry") 
			else SLIT("_noupd_entry"))
	]

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

515 516 517
pprCLbl (RtsLabel RtsModuleRegd)
  = ptext SLIT("module_registered")

518 519 520
pprCLbl (ForeignLabel str _)
  = ptext str

521 522 523 524 525 526 527 528 529
pprCLbl (TyConLabel tc)
  = hcat [ppr tc, pp_cSEP, ptext SLIT("closure_tbl")]

pprCLbl (IdLabel      id  flavor) = ppr id <> ppIdFlavor flavor
pprCLbl (DataConLabel con flavor) = ppr con <> ppConFlavor flavor

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

530 531
pprCLbl (ModuleInitLabel mod)	
   = ptext SLIT("__init_") <> ptext (moduleNameFS (moduleName mod))
532

533 534 535 536
ppIdFlavor :: IdLabelInfo -> SDoc

ppIdFlavor x = pp_cSEP <>
	       (case x of
sof's avatar
sof committed
537
		       Closure	    	-> ptext SLIT("closure")
538
		       SRT		-> ptext SLIT("srt")
sof's avatar
sof committed
539 540
		       InfoTbl	    	-> ptext SLIT("info")
		       EntryStd	    	-> ptext SLIT("entry")
541
		       EntryFast arity	-> --false:ASSERT (arity > 0)
sof's avatar
sof committed
542
					   (<>) (ptext SLIT("fast")) (int arity)
543 544 545 546 547
		       RednCounts	-> ptext SLIT("ct")
		      )

ppConFlavor x = pp_cSEP <>
	     	(case x of
sof's avatar
sof committed
548 549 550 551
		       ConEntry	    	-> ptext SLIT("con_entry")
		       ConInfoTbl    	-> ptext SLIT("con_info")
		       StaticConEntry  	-> ptext SLIT("static_entry")
		       StaticInfoTbl 	-> ptext SLIT("static_info")
552
		)
553
\end{code}
554