StgMiscClosures.hc 33.9 KB
Newer Older
1
/* -----------------------------------------------------------------------------
2
 * $Id: StgMiscClosures.hc,v 1.55 2000/12/14 16:32:40 sewardj Exp $
3
 *
4
 * (c) The GHC Team, 1998-2000
5
6
7
8
9
10
11
 *
 * Entry code for various built-in closure types.
 *
 * ---------------------------------------------------------------------------*/

#include "Rts.h"
#include "RtsUtils.h"
12
#include "RtsFlags.h"
13
14
#include "StgMiscClosures.h"
#include "HeapStackCheck.h"   /* for stg_gen_yield */
15
16
#include "Storage.h"
#include "StoragePriv.h"
17
#include "Profiling.h"
18
#include "Prelude.h"
19
#include "Schedule.h"
20
#include "SMP.h"
21
22
23
24
#if defined(GRAN) || defined(PAR)
# include "GranSimRts.h"      /* for DumpRawGranEvent */
# include "StgRun.h"	/* for StgReturn and register saving */
#endif
25
26
27
28
29

#ifdef HAVE_STDIO_H
#include <stdio.h>
#endif

rrt's avatar
rrt committed
30
/* ToDo: make the printing of panics more win32-friendly, i.e.,
sof's avatar
sof committed
31
32
 *       pop up some lovely message boxes (as well).
 */
33
#define DUMP_ERRMSG(msg) STGCALL2(fprintf,stderr,msg)
sof's avatar
sof committed
34

35
36
37
38
39
/*
  Template for the entry code of non-enterable closures.
*/

