44ce07b006e305813cb69d6548ee1b26f6fc7b95
[ghc-hetmet.git] / ghc / runtime / main / StgStartup.lhc
1 %/****************************************************************
2 %*                                                              *
3 %*   Basic Continuations required by the STG Machine runtime    *
4 %*                                                              *
5 %****************************************************************/
6
7
8 First continuation called by the mini-interpreter is
9 evaluateTopClosure.  It has to set up return and jump to the user's
10 @main@ closure.  If @errorIO@ is called, we will be back here, doing
11 the same thing for the specified continuation.
12
13 \begin{code}
14 #define MAIN_REG_MAP        /* STG world */
15 #include "rtsdefs.h"
16
17 #if 0
18 #ifdef PAR
19 #include "Statistics.h"
20 #endif
21 #endif
22
23 /* ptr to the user's "main" closure (or "errorIO" arg closure),
24    to which we hope to be linked
25 */
26 extern P_ TopClosure;
27
28 EXTFUN(stopThreadDirectReturn);
29 UNVECTBL(,vtbl_stopStgWorld,stopThreadDirectReturn)
30
31 /* Well, we have to put the ArrayOfData and ArrayOfPtrs info tables
32    somewhere...
33 */
34
35 /* Array of data -- mutable */
36 STATICFUN(ArrayOfData_entry)
37 {
38     FB_
39     /* Don't wrap the calls; we're done with STG land */
40     fflush(stdout);
41     fprintf(stderr, "Entered a primitive array (of data)---this shouldn't happen!\n");
42     abort();
43     FE_
44 }
45
46 DATA_ITBL(ArrayOfData_info,ArrayOfData_entry,UpdErr,0,INFO_OTHER_TAG,,,const,IF_,ARR_K,"DATA-ARRAY","ARRAY");
47 /* ToDo: could put a useful tag in there!!! */
48
49 /* Array of pointers -- mutable */
50 STATICFUN(ArrayOfPtrs_entry)
51 {
52     FB_
53     /* Don't wrap the calls; we're done with STG land */
54     fflush(stdout);
55     fprintf(stderr, "Entered a primitive array (of pointers)---this shouldn't happen!\n");
56     abort();
57     FE_
58 }
59
60 MUTUPLE_ITBL(ArrayOfPtrs_info,ArrayOfPtrs_entry,UpdErr,0,INFO_OTHER_TAG,,,const,IF_,ARR_K,"PTR-ARRAY(mut)","ARRAY");
61 /* ToDo: could put a useful tag in there!!! */
62
63 STATICFUN(FullSVar_entry)
64 {
65     FB_
66     /* Don't wrap the calls; we're done with STG land */
67     fflush(stdout);
68     fprintf(stderr, "Entered a full SVar---this shouldn't happen!\n");
69     abort();
70     FE_
71 }
72
73 MUTUPLE_ITBL(FullSVar_info,FullSVar_entry,UpdErr,0,INFO_OTHER_TAG,,,const,IF_,ARR_K,"FullSVar","ARRAY");
74 /* ToDo: could put a useful tag in there!!! */
75
76 STATICFUN(EmptySVar_entry)
77 {
78     FB_
79     /* Don't wrap the calls; we're done with STG land */
80     fflush(stdout);
81     fprintf(stderr, "Entered an empty SVar---this shouldn't happen!\n");
82     abort();
83     FE_
84 }
85
86 MUTUPLE_ITBL(EmptySVar_info,EmptySVar_entry,UpdErr,0,INFO_OTHER_TAG,,,const,IF_,ARR_K,"EmptySVar","ARRAY");
87 /* ToDo: could put a useful tag in there!!! */
88
89 /* Array of pointers -- immutable */
90 STATICFUN(ImMutArrayOfPtrs_entry)
91 {
92     FB_
93     /* Don't wrap the calls; we're done with STG land */
94     fflush(stdout);
95     fprintf(stderr, "Entered a primitive array (immutable, pointers)---this shouldn't happen!\n");
96     abort();
97     FE_
98 }
99
100 IMMUTUPLE_ITBL(ImMutArrayOfPtrs_info,ImMutArrayOfPtrs_entry,UpdErr,0,INFO_OTHER_TAG,,,const,IF_,ARR_K,"PTR-ARRAY(immut)","ARRAY");
101 /* ToDo: could put a useful tag in there!!! */
102
103 /* (end of Array whatnot) */
104
105 /* Question for Will: There seem to be a lot of these static things
106 now - worth putting them in a file by themselves?? [ADR] */
107
108
109 #if !defined(PAR) /* && !defined(GRAN) */
110
111 /* Ditto for Foreign Object entry point and info tables. [ADR]
112
113    BTW Will, I copied most of this blindly from above - what's with
114    this TAG stuff? And what kind of description/ type is wanted here?
115 */
116
117 STATICFUN(ForeignObj_entry)
118 {
119     FB_
120     /* Don't wrap the calls; we're done with STG land */
121     fflush(stdout);
122     fprintf(stderr, "Compiler bug: Entered a ForeignObj---this shouldn't happen!\n");
123     abort();
124     FE_
125 }
126
127 ForeignObj_ITBL(ForeignObj_info,ForeignObj_entry,UpdErr,0,INFO_OTHER_TAG,,,const,EF_,ForeignObj_K,"FOREIGN_OBJ","ForeignObj");
128
129 /* End of ForeignObj stuff */
130
131 /* Ditto for the unused Stable Pointer info table. [ADR]
132 */
133
134 void raiseError PROTO((StgStablePtr));
135 extern StgStablePtr errorHandler; /* NB: prone to magic-value-ery (WDP 95/12) */
136
137 /* Unused Stable Pointer (ie unused slot in a stable pointer table) */
138 STATICFUN(UnusedSP_entry)
139 {
140     FB_
141     (void) SAFESTGCALL1(I_,(void *, FILE *),fflush,stdout);
142     (void) SAFESTGCALL2(I_,(void *, FILE *, char *),fprintf,stderr, "Entered an unused Stable Pointer---this shouldn't happen!\n(This could be program error (using stable pointer after freeing) or compiler bug.)\n");
143
144     (void) STGCALL1(void,(void *, StgStablePtr), raiseError, errorHandler);
145     FE_
146 }
147
148 STATIC_ITBL(UnusedSP_info,UnusedSP_entry,UpdErr,0,INFO_OTHER_TAG,0,0,const,IF_,CON_K,"UNUSED_STABLE_PTR","USP");
149
150 SET_STATIC_HDR(UnusedSP_closure,UnusedSP_info,CC_SUBSUMED,,ED_RO_)
151 };
152
153 /* Entry point and Info table for Stable Pointer Table. */
154
155 STATICFUN(EmptyStablePointerTable_entry)
156 {
157     FB_
158     /* Don't wrap the calls; we're done with STG land */
159     fflush(stdout);
160     fprintf(stderr, "Entered *empty* stable pointer table---this shouldn't happen!\n");
161     abort();
162     FE_
163 }
164
165 STATICFUN(StablePointerTable_entry)
166 {
167     FB_
168     /* Don't wrap the calls; we're done with STG land */
169     fflush(stdout);
170     fprintf(stderr, "Entered the stable pointer table---this shouldn't happen!\n");
171     abort();
172     FE_
173 }
174
175 STATIC_ITBL(EmptyStablePointerTable_info,EmptyStablePointerTable_entry,UpdErr,0,INFO_OTHER_TAG,0,0,const,IF_,SPT_K,"SP_TABLE","SP_TABLE");
176 /* ToDo: could put a useful tag in there!!! */
177
178 DYN_ITBL(StablePointerTable_info,StablePointerTable_entry,UpdErr,0,INFO_OTHER_TAG,0,0,const,IF_,SPT_K,"SP_TABLE","SP_TABLE");
179 /* ToDo: could put a useful tag in there!!! */
180
181
182 /* To ease initialisation of the heap, we start with an empty stable
183    pointer table.  When we try to create the first stable pointer, the
184    overflow will trigger creation of a table of useful size.
185 */
186
187 SET_STATIC_HDR(EmptySPTable_closure,EmptyStablePointerTable_info,CC_SUBSUMED,,ED_RO_)
188 , (W_) DYN_VHS + 0 + 1 + 0  /* size = DYN_VHS + n + 1 + n with n = 0 */
189 , (W_) 0   /* number of ptrs */
190 , (W_) 0   /* top of stack */
191 };
192
193 /* End of SP stuff */
194 #endif /* !PAR */
195
196 /* Not a natural home for these, but
197    the following symbols may be referenced in
198    an object file, but never entered
199 */
200 P_ PrelGHC_void_closure = (P_) 0xbadbadbaL;
201 P_ PrelGHC_ZcCCallable_static_info = (P_) 0xbadbadbaL;
202 P_ PrelGHC_ZcCReturnable_static_info = (P_) 0xbadbadbaL;
203
204 /* the IoWorld token to start the whole thing off */
205 /* Question: this is just an amusing hex code isn't it
206    -- or does it mean something? ADR */
207 P_ realWorldZh_closure = (P_) 0xbadbadbaL;
208
209 #ifndef CONCURRENT
210
211 STGFUN(startStgWorld)
212 {
213     FB_
214     /* At this point we are in the threaded-code world.
215
216        TopClosure points to a closure of type PrimIO (), which should be
217        performed (by applying it to the state of the world).
218
219        The smInfo storage-management info block is assumed to be
220        up to date, and is used to load the STG registers.
221     */
222
223     RestoreAllStgRegs();    /* inline! */
224
225     /* ------- STG registers are now valid! -------------------------*/
226
227     /* Put a suitable return address on the B stack */
228     RetReg = (StgRetAddr) UNVEC(stopThreadDirectReturn,vtbl_stopStgWorld); 
229
230     /* Put an IoWorld token on the A stack */
231     SpB -= BREL(1);
232     *SpB = (P_) realWorldZh_closure;
233
234     Node = (P_) TopClosure; /* Point to the closure for main/errorIO-arg */
235     ENT_VIA_NODE();
236     InfoPtr=(D_)(INFO_PTR(Node));
237     JMP_(ENTRY_CODE(InfoPtr));
238     FE_
239 }
240 #endif  /* ! CONCURRENT */
241
242 \end{code}
243
244 %************************************************************************
245 %*                                                                      *
246 \subsection[thread-return]{Polymorphic end-of-thread code}
247 %*                                                                      *
248 %************************************************************************
249
250 \begin{code}
251
252 /* 
253    Here's the polymorphic return for the end of a thread.
254
255    NB: For direct returns to work properly, the name of the routine must be
256    the same as the name of the vector table with vtbl_ removed and DirectReturn
257    appended.  This is all the mangler understands.
258 */
259
260 const W_
261 vtbl_stopThread[] = {
262   /* at least "MAX_VECTORED_RTN" elements (see GhcConstants.lh) */
263   (W_) stopThreadDirectReturn,
264   (W_) stopThreadDirectReturn,
265   (W_) stopThreadDirectReturn,
266   (W_) stopThreadDirectReturn,
267   (W_) stopThreadDirectReturn,
268   (W_) stopThreadDirectReturn,
269   (W_) stopThreadDirectReturn,
270   (W_) stopThreadDirectReturn
271 };
272
273 STGFUN(stopThreadDirectReturn)
274 {
275     FB_
276     /* The final exit.
277
278        The top-top-level closures (e.g., "main") are of type "IO ()".
279        When entered, they perform an IO action and return a () --
280        essentially, TagReg is set to 1.  Here, we don't need to do
281        anything with that.
282
283        We just tidy up the register stuff (real regs in *_SAVE, then 
284        *_SAVE -> smInfo locs).
285     */
286
287 #ifdef CONCURRENT
288     SET_TASK_ACTIVITY(ST_OVERHEAD);
289 #endif
290
291     SaveAllStgRegs();   /* inline! */
292
293 #ifdef CONCURRENT
294     EndThread();
295 #else
296     RESUME_(miniInterpretEnd);
297 #endif
298     FE_
299 }
300
301 \end{code}  
302
303 \begin{code}
304 I_ ErrorIO_call_count = 0;
305
306 #ifdef CONCURRENT
307 EXTFUN(EnterNodeCode);
308
309 STGFUN(ErrorIO_innards)
310     /* Assumes that "TopClosure" has been set already */
311 {
312     FB_
313     if (ErrorIO_call_count >= 16 /* MAGIC CONSTANT */ ) {
314         /* Don't wrap the calls; we're done with STG land */
315         fflush(stdout);
316         fprintf(stderr, "too many nested calls to `error'\n");
317         EXIT(EXIT_FAILURE);
318     }
319     ErrorIO_call_count++; /* NB: undo later if decide to let someone else handle it */
320
321     /* Unlock all global closures held by this thread! (ToDo) --JSM */
322
323     switch(TSO_TYPE(CurrentTSO)) {
324     case T_MAIN:
325         /* Re-initialize stack pointers (cf. NewThread) */
326 #ifdef PAR
327         SpB = SuB = STKO_BSTK_BOT(StkOReg) + BREL(1);
328         SuA = STKO_ASTK_BOT(StkOReg) + AREL(1);
329 #else
330         SuA = stackInfo.botA + AREL(1);
331         SuB = stackInfo.botB + BREL(1);
332         /* HWL */
333         /* 
334         SpB = SuB = STKO_BSTK_BOT(StkOReg) + BREL(1);
335         SuA = STKO_ASTK_BOT(StkOReg) + AREL(1);
336         */
337    
338 #endif
339         break;
340
341     case T_REQUIRED:
342         /* Re-initialize stack pointers (cf. NewThread) */
343         SpB = SuB = STKO_BSTK_BOT(StkOReg) + BREL(1);
344         SuA = STKO_ASTK_BOT(StkOReg) + AREL(1);
345         break;
346
347     case T_ADVISORY:
348         ErrorIO_call_count--; /* undo the damage, as someone else will deal with it */
349         /* Let the main thread eventually handle it */
350         JMP_(stopThreadDirectReturn);
351
352     case T_FAIL:
353         EXIT(EXIT_FAILURE);
354
355     default:
356         /* Don't wrap the calls; we're done with STG land */
357         fflush(stdout);
358         fprintf(stderr,"ErrorIO: %lx unknown\n", TSO_TYPE(CurrentTSO));
359         EXIT(EXIT_FAILURE);
360     }
361
362     /* Finish stack setup as if for a top-level task and enter the error node */
363
364     /* Put an IoWorld token on the B stack */
365     SpB -= BREL(1);
366     *SpB = (P_) realWorldZh_closure;
367 /*
368     SpA = SuA - AREL(1);
369     *SpA = (P_) realWorldZh_closure;
370 */
371     STKO_LINK(StkOReg) = PrelBase_Z91Z93_closure;
372     STKO_RETURN(StkOReg) = NULL;
373
374 #ifdef TICKY_TICKY
375     STKO_ADEP(StkOReg) = STKO_BDEP(StkOReg) = 0;
376 #endif
377
378     /* Go! */
379     Node = (P_) TopClosure;
380     RetReg = (StgRetAddr) UNVEC(stopThreadDirectReturn,vtbl_stopStgWorld);
381     JMP_(EnterNodeCode);
382
383     FE_
384 }
385 \end{code}
386
387 We cannot afford to call @error@ too many times
388 (e.g., \tr{error x where x = error x}), so we keep count.
389
390 \begin{code}
391 #else   /* !CONCURRENT */
392
393 StgFunPtr
394 ErrorIO_innards(STG_NO_ARGS)
395     /* Assumes that "TopClosure" has been set already */
396 {
397     FB_
398     if (ErrorIO_call_count >= 16 /* MAGIC CONSTANT */ ) {
399         /* Don't wrap the calls; we're done with STG land */
400         fflush(stdout);
401         fprintf(stderr, "too many nested calls to `error'\n");
402         EXIT(EXIT_FAILURE);
403     }
404     ErrorIO_call_count++;
405
406     /* Copy the heap-related registers into smInfo.  (Other registers get
407        saved in this process, but we aren't interested in them.)
408
409        Get a new stack (which re-initialises the smInfo stack stuff),
410        and start the world again.
411     */
412     /* ToDo: chk this has been handled in parallel world */
413
414     SaveAllStgRegs();   /* inline! */
415
416     if (! initStacks( &StorageMgrInfo )) {
417         /* Don't wrap the calls; we're done with STG land */
418         fflush(stdout);
419         fprintf(stderr, "initStacks failed!\n");
420         EXIT(EXIT_FAILURE);
421     }
422
423     JMP_( startStgWorld );
424     FE_
425 }
426
427 #endif  /* !CONCURRENT */
428 \end{code}  
429
430 \begin{code}
431 #if defined(PAR) || defined(GRAN) 
432
433 STATICFUN(RBH_Save_0_entry)
434 {
435   FB_
436   fprintf(stderr,"Oops, entered an RBH save\n");
437   EXIT(EXIT_FAILURE);
438   FE_
439 }
440
441 STATICFUN(RBH_Save_1_entry)
442 {
443   FB_
444   fprintf(stderr,"Oops, entered an RBH save\n");
445   EXIT(EXIT_FAILURE);
446   FE_
447 }
448
449 STATICFUN(RBH_Save_2_entry)
450 {
451   FB_
452   fprintf(stderr,"Oops, entered an RBH save\n");
453   EXIT(EXIT_FAILURE);
454   FE_
455 }
456
457 SPEC_N_ITBL(RBH_Save_0_info,RBH_Save_0_entry,UpdErr,0,INFO_OTHER_TAG,2,0,,IF_,INTERNAL_KIND,"RBH-SAVE","RBH_Save_0");
458 SPEC_N_ITBL(RBH_Save_1_info,RBH_Save_1_entry,UpdErr,0,INFO_OTHER_TAG,2,1,,IF_,INTERNAL_KIND,"RBH-SAVE","RBH_Save_1");
459 SPEC_N_ITBL(RBH_Save_2_info,RBH_Save_2_entry,UpdErr,0,INFO_OTHER_TAG,2,2,,IF_,INTERNAL_KIND,"RBH-SAVE","RBH_Save_2");
460
461 #endif /* PAR || GRAN */
462 \end{code}
463
464
465 %/****************************************************************
466 %*                                                              *
467 %*              Other Bits and Pieces                           *
468 %*                                                              *
469 %****************************************************************/
470
471 \begin{code}
472 /* If we don't need the slow entry code for a closure, we put in a
473    pointer to this in the closure's slow entry code pointer instead.
474  */
475
476 STGFUN(__std_entry_error__) {
477     FB_
478     /* Don't wrap the calls; we're done with STG land */
479     fflush(stdout);
480     fprintf(stderr, "Called non-existent slow-entry code!!!\n");
481     abort();
482     JMP_(0);
483     FE_
484 }
485
486 /* entry code */
487 STGFUN(STK_STUB_entry) {
488     FB_
489     /* Don't wrap the calls; we're done with STG land */
490     fflush(stdout);
491     fprintf(stderr, "Entered from a stubbed stack slot!\n");
492     abort();
493     JMP_(0);
494     FE_
495 }
496
497 /* info table */
498 STATIC_ITBL(STK_STUB_info,STK_STUB_entry,UpdErr,0,INFO_OTHER_TAG,0,0,const,EF_,INTERNAL_KIND,"STK_STUB","STK_STUB");
499
500 /* closure */
501 SET_STATIC_HDR(STK_STUB_closure,STK_STUB_info,CC_SUBSUMED,,EXTDATA_RO)
502   , (W_)0, (W_)0
503 };
504 \end{code}
505
506 %/****************************************************************
507 %*                                                              *
508 %*              Some GC info tables                           *
509 %*                                                              *
510 %****************************************************************/
511
512 These have to be in a .lhc file, so they will be reversed correctly.
513
514 \begin{code}
515 #include "../storage/SMinternal.h"
516
517 #if defined(_INFO_COPYING)
518
519 STGFUN(Caf_Evac_Upd_entry) {
520     FB_
521     /* Don't wrap the calls; we're done with STG land */
522     fflush(stdout);
523     fprintf(stderr,"Entered Caf_Evac_Upd %lx: Should never occur!\n", (W_) Node);
524     abort();
525     FE_
526 }
527
528 CAF_EVAC_UPD_ITBL(Caf_Evac_Upd_info,Caf_Evac_Upd_entry,const/*not static*/);
529
530 #if defined(GCgn)
531
532 STGFUN(Forward_Ref_New_entry) {
533     FB_
534     /* Don't wrap the calls; we're done with STG land */
535     fflush(stdout);
536     fprintf(stderr,"Entered Forward_Ref_New %lx: Should never occur!\n", (W_) Node);
537     EXIT(EXIT_FAILURE); /* abort(); */
538     FE_
539 }
540 FORWARDREF_ITBL(Forward_Ref_New_info,Forward_Ref_New_entry,const/*not static*/,_Evacuate_Old_Forward_Ref);
541
542 STGFUN(Forward_Ref_Old_entry) {
543     FB_
544     /* Don't wrap the calls; we're done with STG land */
545     fflush(stdout);
546     fprintf(stderr,"Entered Forward_Ref_Old %lx: Should never occur!\n", (W_) Node);
547     EXIT(EXIT_FAILURE); /*    abort(); */
548     FE_
549 }
550 FORWARDREF_ITBL(Forward_Ref_Old_info,Forward_Ref_Old_entry,const/*not static*/,_Evacuate_New_Forward_Ref);
551
552 STGFUN(OldRoot_Forward_Ref_entry) {
553     FB_
554     /* Don't wrap the calls; we're done with STG land */
555     fflush(stdout);
556     fprintf(stderr,"Entered OldRoot_Forward_Ref %lx: Should never occur!\n", (W_) Node);
557     EXIT(EXIT_FAILURE); /*    abort(); */
558     FE_
559 }
560 FORWARDREF_ITBL(OldRoot_Forward_Ref_info,OldRoot_Forward_Ref_entry,const/*not static*/,_Evacuate_OldRoot_Forward);
561 #else /* ! GCgn */
562
563 STGFUN(Forward_Ref_entry) {
564     FB_
565     /* Don't wrap the calls; we're done with STG land */
566     fflush(stdout);
567     fprintf(stderr,"Entered Forward_Ref %lx: Should never occur!\n", (W_) Node);
568     EXIT(EXIT_FAILURE); /*    abort(); */
569     FE_
570 }
571 FORWARDREF_ITBL(Forward_Ref_info,Forward_Ref_entry,const/*not static*/,_Evacuate_Forward_Ref);
572 #endif /* ! GCgn */
573
574 #endif /* _INFO_COPYING */
575
576 #if defined(GCgn)
577 OLDROOT_ITBL(OldRoot_info,Ind_Entry,const,EF_);
578 #endif /* GCgn */
579 \end{code}
580
581
582 %/***************************************************************
583 %*                                                              *
584 %*              Cost Centre stuff ...                           *
585 %*                                                              *
586 %****************************************************************/
587
588 For cost centres we need prelude cost centres and register routine.
589
590 N.B. ALL prelude cost centres should be declared here as none will
591      be declared when the prelude is compiled.
592
593 ToDo: Explicit cost centres in prelude for Input and Output costs.
594
595 \begin{code}
596 #if defined(PROFILING)
597
598 STGFUN(startCcRegisteringWorld)
599 {
600     FB_
601     /* 
602      * We used to push miniInterpretEnd on the register stack, but
603      * miniInterpretEnd must only be entered with the RESUME_ macro,
604      * whereas the other addresses on the register stack must only be
605      * entered with the JMP_ macro.  Now, we push NULL and test for 
606      * it explicitly at each pop.
607      */
608     PUSH_REGISTER_STACK(NULL);
609     JMP_(_regMain);
610     FE_
611 }
612
613 CC_DECLARE(CC_CAFs,  "CAFs_in_...",  "PRELUDE", "PRELUDE", CC_IS_CAF,/*not static*/);
614 CC_DECLARE(CC_DICTs, "DICTs_in_...", "PRELUDE", "PRELUDE", CC_IS_DICT,/*not static*/);
615
616 START_REGISTER_PRELUDE(_regPrel);
617 REGISTER_CC(CC_CAFs);
618 REGISTER_CC(CC_DICTs);
619 END_REGISTER_CCS()
620
621 \end{code}
622
623 We also need cost centre declarations and registering routines for other
624 built-in prelude-like modules.
625
626 ToDo: What built-in prelude-like modules exist ?
627
628 \begin{code}
629 START_REGISTER_PRELUDE(_regByteOps);    /* used in Glasgow tests only? */
630 END_REGISTER_CCS()
631
632 /* _regPrelude is above */
633
634 START_REGISTER_PRELUDE(_regPrelGHC);
635 END_REGISTER_CCS()
636
637 #endif
638 \end{code}