61d963bc0a6c34174eba390074113241e66b8462
[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
197 /* the IoWorld token to start the whole thing off */
198 /* Question: this is just an amusing hex code isn't it
199    -- or does it mean something? ADR */
200 P_ realWorldZh_closure = (P_) 0xbadbadbaL;
201 P_ GHC_void_closure = (P_) 0xbadbadbaL;
202
203 #ifndef CONCURRENT
204
205 STGFUN(startStgWorld)
206 {
207     FB_
208     /* At this point we are in the threaded-code world.
209
210        TopClosure points to a closure of type PrimIO (), which should be
211        performed (by applying it to the state of the world).
212
213        The smInfo storage-management info block is assumed to be
214        up to date, and is used to load the STG registers.
215     */
216
217     RestoreAllStgRegs();    /* inline! */
218
219     /* ------- STG registers are now valid! -------------------------*/
220
221     /* Put a suitable return address on the B stack */
222     RetReg = (StgRetAddr) UNVEC(stopThreadDirectReturn,vtbl_stopStgWorld); 
223
224     /* Put an IoWorld token on the A stack */
225     SpB -= BREL(1);
226     *SpB = (P_) realWorldZh_closure;
227
228     Node = (P_) TopClosure; /* Point to the closure for main/errorIO-arg */
229     ENT_VIA_NODE();
230     InfoPtr=(D_)(INFO_PTR(Node));
231     JMP_(ENTRY_CODE(InfoPtr));
232     FE_
233 }
234 #endif  /* ! CONCURRENT */
235
236 \end{code}
237
238 %************************************************************************
239 %*                                                                      *
240 \subsection[thread-return]{Polymorphic end-of-thread code}
241 %*                                                                      *
242 %************************************************************************
243
244 \begin{code}
245
246 /* 
247    Here's the polymorphic return for the end of a thread.
248
249    NB: For direct returns to work properly, the name of the routine must be
250    the same as the name of the vector table with vtbl_ removed and DirectReturn
251    appended.  This is all the mangler understands.
252 */
253
254 const W_
255 vtbl_stopThread[] = {
256   /* at least "MAX_VECTORED_RTN" elements (see GhcConstants.lh) */
257   (W_) stopThreadDirectReturn,
258   (W_) stopThreadDirectReturn,
259   (W_) stopThreadDirectReturn,
260   (W_) stopThreadDirectReturn,
261   (W_) stopThreadDirectReturn,
262   (W_) stopThreadDirectReturn,
263   (W_) stopThreadDirectReturn,
264   (W_) stopThreadDirectReturn
265 };
266
267 STGFUN(stopThreadDirectReturn)
268 {
269     FB_
270     /* The final exit.
271
272        The top-top-level closures (e.g., "main") are of type "IO ()".
273        When entered, they perform an IO action and return a () --
274        essentially, TagReg is set to 1.  Here, we don't need to do
275        anything with that.
276
277        We just tidy up the register stuff (real regs in *_SAVE, then 
278        *_SAVE -> smInfo locs).
279     */
280
281 #ifdef CONCURRENT
282     SET_TASK_ACTIVITY(ST_OVERHEAD);
283 #endif
284
285     SaveAllStgRegs();   /* inline! */
286
287 #ifdef CONCURRENT
288     EndThread();
289 #else
290     RESUME_(miniInterpretEnd);
291 #endif
292     FE_
293 }
294
295 \end{code}  
296
297 \begin{code}
298 I_ ErrorIO_call_count = 0;
299
300 #ifdef CONCURRENT
301 EXTFUN(EnterNodeCode);
302
303 STGFUN(ErrorIO_innards)
304     /* Assumes that "TopClosure" has been set already */
305 {
306     FB_
307     if (ErrorIO_call_count >= 16 /* MAGIC CONSTANT */ ) {
308         /* Don't wrap the calls; we're done with STG land */
309         fflush(stdout);
310         fprintf(stderr, "too many nested calls to `error'\n");
311         EXIT(EXIT_FAILURE);
312     }
313     ErrorIO_call_count++; /* NB: undo later if decide to let someone else handle it */
314
315     /* Unlock all global closures held by this thread! (ToDo) --JSM */
316
317     switch(TSO_TYPE(CurrentTSO)) {
318     case T_MAIN:
319         /* Re-initialize stack pointers (cf. NewThread) */
320 #ifdef PAR
321         SpB = SuB = STKO_BSTK_BOT(StkOReg) + BREL(1);
322         SuA = STKO_ASTK_BOT(StkOReg) + AREL(1);
323 #else
324         SuA = stackInfo.botA + AREL(1);
325         SuB = stackInfo.botB + BREL(1);
326         /* HWL */
327         /* 
328         SpB = SuB = STKO_BSTK_BOT(StkOReg) + BREL(1);
329         SuA = STKO_ASTK_BOT(StkOReg) + AREL(1);
330         */
331    
332 #endif
333         break;
334
335     case T_REQUIRED:
336         /* Re-initialize stack pointers (cf. NewThread) */
337         SpB = SuB = STKO_BSTK_BOT(StkOReg) + BREL(1);
338         SuA = STKO_ASTK_BOT(StkOReg) + AREL(1);
339         break;
340
341     case T_ADVISORY:
342         ErrorIO_call_count--; /* undo the damage, as someone else will deal with it */
343         /* Let the main thread eventually handle it */
344         JMP_(stopThreadDirectReturn);
345
346     case T_FAIL:
347         EXIT(EXIT_FAILURE);
348
349     default:
350         /* Don't wrap the calls; we're done with STG land */
351         fflush(stdout);
352         fprintf(stderr,"ErrorIO: %lx unknown\n", TSO_TYPE(CurrentTSO));
353         EXIT(EXIT_FAILURE);
354     }
355
356     /* Finish stack setup as if for a top-level task and enter the error node */
357
358     SpA = SuA - AREL(1);
359
360     *SpA = (P_) realWorldZh_closure;
361
362     STKO_LINK(StkOReg) = PrelBase_Z91Z93_closure;
363     STKO_RETURN(StkOReg) = NULL;
364
365 #ifdef TICKY_TICKY
366     STKO_ADEP(StkOReg) = STKO_BDEP(StkOReg) = 0;
367 #endif
368
369     /* Go! */
370     Node = (P_) TopClosure;
371     RetReg = (StgRetAddr) UNVEC(stopThreadDirectReturn,vtbl_stopStgWorld);
372     JMP_(EnterNodeCode);
373
374     FE_
375 }
376 \end{code}
377
378 We cannot afford to call @error@ too many times
379 (e.g., \tr{error x where x = error x}), so we keep count.
380
381 \begin{code}
382 #else   /* !CONCURRENT */
383
384 StgFunPtr
385 ErrorIO_innards(STG_NO_ARGS)
386     /* Assumes that "TopClosure" has been set already */
387 {
388     FB_
389     if (ErrorIO_call_count >= 16 /* MAGIC CONSTANT */ ) {
390         /* Don't wrap the calls; we're done with STG land */
391         fflush(stdout);
392         fprintf(stderr, "too many nested calls to `error'\n");
393         EXIT(EXIT_FAILURE);
394     }
395     ErrorIO_call_count++;
396
397     /* Copy the heap-related registers into smInfo.  (Other registers get
398        saved in this process, but we aren't interested in them.)
399
400        Get a new stack (which re-initialises the smInfo stack stuff),
401        and start the world again.
402     */
403     /* ToDo: chk this has been handled in parallel world */
404
405     SaveAllStgRegs();   /* inline! */
406
407     if (! initStacks( &StorageMgrInfo )) {
408         /* Don't wrap the calls; we're done with STG land */
409         fflush(stdout);
410         fprintf(stderr, "initStacks failed!\n");
411         EXIT(EXIT_FAILURE);
412     }
413
414     JMP_( startStgWorld );
415     FE_
416 }
417
418 #endif  /* !CONCURRENT */
419 \end{code}  
420
421 \begin{code}
422 #if defined(PAR) || defined(GRAN) 
423
424 STATICFUN(RBH_Save_0_entry)
425 {
426   FB_
427   fprintf(stderr,"Oops, entered an RBH save\n");
428   EXIT(EXIT_FAILURE);
429   FE_
430 }
431
432 STATICFUN(RBH_Save_1_entry)
433 {
434   FB_
435   fprintf(stderr,"Oops, entered an RBH save\n");
436   EXIT(EXIT_FAILURE);
437   FE_
438 }
439
440 STATICFUN(RBH_Save_2_entry)
441 {
442   FB_
443   fprintf(stderr,"Oops, entered an RBH save\n");
444   EXIT(EXIT_FAILURE);
445   FE_
446 }
447
448 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");
449 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");
450 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");
451
452 #endif /* PAR || GRAN */
453 \end{code}
454
455
456 %/****************************************************************
457 %*                                                              *
458 %*              Other Bits and Pieces                           *
459 %*                                                              *
460 %****************************************************************/
461
462 \begin{code}
463 /* If we don't need the slow entry code for a closure, we put in a
464    pointer to this in the closure's slow entry code pointer instead.
465  */
466
467 STGFUN(__std_entry_error__) {
468     FB_
469     /* Don't wrap the calls; we're done with STG land */
470     fflush(stdout);
471     fprintf(stderr, "Called non-existent slow-entry code!!!\n");
472     abort();
473     JMP_(0);
474     FE_
475 }
476
477 /* entry code */
478 STGFUN(STK_STUB_entry) {
479     FB_
480     /* Don't wrap the calls; we're done with STG land */
481     fflush(stdout);
482     fprintf(stderr, "Entered from a stubbed stack slot!\n");
483     abort();
484     JMP_(0);
485     FE_
486 }
487
488 /* info table */
489 STATIC_ITBL(STK_STUB_info,STK_STUB_entry,UpdErr,0,INFO_OTHER_TAG,0,0,const,EF_,INTERNAL_KIND,"STK_STUB","STK_STUB");
490
491 /* closure */
492 SET_STATIC_HDR(STK_STUB_closure,STK_STUB_info,CC_SUBSUMED,,EXTDATA_RO)
493   , (W_)0, (W_)0
494 };
495 \end{code}
496
497 %/****************************************************************
498 %*                                                              *
499 %*              Some GC info tables                           *
500 %*                                                              *
501 %****************************************************************/
502
503 These have to be in a .lhc file, so they will be reversed correctly.
504
505 \begin{code}
506 #include "../storage/SMinternal.h"
507
508 #if defined(_INFO_COPYING)
509
510 STGFUN(Caf_Evac_Upd_entry) {
511     FB_
512     /* Don't wrap the calls; we're done with STG land */
513     fflush(stdout);
514     fprintf(stderr,"Entered Caf_Evac_Upd %lx: Should never occur!\n", (W_) Node);
515     abort();
516     FE_
517 }
518
519 CAF_EVAC_UPD_ITBL(Caf_Evac_Upd_info,Caf_Evac_Upd_entry,const/*not static*/);
520
521 #if defined(GCgn)
522
523 STGFUN(Forward_Ref_New_entry) {
524     FB_
525     /* Don't wrap the calls; we're done with STG land */
526     fflush(stdout);
527     fprintf(stderr,"Entered Forward_Ref_New %lx: Should never occur!\n", (W_) Node);
528     EXIT(EXIT_FAILURE); /* abort(); */
529     FE_
530 }
531 FORWARDREF_ITBL(Forward_Ref_New_info,Forward_Ref_New_entry,const/*not static*/,_Evacuate_Old_Forward_Ref);
532
533 STGFUN(Forward_Ref_Old_entry) {
534     FB_
535     /* Don't wrap the calls; we're done with STG land */
536     fflush(stdout);
537     fprintf(stderr,"Entered Forward_Ref_Old %lx: Should never occur!\n", (W_) Node);
538     EXIT(EXIT_FAILURE); /*    abort(); */
539     FE_
540 }
541 FORWARDREF_ITBL(Forward_Ref_Old_info,Forward_Ref_Old_entry,const/*not static*/,_Evacuate_New_Forward_Ref);
542
543 STGFUN(OldRoot_Forward_Ref_entry) {
544     FB_
545     /* Don't wrap the calls; we're done with STG land */
546     fflush(stdout);
547     fprintf(stderr,"Entered OldRoot_Forward_Ref %lx: Should never occur!\n", (W_) Node);
548     EXIT(EXIT_FAILURE); /*    abort(); */
549     FE_
550 }
551 FORWARDREF_ITBL(OldRoot_Forward_Ref_info,OldRoot_Forward_Ref_entry,const/*not static*/,_Evacuate_OldRoot_Forward);
552 #else /* ! GCgn */
553
554 STGFUN(Forward_Ref_entry) {
555     FB_
556     /* Don't wrap the calls; we're done with STG land */
557     fflush(stdout);
558     fprintf(stderr,"Entered Forward_Ref %lx: Should never occur!\n", (W_) Node);
559     EXIT(EXIT_FAILURE); /*    abort(); */
560     FE_
561 }
562 FORWARDREF_ITBL(Forward_Ref_info,Forward_Ref_entry,const/*not static*/,_Evacuate_Forward_Ref);
563 #endif /* ! GCgn */
564
565 #endif /* _INFO_COPYING */
566
567 #if defined(GCgn)
568 OLDROOT_ITBL(OldRoot_info,Ind_Entry,const,EF_);
569 #endif /* GCgn */
570 \end{code}
571
572
573 %/***************************************************************
574 %*                                                              *
575 %*              Cost Centre stuff ...                           *
576 %*                                                              *
577 %****************************************************************/
578
579 For cost centres we need prelude cost centres and register routine.
580
581 N.B. ALL prelude cost centres should be declared here as none will
582      be declared when the prelude is compiled.
583
584 ToDo: Explicit cost centres in prelude for Input and Output costs.
585
586 \begin{code}
587 #if defined(PROFILING)
588
589 STGFUN(startCcRegisteringWorld)
590 {
591     FB_
592     /* 
593      * We used to push miniInterpretEnd on the register stack, but
594      * miniInterpretEnd must only be entered with the RESUME_ macro,
595      * whereas the other addresses on the register stack must only be
596      * entered with the JMP_ macro.  Now, we push NULL and test for 
597      * it explicitly at each pop.
598      */
599     PUSH_REGISTER_STACK(NULL);
600     JMP_(_regMain);
601     FE_
602 }
603
604 CC_DECLARE(CC_CAFs,  "CAFs_in_...",  "PRELUDE", "PRELUDE", CC_IS_CAF,/*not static*/);
605 CC_DECLARE(CC_DICTs, "DICTs_in_...", "PRELUDE", "PRELUDE", CC_IS_DICT,/*not static*/);
606
607 START_REGISTER_PRELUDE(_regPrel);
608 REGISTER_CC(CC_CAFs);
609 REGISTER_CC(CC_DICTs);
610 END_REGISTER_CCS()
611
612 \end{code}
613
614 We also need cost centre declarations and registering routines for other
615 built-in prelude-like modules.
616
617 ToDo: What built-in prelude-like modules exist ?
618
619 \begin{code}
620 START_REGISTER_PRELUDE(_regByteOps);    /* used in Glasgow tests only? */
621 END_REGISTER_CCS()
622
623 /* _regPrelude is above */
624
625 START_REGISTER_PRELUDE(_regGHCbase);
626 END_REGISTER_CCS()
627
628 /* OLD: START_REGISTER_PRELUDE(_regGHCerr); */
629 START_REGISTER_PRELUDE(_regGHC);
630 END_REGISTER_CCS()
631
632 START_REGISTER_PRELUDE(_regPreludeGlaST);
633 END_REGISTER_CCS()
634
635 #endif
636 \end{code}