#define NON_ENTERABLE_ENTRY_CODE(type)					\
40
STGFUN(stg_##type##_entry)							\
41
42
43
{									\
  FB_									\
    DUMP_ERRMSG(#type " object entered!\n");                            \
44
    STGCALL1(shutdownHaskellAndExit, EXIT_FAILURE);			\
45
    return NULL;							\
46
47
48
  FE_									\
}

49
50

/* -----------------------------------------------------------------------------
51
   Support for the bytecode interpreter.
52
53
54
55
   -------------------------------------------------------------------------- */

#ifdef GHCI

56
57
/* 9 bits of return code for constructors created by the interpreter. */
FN_(stg_interp_constr_entry) 
58
59
60
{ 
  /* R1 points at the constructor */
  FB_ 
61
    STGCALL2(fprintf,stderr,"stg_interp_constr_entry (direct return)!\n");
62
63
64
65
66
67
    /* Pointless, since SET_TAG doesn't do anything */
    SET_TAG( GET_TAG(GET_INFO(R1.cl))); 
    JMP_(ENTRY_CODE((P_)(*Sp))); 
  FE_ 
}

68
69
70
71
72
73
74
75
FN_(stg_interp_constr1_entry) { FB_ JMP_(RET_VEC((P_)(*Sp),0)); FE_ }
FN_(stg_interp_constr2_entry) { FB_ JMP_(RET_VEC((P_)(*Sp),1)); FE_ }
FN_(stg_interp_constr3_entry) { FB_ JMP_(RET_VEC((P_)(*Sp),2)); FE_ }
FN_(stg_interp_constr4_entry) { FB_ JMP_(RET_VEC((P_)(*Sp),3)); FE_ }
FN_(stg_interp_constr5_entry) { FB_ JMP_(RET_VEC((P_)(*Sp),4)); FE_ }
FN_(stg_interp_constr6_entry) { FB_ JMP_(RET_VEC((P_)(*Sp),5)); FE_ }
FN_(stg_interp_constr7_entry) { FB_ JMP_(RET_VEC((P_)(*Sp),6)); FE_ }
FN_(stg_interp_constr8_entry) { FB_ JMP_(RET_VEC((P_)(*Sp),7)); FE_ }
76
 
77
78
79
80
81
82
/* Some info tables to be used when compiled code returns a value to
   the interpreter, i.e. the interpreter pushes one of these onto the
   stack before entering a value.  What the code does is to
   impedance-match the compiled return convention (in R1/F1/D1 etc) to
   the interpreter's convention (returned value is on top of stack),
   and then cause the scheduler to enter the interpreter.
83

84
   On entry, the stack (growing down) looks like this:
85

86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
      ptr to BCO holding return continuation
      ptr to one of these info tables.
 
   The info table code, both direct and vectored, must:
      * push R1/F1/D1 on the stack
      * push the BCO (so it's now on the stack twice)
      * Yield, ie, go to the scheduler.

   Scheduler examines the t.o.s, discovers it is a BCO, and proceeds
   directly to the bytecode interpreter.  That pops the top element
   (the BCO, containing the return continuation), and interprets it.
   Net result: return continuation gets interpreted, with the
   following stack:

      ptr to this BCO
      ptr to the info table just jumped thru
      return value

   which is just what we want -- the "standard" return layout for the
   interpreter.  Hurrah!

   Don't ask me how unboxed tuple returns are supposed to work.  We
   haven't got a good story about that yet.
*/
110

111
/* When the returned value is in R1 ... */
112
#define STG_CtoI_RET_R1_Template(label) 	\
113
114
115
116
117
118
119
120
121
122
123
124
   IFN_(label)			        \
   {                                    \
      StgPtr bco;                       \
      FB_				\
      bco = ((StgPtr*)Sp)[1];           \
      Sp -= 1;				\
      ((StgPtr*)Sp)[0] = R1.p;		\
      Sp -= 1;				\
      ((StgPtr*)Sp)[0] = bco;		\
      JMP_(stg_yield_to_interpreter);   \
      FE_                               \
   }
125

126
127
128
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
STG_CtoI_RET_R1_Template(stg_ctoi_ret_R1_entry);
STG_CtoI_RET_R1_Template(stg_ctoi_ret_R1_0_entry);
STG_CtoI_RET_R1_Template(stg_ctoi_ret_R1_1_entry);
STG_CtoI_RET_R1_Template(stg_ctoi_ret_R1_2_entry);
STG_CtoI_RET_R1_Template(stg_ctoi_ret_R1_3_entry);
STG_CtoI_RET_R1_Template(stg_ctoi_ret_R1_4_entry);
STG_CtoI_RET_R1_Template(stg_ctoi_ret_R1_5_entry);
STG_CtoI_RET_R1_Template(stg_ctoi_ret_R1_6_entry);
STG_CtoI_RET_R1_Template(stg_ctoi_ret_R1_7_entry);

VEC_POLY_INFO_TABLE(stg_ctoi_ret_R1,0, NULL/*srt*/, 0/*srt_off*/, 0/*srt_len*/, RET_BCO,, EF_);

/* When the returned value is in F1 ... */
/* TODO */
/* When the returned value is in D1 ... */
/* TODO */


/* The other way round: when the interpreter returns a value to
   compiled code.  The stack looks like this:

      return info table (pushed by compiled code)
      return value (pushed by interpreter)

   If the value is ptr-rep'd, the interpreter simply returns to the
   scheduler, instructing it to ThreadEnterGHC.

   Otherwise (unboxed return value), we replace the top stack word,
   which must be the tag, with stg_gc_unbx_r1_info (or f1_info or d1_info),
   and return to the scheduler, instructing it to ThreadRunGHC.

   No supporting code needed!
*/
159
160


161
162
163
164
/* Entering a BCO.  Heave it on the stack and defer to the
   scheduler. */
INFO_TABLE(stg_BCO_info,stg_BCO_entry,3,0,BCO,,EF_,"BCO","BCO");
STGFUN(stg_BCO_entry) {
165
  FB_
166
167
168
    Sp -= 1;
    Sp[0] = R1.w;
    JMP_(stg_yield_to_interpreter);
169
170
171
172
173
174
  FE_
}

#endif /* GHCI */


175
176
177
178
/* -----------------------------------------------------------------------------
   Entry code for an indirection.
   -------------------------------------------------------------------------- */

179
180
INFO_TABLE(stg_IND_info,stg_IND_entry,1,0,IND,,EF_,0,0);
STGFUN(stg_IND_entry)
181
182
183
184
185
186
{
    FB_
    TICK_ENT_IND(Node);	/* tick */

    R1.p = (P_) ((StgInd*)R1.p)->indirectee;
    TICK_ENT_VIA_NODE();
187
    JMP_(ENTRY_CODE(*R1.p));
188
189
190
    FE_
}

191
192
INFO_TABLE(stg_IND_STATIC_info,stg_IND_STATIC_entry,1,0,IND_STATIC,,EF_,0,0);
STGFUN(stg_IND_STATIC_entry)
193
194
195
196
197
{
    FB_
    TICK_ENT_IND(Node);	/* tick */
    R1.p = (P_) ((StgIndStatic*)R1.p)->indirectee;
    TICK_ENT_VIA_NODE();
198
    JMP_(ENTRY_CODE(*R1.p));
199
200
201
    FE_
}

202
203
INFO_TABLE(stg_IND_PERM_info,stg_IND_PERM_entry,1,1,IND_PERM,,EF_,"IND_PERM","IND_PERM");
STGFUN(stg_IND_PERM_entry)
204
205
206
{
    FB_
    /* Don't add INDs to granularity cost */
207
208
209
210
211
212
    /* Dont: TICK_ENT_IND(Node); for ticky-ticky; this ind is here only to help profiling */

#if defined(TICKY_TICKY) && !defined(PROFILING)
    /* TICKY_TICKY && !PROFILING means PERM_IND *replaces* an IND, rather than being extra  */
    TICK_ENT_PERM_IND(R1.p); /* tick */
#endif
213
214
215
216

    /* Enter PAP cost centre -- lexical scoping only */
    ENTER_CCS_PAP_CL(R1.cl);

217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
    /* For ticky-ticky, change the perm_ind to a normal ind on first
     * entry, so the number of ent_perm_inds is the number of *thunks*
     * entered again, not the number of subsequent entries.
     *
     * Since this screws up cost centres, we die if profiling and
     * ticky_ticky are on at the same time.  KSW 1999-01.
     */

#ifdef TICKY_TICKY
#  ifdef PROFILING
#    error Profiling and ticky-ticky do not mix at present!
#  endif  /* PROFILING */
    SET_INFO((StgInd*)R1.p,&IND_info);
#endif /* TICKY_TICKY */

232
233
234
235
    R1.p = (P_) ((StgInd*)R1.p)->indirectee;

    /* Dont: TICK_ENT_VIA_NODE(); for ticky-ticky; as above */

236
237
238
239
#if defined(TICKY_TICKY) && !defined(PROFILING)
    TICK_ENT_VIA_NODE();
#endif

240
    JMP_(ENTRY_CODE(*R1.p));
241
242
243
    FE_
}  

244
245
INFO_TABLE(stg_IND_OLDGEN_info,stg_IND_OLDGEN_entry,1,1,IND_OLDGEN,,EF_,0,0);
STGFUN(stg_IND_OLDGEN_entry)
246
247
248
249
250
251
{
    FB_
    TICK_ENT_IND(Node);	/* tick */
  
    R1.p = (P_) ((StgInd*)R1.p)->indirectee;
    TICK_ENT_VIA_NODE();
252
    JMP_(ENTRY_CODE(*R1.p));
253
254
255
    FE_
}

256
257
INFO_TABLE(stg_IND_OLDGEN_PERM_info,stg_IND_OLDGEN_PERM_entry,1,1,IND_OLDGEN_PERM,,EF_,0,0);
STGFUN(stg_IND_OLDGEN_PERM_entry)
258
259
{
    FB_
260
    /* Dont: TICK_ENT_IND(Node); for ticky-ticky; this ind is here only to help profiling */
261

262
263
264
265
266
#if defined(TICKY_TICKY) && !defined(PROFILING)
    /* TICKY_TICKY && !PROFILING means PERM_IND *replaces* an IND, rather than being extra  */
    TICK_ENT_PERM_IND(R1.p); /* tick */
#endif
  
267
268
269
    /* Enter PAP cost centre -- lexical scoping only */
    ENTER_CCS_PAP_CL(R1.cl);

270
271
272
273
274
275
276
277
    /* see comment in IND_PERM */
#ifdef TICKY_TICKY
#  ifdef PROFILING
#    error Profiling and ticky-ticky do not mix at present!
#  endif  /* PROFILING */
    SET_INFO((StgInd*)R1.p,&IND_OLDGEN_info);
#endif /* TICKY_TICKY */

278
279
    R1.p = (P_) ((StgInd*)R1.p)->indirectee;
    TICK_ENT_VIA_NODE();
280
    JMP_(ENTRY_CODE(*R1.p));
281
282
283
284
285
286
287
288
289
    FE_
}

/* -----------------------------------------------------------------------------
   Entry code for CAFs

   This code assumes R1 is in a register for now.
   -------------------------------------------------------------------------- */

290
291
INFO_TABLE(stg_CAF_UNENTERED_info,stg_CAF_UNENTERED_entry,1,3,CAF_UNENTERED,,EF_,0,0);
STGFUN(stg_CAF_UNENTERED_entry)
292
293
294
295
296
{
    FB_
    /* ToDo: implement directly in GHC */
    Sp -= 1;
    Sp[0] = R1.w;
297
    JMP_(stg_yield_to_interpreter);
298
299
300
    FE_
}

301
/* 0,4 is entirely bogus; _do not_ rely on this info */
302
303
INFO_TABLE(stg_CAF_ENTERED_info,stg_CAF_ENTERED_entry,0,4,CAF_ENTERED,,EF_,0,0);
STGFUN(stg_CAF_ENTERED_entry)
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
{
    FB_
    R1.p = (P_) ((StgCAF*)R1.p)->value; /* just a fancy indirection */
    TICK_ENT_VIA_NODE();
    JMP_(GET_ENTRY(R1.cl));
    FE_
}

/* -----------------------------------------------------------------------------
   Entry code for a black hole.

   Entering a black hole normally causes a cyclic data dependency, but
   in the concurrent world, black holes are synchronization points,
   and they are turned into blocking queues when there are threads
   waiting for the evaluation of the closure to finish.
   -------------------------------------------------------------------------- */

321
322
323
324
325
/* Note: a BLACKHOLE and BLACKHOLE_BQ must be big enough to be
 * overwritten with an indirection/evacuee/catch.  Thus we claim it
 * has 1 non-pointer word of payload (in addition to the pointer word
 * for the blocking queue in a BQ), which should be big enough for an
 * old-generation indirection. 
326
327
 */

328
329
INFO_TABLE(stg_BLACKHOLE_info, stg_BLACKHOLE_entry,0,2,BLACKHOLE,,EF_,"BLACKHOLE","BLACKHOLE");
STGFUN(stg_BLACKHOLE_entry)
330
331
{
  FB_
332
333
334
335
336
#if defined(GRAN)
    /* Before overwriting TSO_LINK */
    STGCALL3(GranSimBlock,CurrentTSO,CurrentProc,(StgClosure *)R1.p /*Node*/);
#endif

337
#ifdef SMP
338
339
340
341
342
343
344
345
346
347
348
    {
      bdescr *bd = Bdescr(R1.p);
      if (bd->back != (bdescr *)BaseReg) {
	if (bd->gen->no >= 1 || bd->step->no >= 1) {
	  CMPXCHG(R1.cl->header.info, &BLACKHOLE_info, &WHITEHOLE_info);
	} else {
	  EXTFUN_RTS(stg_gc_enter_1_hponly);
	  JMP_(stg_gc_enter_1_hponly);
	}
      }
    }
349
#endif
350
351
    TICK_ENT_BH();

352
    /* Put ourselves on the blocking queue for this black hole */
353
354
355
356
357
358
#if defined(GRAN) || defined(PAR)
    /* in fact, only difference is the type of the end-of-queue marker! */
    CurrentTSO->link = END_BQ_QUEUE;
    ((StgBlockingQueue *)R1.p)->blocking_queue = (StgBlockingQueueElement *)CurrentTSO;
#else
    CurrentTSO->link = END_TSO_QUEUE;
359
    ((StgBlockingQueue *)R1.p)->blocking_queue = CurrentTSO;
360
361
#endif
    /* jot down why and on what closure we are blocked */
362
363
    CurrentTSO->why_blocked = BlockedOnBlackHole;
    CurrentTSO->block_info.closure = R1.cl;
364
    /* closure is mutable since something has just been added to its BQ */
365
    recordMutable((StgMutClosure *)R1.cl);
366
    /* Change the BLACKHOLE into a BLACKHOLE_BQ */
367
    ((StgBlockingQueue *)R1.p)->header.info = &stg_BLACKHOLE_BQ_info;
368

369
    /* PAR: dumping of event now done in blockThread -- HWL */
370

371
372
    /* stg_gen_block is too heavyweight, use a specialised one */
    BLOCK_NP(1);
373

374
375
376
  FE_
}

377
378
INFO_TABLE(stg_BLACKHOLE_BQ_info, stg_BLACKHOLE_BQ_entry,1,1,BLACKHOLE_BQ,,EF_,"BLACKHOLE","BLACKHOLE");
STGFUN(stg_BLACKHOLE_BQ_entry)
379
380
{
  FB_
381
382
383
384
385
#if defined(GRAN)
    /* Before overwriting TSO_LINK */
    STGCALL3(GranSimBlock,CurrentTSO,CurrentProc,(StgClosure *)R1.p /*Node*/);
#endif

386
#ifdef SMP
387
388
389
390
391
392
393
394
395
396
397
    {
      bdescr *bd = Bdescr(R1.p);
      if (bd->back != (bdescr *)BaseReg) {
	if (bd->gen->no >= 1 || bd->step->no >= 1) {
	  CMPXCHG(R1.cl->header.info, &BLACKHOLE_info, &WHITEHOLE_info);
	} else {
	  EXTFUN_RTS(stg_gc_enter_1_hponly);
	  JMP_(stg_gc_enter_1_hponly);
	}
      }
    }
398
399
#endif

400
401
    TICK_ENT_BH();

402
    /* Put ourselves on the blocking queue for this black hole */
403
404
    CurrentTSO->link = ((StgBlockingQueue *)R1.p)->blocking_queue;
    ((StgBlockingQueue *)R1.p)->blocking_queue = CurrentTSO;
405
406
407
    /* jot down why and on what closure we are blocked */
    CurrentTSO->why_blocked = BlockedOnBlackHole;
    CurrentTSO->block_info.closure = R1.cl;
408
#ifdef SMP
409
    ((StgBlockingQueue *)R1.p)->header.info = &stg_BLACKHOLE_BQ_info;
410
#endif
411

412
    /* PAR: dumping of event now done in blockThread -- HWL */
413

414
415
416
417
418
    /* stg_gen_block is too heavyweight, use a specialised one */
    BLOCK_NP(1);
  FE_
}

419
420
421
422
423
424
425
426
427
428
429
430
431
432
/*
   Revertible black holes are needed in the parallel world, to handle
   negative acknowledgements of messages containing updatable closures.
   The idea is that when the original message is transmitted, the closure
   is turned into a revertible black hole...an object which acts like a
   black hole when local threads try to enter it, but which can be reverted
   back to the original closure if necessary.

   It's actually a lot like a blocking queue (BQ) entry, because revertible
   black holes are initially set up with an empty blocking queue.
*/

#if defined(PAR) || defined(GRAN)

433
434
INFO_TABLE(stg_RBH_info, stg_RBH_entry,1,1,RBH,,EF_,0,0);
STGFUN(stg_RBH_entry)
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
{
  FB_
# if defined(GRAN)
    /* mainly statistics gathering for GranSim simulation */
    STGCALL3(GranSimBlock,CurrentTSO,CurrentProc,(StgClosure *)R1.p /*Node*/);
# endif

    /* exactly the same as a BLACKHOLE_BQ_entry -- HWL */
    /* Put ourselves on the blocking queue for this black hole */
    CurrentTSO->link = ((StgBlockingQueue *)R1.p)->blocking_queue;
    ((StgBlockingQueue *)R1.p)->blocking_queue = CurrentTSO;
    /* jot down why and on what closure we are blocked */
    CurrentTSO->why_blocked = BlockedOnBlackHole;
    CurrentTSO->block_info.closure = R1.cl;

450
    /* PAR: dumping of event now done in blockThread -- HWL */
451
452
453
454
455
456

    /* stg_gen_block is too heavyweight, use a specialised one */
    BLOCK_NP(1); 
  FE_
}

457
INFO_TABLE(stg_RBH_Save_0_info, stg_RBH_Save_0_entry,0,2,CONSTR,,EF_,0,0);
458
459
NON_ENTERABLE_ENTRY_CODE(RBH_Save_0);

460
INFO_TABLE(stg_RBH_Save_1_info, stg_RBH_Save_1_entry,1,1,CONSTR,,EF_,0,0);
461
462
NON_ENTERABLE_ENTRY_CODE(RBH_Save_1);

463
INFO_TABLE(stg_RBH_Save_2_info, stg_RBH_Save_2_entry,2,0,CONSTR,,EF_,0,0);
464
465
466
NON_ENTERABLE_ENTRY_CODE(RBH_Save_2);
#endif /* defined(PAR) || defined(GRAN) */

467
/* identical to BLACKHOLEs except for the infotag */
468
INFO_TABLE(stg_CAF_BLACKHOLE_info, stg_CAF_BLACKHOLE_entry,0,2,CAF_BLACKHOLE,,EF_,"CAF_BLACKHOLE","CAF_BLACKHOLE");
469
STGFUN(stg_CAF_BLACKHOLE_entry)
470
471
{
  FB_
472
473
474
475
476
#if defined(GRAN)
    /* mainly statistics gathering for GranSim simulation */
    STGCALL3(GranSimBlock,CurrentTSO,CurrentProc,(StgClosure *)R1.p /*Node*/);
#endif

477
#ifdef SMP
478
479
480
481
482
483
484
485
486
487
488
    {
      bdescr *bd = Bdescr(R1.p);
      if (bd->back != (bdescr *)BaseReg) {
	if (bd->gen->no >= 1 || bd->step->no >= 1) {
	  CMPXCHG(R1.cl->header.info, &CAF_BLACKHOLE_info, &WHITEHOLE_info);
	} else {
	  EXTFUN_RTS(stg_gc_enter_1_hponly);
	  JMP_(stg_gc_enter_1_hponly);
	}
      }
    }
489
#endif
490
491
492
493

    TICK_ENT_BH();

    /* Put ourselves on the blocking queue for this black hole */
494
495
496
497
498
499
#if defined(GRAN) || defined(PAR)
    /* in fact, only difference is the type of the end-of-queue marker! */
    CurrentTSO->link = END_BQ_QUEUE;
    ((StgBlockingQueue *)R1.p)->blocking_queue = (StgBlockingQueueElement *)CurrentTSO;
#else
    CurrentTSO->link = END_TSO_QUEUE;
500
    ((StgBlockingQueue *)R1.p)->blocking_queue = CurrentTSO;
501
502
#endif
    /* jot down why and on what closure we are blocked */
503
504
    CurrentTSO->why_blocked = BlockedOnBlackHole;
    CurrentTSO->block_info.closure = R1.cl;
505
    /* closure is mutable since something has just been added to its BQ */
506
507
    recordMutable((StgMutClosure *)R1.cl);
    /* Change the CAF_BLACKHOLE into a BLACKHOLE_BQ */
508
    ((StgBlockingQueue *)R1.p)->header.info = &stg_BLACKHOLE_BQ_info;
509

510
    /* PAR: dumping of event now done in blockThread -- HWL */
511
512
513

    /* stg_gen_block is too heavyweight, use a specialised one */
    BLOCK_NP(1);
514
515
516
  FE_
}

517
#ifdef TICKY_TICKY
518
519
INFO_TABLE(stg_SE_BLACKHOLE_info, stg_SE_BLACKHOLE_entry,0,2,SE_BLACKHOLE,,EF_,0,0);
STGFUN(stg_SE_BLACKHOLE_entry)
520
521
522
{
  FB_
    STGCALL3(fprintf,stderr,"SE_BLACKHOLE at %p entered!\n",R1.p);
523
    STGCALL1(shutdownHaskellAndExit,EXIT_FAILURE);
524
525
526
  FE_
}

527
INFO_TABLE(SE_CAF_BLACKHOLE_info, SE_CAF_BLACKHOLE_entry,0,2,SE_CAF_BLACKHOLE,,EF_,0,0);
528
STGFUN(stg_SE_CAF_BLACKHOLE_entry)
529
530
531
{
  FB_
    STGCALL3(fprintf,stderr,"SE_CAF_BLACKHOLE at %p entered!\n",R1.p);
532
    STGCALL1(shutdownHaskellAndExit,EXIT_FAILURE);
533
534
535
536
  FE_
}
#endif

537
#ifdef SMP
538
539
INFO_TABLE(stg_WHITEHOLE_info, stg_WHITEHOLE_entry,0,2,CONSTR_NOCAF_STATIC,,EF_,0,0);
STGFUN(stg_WHITEHOLE_entry)
540
541
542
543
544
545
546
{
  FB_
     JMP_(GET_ENTRY(R1.cl));
  FE_
}
#endif

547
548
549
/* -----------------------------------------------------------------------------
   Some static info tables for things that don't get entered, and
   therefore don't need entry code (i.e. boxed but unpointed objects)
550
   NON_ENTERABLE_ENTRY_CODE now defined at the beginning of the file
551
552
   -------------------------------------------------------------------------- */

553
INFO_TABLE(stg_TSO_info, stg_TSO_entry, 0,0,TSO,,EF_,"TSO","TSO");
554
555
556
557
558
559
560
NON_ENTERABLE_ENTRY_CODE(TSO);

/* -----------------------------------------------------------------------------
   Evacuees are left behind by the garbage collector.  Any attempt to enter
   one is a real bug.
   -------------------------------------------------------------------------- */

561
INFO_TABLE(stg_EVACUATED_info,stg_EVACUATED_entry,1,0,EVACUATED,,EF_,0,0);
562
563
564
565
566
567
568
569
570
571
NON_ENTERABLE_ENTRY_CODE(EVACUATED);

/* -----------------------------------------------------------------------------
   Weak pointers

   Live weak pointers have a special closure type.  Dead ones are just
   nullary constructors (although they live on the heap - we overwrite
   live weak pointers with dead ones).
   -------------------------------------------------------------------------- */

572
INFO_TABLE(stg_WEAK_info,stg_WEAK_entry,0,4,WEAK,,EF_,"WEAK","WEAK");
573
574
NON_ENTERABLE_ENTRY_CODE(WEAK);

575
INFO_TABLE_CONSTR(stg_DEAD_WEAK_info,stg_DEAD_WEAK_entry,0,1,0,CONSTR,,EF_,"DEAD_WEAK","DEAD_WEAK");
576
577
NON_ENTERABLE_ENTRY_CODE(DEAD_WEAK);

578
/* -----------------------------------------------------------------------------
579
   NO_FINALIZER
580
581

   This is a static nullary constructor (like []) that we use to mark an empty
582
   finalizer in a weak pointer object.
583
584
   -------------------------------------------------------------------------- */

585
INFO_TABLE_CONSTR(stg_NO_FINALIZER_info,stg_NO_FINALIZER_entry,0,0,0,CONSTR_NOCAF_STATIC,,EF_,0,0);
586
NON_ENTERABLE_ENTRY_CODE(NO_FINALIZER);
587

588
SET_STATIC_HDR(stg_NO_FINALIZER_closure,stg_NO_FINALIZER_info,0/*CC*/,,EI_)
589
, /*payload*/{} };
590

591
592
593
594
/* -----------------------------------------------------------------------------
   Foreign Objects are unlifted and therefore never entered.
   -------------------------------------------------------------------------- */

595
INFO_TABLE(stg_FOREIGN_info,stg_FOREIGN_entry,0,1,FOREIGN,,EF_,"FOREIGN","FOREIGN");
596
597
NON_ENTERABLE_ENTRY_CODE(FOREIGN);

598
599
600
601
/* -----------------------------------------------------------------------------
   Stable Names are unlifted too.
   -------------------------------------------------------------------------- */

602
INFO_TABLE(stg_STABLE_NAME_info,stg_STABLE_NAME_entry,0,1,STABLE_NAME,,EF_,"STABLE_NAME","STABLE_NAME");
603
604
NON_ENTERABLE_ENTRY_CODE(STABLE_NAME);

605
606
607
608
609
610
611
/* -----------------------------------------------------------------------------
   MVars

   There are two kinds of these: full and empty.  We need an info table
   and entry code for each type.
   -------------------------------------------------------------------------- */

612
INFO_TABLE(stg_FULL_MVAR_info,stg_FULL_MVAR_entry,4,0,MVAR,,EF_,"MVAR","MVAR");
613
614
NON_ENTERABLE_ENTRY_CODE(FULL_MVAR);

615
INFO_TABLE(stg_EMPTY_MVAR_info,stg_EMPTY_MVAR_entry,4,0,MVAR,,EF_,"MVAR","MVAR");
616
617
618
619
620
621
622
623
624
NON_ENTERABLE_ENTRY_CODE(EMPTY_MVAR);

/* -----------------------------------------------------------------------------
   END_TSO_QUEUE

   This is a static nullary constructor (like []) that we use to mark the
   end of a linked TSO queue.
   -------------------------------------------------------------------------- */

625
INFO_TABLE_CONSTR(stg_END_TSO_QUEUE_info,stg_END_TSO_QUEUE_entry,0,0,0,CONSTR_NOCAF_STATIC,,EF_,0,0);
626
627
NON_ENTERABLE_ENTRY_CODE(END_TSO_QUEUE);

628
SET_STATIC_HDR(stg_END_TSO_QUEUE_closure,stg_END_TSO_QUEUE_info,0/*CC*/,,EI_)
629
, /*payload*/{} };
630

631
632
633
634
635
636
637
638
/* -----------------------------------------------------------------------------
   Mutable lists

   Mutable lists (used by the garbage collector) consist of a chain of
   StgMutClosures connected through their mut_link fields, ending in
   an END_MUT_LIST closure.
   -------------------------------------------------------------------------- */

639
INFO_TABLE_CONSTR(stg_END_MUT_LIST_info,stg_END_MUT_LIST_entry,0,0,0,CONSTR_NOCAF_STATIC,,EF_,0,0);
640
641
NON_ENTERABLE_ENTRY_CODE(END_MUT_LIST);

642
SET_STATIC_HDR(stg_END_MUT_LIST_closure,stg_END_MUT_LIST_info,0/*CC*/,,EI_)
643
, /*payload*/{} };
644

645
INFO_TABLE(stg_MUT_CONS_info, stg_MUT_CONS_entry, 1, 1, MUT_VAR, , EF_, 0, 0);
646
647
NON_ENTERABLE_ENTRY_CODE(MUT_CONS);

648
649
650
651
/* -----------------------------------------------------------------------------
   Exception lists
   -------------------------------------------------------------------------- */

652
INFO_TABLE_CONSTR(stg_END_EXCEPTION_LIST_info,stg_END_EXCEPTION_LIST_entry,0,0,0,CONSTR_NOCAF_STATIC,,EF_,0,0);
653
654
NON_ENTERABLE_ENTRY_CODE(END_EXCEPTION_LIST);

655
SET_STATIC_HDR(stg_END_EXCEPTION_LIST_closure,stg_END_EXCEPTION_LIST_info,0/*CC*/,,EI_)
656
, /*payload*/{} };
657

658
INFO_TABLE(stg_EXCEPTION_CONS_info, stg_EXCEPTION_CONS_entry, 1, 1, CONSTR, , EF_, 0, 0);
659
660
NON_ENTERABLE_ENTRY_CODE(EXCEPTION_CONS);

661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
/* -----------------------------------------------------------------------------
   Arrays

   These come in two basic flavours: arrays of data (StgArrWords) and arrays of
   pointers (StgArrPtrs).  They all have a similar layout:

	___________________________
	| Info | No. of | data....
        |  Ptr | Words  |
	---------------------------

   These are *unpointed* objects: i.e. they cannot be entered.

   -------------------------------------------------------------------------- */

676
#define ArrayInfo(type)					\
677
INFO_TABLE(stg_##type##_info, stg_##type##_entry, 0, 0, type, , EF_,"" # type "","" # type "");
678
679

ArrayInfo(ARR_WORDS);
680
NON_ENTERABLE_ENTRY_CODE(ARR_WORDS);
681
ArrayInfo(MUT_ARR_PTRS);
682
NON_ENTERABLE_ENTRY_CODE(MUT_ARR_PTRS);
683
ArrayInfo(MUT_ARR_PTRS_FROZEN);
684
NON_ENTERABLE_ENTRY_CODE(MUT_ARR_PTRS_FROZEN);
685
686
687
688
689
690
691

#undef ArrayInfo

/* -----------------------------------------------------------------------------
   Mutable Variables
   -------------------------------------------------------------------------- */

692
INFO_TABLE(stg_MUT_VAR_info, stg_MUT_VAR_entry, 1, 1, MUT_VAR, , EF_, "MUT_VAR", "MUT_VAR");
693
694
695
696
697
698
699
700
NON_ENTERABLE_ENTRY_CODE(MUT_VAR);

/* -----------------------------------------------------------------------------
   Standard Error Entry.

   This is used for filling in vector-table entries that can never happen,
   for instance.
   -------------------------------------------------------------------------- */
rrt's avatar
rrt committed
701
702
/* No longer used; we use NULL, because a) it never happens, right? and b)
   Windows doesn't like DLL entry points being used as static initialisers
703
704
705
STGFUN(stg_error_entry)							\
{									\
  FB_									\
sof's avatar
sof committed
706
    DUMP_ERRMSG("fatal: stg_error_entry");                              \
707
    STGCALL1(shutdownHaskellAndExit, EXIT_FAILURE);			\
708
    return NULL;							\
709
710
  FE_									\
}
rrt's avatar
rrt committed
711
*/
712
713
714
715
716
717
718
719
/* -----------------------------------------------------------------------------
   Dummy return closure
 
   Entering this closure will just return to the address on the top of the
   stack.  Useful for getting a thread in a canonical form where we can
   just enter the top stack word to start the thread.  (see deleteThread)
 * -------------------------------------------------------------------------- */

720
721
INFO_TABLE(stg_dummy_ret_info, stg_dummy_ret_entry, 0, 0, CONSTR_NOCAF_STATIC, , EF_, 0, 0);
STGFUN(stg_dummy_ret_entry)
722
723
724
725
726
727
{
  W_ ret_addr;
  FB_
  ret_addr = Sp[0];
  Sp++;
  JMP_(ENTRY_CODE(ret_addr));
728
  FE_
729
}
730
SET_STATIC_HDR(stg_dummy_ret_closure,stg_dummy_ret_info,CCS_DONT_CARE,,EI_)
731
, /*payload*/{} };
732

sof's avatar
sof committed
733
734
735
736
737
738
739
740
741
742
743
744
745
/* -----------------------------------------------------------------------------
    Strict IO application - performing an IO action and entering its result.
    
    rts_evalIO() lets you perform Haskell IO actions from outside of Haskell-land,
    returning back to you their result. Want this result to be evaluated to WHNF
    by that time, so that we can easily get at the int/char/whatever using the
    various get{Ty} functions provided by the RTS API.

    forceIO takes care of this, performing the IO action and entering the
    results that comes back.

 * -------------------------------------------------------------------------- */

746
#ifdef REG_R1
747
748
INFO_TABLE_SRT_BITMAP(stg_forceIO_ret_info,stg_forceIO_ret_entry,0,0,0,0,RET_SMALL,,EF_,0,0);
STGFUN(stg_forceIO_ret_entry)
sof's avatar
sof committed
749
750
751
752
753
754
755
{
  FB_
  Sp++;
  Sp -= sizeofW(StgSeqFrame);
  PUSH_SEQ_FRAME(Sp);
  JMP_(GET_ENTRY(R1.cl));
}
756
#else
757
758
INFO_TABLE_SRT_BITMAP(stg_forceIO_ret_info,stg_forceIO_ret_entry,0,0,0,0,RET_SMALL,,EF_,0,0);
STGFUN(forceIO_ret_entry)
759
760
761
762
763
764
765
{
  StgClosure *rval;
  FB_
  rval = (StgClosure *)Sp[0];
  Sp += 2;
  Sp -= sizeofW(StgSeqFrame);
  PUSH_SEQ_FRAME(Sp);
766
767
  R1.cl = rval;
  JMP_(GET_ENTRY(R1.cl));
768
769
}
#endif
sof's avatar
sof committed
770

771
772
INFO_TABLE(stg_forceIO_info,stg_forceIO_entry,1,0,FUN_STATIC,,EF_,0,0);
FN_(stg_forceIO_entry)
sof's avatar
sof committed
773
774
775
776
777
{
  FB_
  /* Sp[0] contains the IO action we want to perform */
  R1.p  = (P_)Sp[0];
  /* Replace it with the return continuation that enters the result. */
778
  Sp[0] = (W_)&stg_forceIO_ret_info;
sof's avatar
sof committed
779
780
781
782
783
784
  Sp--;
  /* Push the RealWorld# tag and enter */
  Sp[0] =(W_)REALWORLD_TAG;
  JMP_(GET_ENTRY(R1.cl));
  FE_
}
785
SET_STATIC_HDR(stg_forceIO_closure,stg_forceIO_info,CCS_DONT_CARE,,EI_)
786
, /*payload*/{} };
sof's avatar
sof committed
787
788


789
790
791
792
793
794
795
796
/* -----------------------------------------------------------------------------
   CHARLIKE and INTLIKE closures.  

   These are static representations of Chars and small Ints, so that
   we can remove dynamic Chars and Ints during garbage collection and
   replace them with references to the static objects.
   -------------------------------------------------------------------------- */

797
#if defined(INTERPRETER) || defined(ENABLE_WIN32_DLL_SUPPORT)
sof's avatar
sof committed
798
799
800
801
802
803
/*
 * When sticking the RTS in a DLL, we delay populating the
 * Charlike and Intlike tables until load-time, which is only
 * when we've got the real addresses to the C# and I# closures.
 *
 */
804
805
static INFO_TBL_CONST StgInfoTable czh_static_info;
static INFO_TBL_CONST StgInfoTable izh_static_info;
sof's avatar
sof committed
806
807
808
#define Char_hash_static_info czh_static_info
#define Int_hash_static_info izh_static_info
#else
809
810
#define Char_hash_static_info PrelBase_Czh_static_info
#define Int_hash_static_info PrelBase_Izh_static_info
sof's avatar
sof committed
811
812
#endif

813
814
#define CHARLIKE_HDR(n)						\
	{							\
sof's avatar
sof committed
815
	  STATIC_HDR(Char_hash_static_info, /* C# */   		\
816
			 CCS_DONT_CARE),			\
817
818
819
820
821
          data : n						\
	}
					     
#define INTLIKE_HDR(n)						\
	{							\
sof's avatar
sof committed
822
	  STATIC_HDR(Int_hash_static_info,  /* I# */  		\
823
			 CCS_DONT_CARE),			\
824
825
826
827
828
829
830
831
832
          data : n						\
	}

/* put these in the *data* section, since the garbage collector relies
 * on the fact that static closures live in the data section.
 */

/* end the name with _closure, to convince the mangler this is a closure */

833
StgIntCharlikeClosure stg_CHARLIKE_closure[] = {
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
    CHARLIKE_HDR(0),
    CHARLIKE_HDR(1),
    CHARLIKE_HDR(2),
    CHARLIKE_HDR(3),
    CHARLIKE_HDR(4),
    CHARLIKE_HDR(5),
    CHARLIKE_HDR(6),
    CHARLIKE_HDR(7),
    CHARLIKE_HDR(8),
    CHARLIKE_HDR(9),
    CHARLIKE_HDR(10),
    CHARLIKE_HDR(11),
    CHARLIKE_HDR(12),
    CHARLIKE_HDR(13),
    CHARLIKE_HDR(14),
    CHARLIKE_HDR(15),
    CHARLIKE_HDR(16),
    CHARLIKE_HDR(17),
    CHARLIKE_HDR(18),
    CHARLIKE_HDR(19),
    CHARLIKE_HDR(20),
    CHARLIKE_HDR(21),
    CHARLIKE_HDR(22),
    CHARLIKE_HDR(23),
    CHARLIKE_HDR(24),
    CHARLIKE_HDR(25),
    CHARLIKE_HDR(26),
    CHARLIKE_HDR(27),
    CHARLIKE_HDR(28),
    CHARLIKE_HDR(29),
    CHARLIKE_HDR(30),
    CHARLIKE_HDR(31),
    CHARLIKE_HDR(32),
    CHARLIKE_HDR(33),
    CHARLIKE_HDR(34),
    CHARLIKE_HDR(35),
    CHARLIKE_HDR(36),
    CHARLIKE_HDR(37),
    CHARLIKE_HDR(38),
    CHARLIKE_HDR(39),
    CHARLIKE_HDR(40),
    CHARLIKE_HDR(41),
    CHARLIKE_HDR(42),
    CHARLIKE_HDR(43),
    CHARLIKE_HDR(44),
    CHARLIKE_HDR(45),
    CHARLIKE_HDR(46),
    CHARLIKE_HDR(47),
    CHARLIKE_HDR(48),
    CHARLIKE_HDR(49),
    CHARLIKE_HDR(50),
    CHARLIKE_HDR(51),
    CHARLIKE_HDR(52),
    CHARLIKE_HDR(53),
    CHARLIKE_HDR(54),
    CHARLIKE_HDR(55),
    CHARLIKE_HDR(56),
    CHARLIKE_HDR(57),
    CHARLIKE_HDR(58),
    CHARLIKE_HDR(59),
    CHARLIKE_HDR(60),
    CHARLIKE_HDR(61),
    CHARLIKE_HDR(62),
    CHARLIKE_HDR(63),
    CHARLIKE_HDR(64),
    CHARLIKE_HDR(65),
    CHARLIKE_HDR(66),
    CHARLIKE_HDR(67),
    CHARLIKE_HDR(68),
    CHARLIKE_HDR(69),
    CHARLIKE_HDR(70),
    CHARLIKE_HDR(71),
    CHARLIKE_HDR(72),
    CHARLIKE_HDR(73),
    CHARLIKE_HDR(74),
    CHARLIKE_HDR(75),
    CHARLIKE_HDR(76),
    CHARLIKE_HDR(77),
    CHARLIKE_HDR(78),
    CHARLIKE_HDR(79),
    CHARLIKE_HDR(80),
    CHARLIKE_HDR(81),
    CHARLIKE_HDR(82),
    CHARLIKE_HDR(83),
    CHARLIKE_HDR(84),
    CHARLIKE_HDR(85),
    CHARLIKE_HDR(86),
    CHARLIKE_HDR(87),
    CHARLIKE_HDR(88),
    CHARLIKE_HDR(89),
    CHARLIKE_HDR(90),
    CHARLIKE_HDR(91),
    CHARLIKE_HDR(92),
    CHARLIKE_HDR(93),
    CHARLIKE_HDR(94),
    CHARLIKE_HDR(95),
    CHARLIKE_HDR(96),
    CHARLIKE_HDR(97),
    CHARLIKE_HDR(98),
    CHARLIKE_HDR(99),
    CHARLIKE_HDR(100),
    CHARLIKE_HDR(101),
    CHARLIKE_HDR(102),
    CHARLIKE_HDR(103),
    CHARLIKE_HDR(104),
    CHARLIKE_HDR(105),
    CHARLIKE_HDR(106),
    CHARLIKE_HDR(107),
    CHARLIKE_HDR(108),
    CHARLIKE_HDR(109),
    CHARLIKE_HDR(110),
    CHARLIKE_HDR(111),
    CHARLIKE_HDR(112),
    CHARLIKE_HDR(113),
    CHARLIKE_HDR(114),
    CHARLIKE_HDR(115),
    CHARLIKE_HDR(116),
    CHARLIKE_HDR(117),
    CHARLIKE_HDR(118),
    CHARLIKE_HDR(119),
    CHARLIKE_HDR(120),
    CHARLIKE_HDR(121),
    CHARLIKE_HDR(122),
    CHARLIKE_HDR(123),
    CHARLIKE_HDR(124),
    CHARLIKE_HDR(125),
    CHARLIKE_HDR(126),
    CHARLIKE_HDR(127),
    CHARLIKE_HDR(128),
    CHARLIKE_HDR(129),
    CHARLIKE_HDR(130),
    CHARLIKE_HDR(131),
    CHARLIKE_HDR(132),
    CHARLIKE_HDR(133),
    CHARLIKE_HDR(134),
    CHARLIKE_HDR(135),
    CHARLIKE_HDR(136),
    CHARLIKE_HDR(137),
    CHARLIKE_HDR(138),
    CHARLIKE_HDR(139),
    CHARLIKE_HDR(140),
    CHARLIKE_HDR(141),
    CHARLIKE_HDR(142),
    CHARLIKE_HDR(143),
    CHARLIKE_HDR(144),
    CHARLIKE_HDR(145),
    CHARLIKE_HDR(146),
    CHARLIKE_HDR(147),
    CHARLIKE_HDR(148),
    CHARLIKE_HDR(149),
    CHARLIKE_HDR(150),
    CHARLIKE_HDR(151),
    CHARLIKE_HDR(152),
    CHARLIKE_HDR(153),
    CHARLIKE_HDR(154),
    CHARLIKE_HDR(155),
    CHARLIKE_HDR(156),
    CHARLIKE_HDR(157),
    CHARLIKE_HDR(158),
    CHARLIKE_HDR(159),
    CHARLIKE_HDR(160),
    CHARLIKE_HDR(161),
    CHARLIKE_HDR(162),
    CHARLIKE_HDR(163),
    CHARLIKE_HDR(164),
    CHARLIKE_HDR(165),
    CHARLIKE_HDR(166),