1 %/****************************************************************
3 %* Basic Continuations required by the STG Machine runtime *
5 %****************************************************************/
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.
14 #define MAIN_REG_MAP /* STG world */
19 #include "Statistics.h"
23 /* ptr to the user's "main" closure (or "errorIO" arg closure),
24 to which we hope to be linked
28 EXTFUN(stopThreadDirectReturn);
29 UNVECTBL(,vtbl_stopStgWorld,stopThreadDirectReturn)
31 /* Well, we have to put the ArrayOfData and ArrayOfPtrs info tables
35 /* Array of data -- mutable */
36 STATICFUN(ArrayOfData_entry)
39 /* Don't wrap the calls; we're done with STG land */
41 fprintf(stderr, "Entered a primitive array (of data)---this shouldn't happen!\n");
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!!! */
49 /* Array of pointers -- mutable */
50 STATICFUN(ArrayOfPtrs_entry)
53 /* Don't wrap the calls; we're done with STG land */
55 fprintf(stderr, "Entered a primitive array (of pointers)---this shouldn't happen!\n");
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!!! */
63 STATICFUN(FullSVar_entry)
66 /* Don't wrap the calls; we're done with STG land */
68 fprintf(stderr, "Entered a full SVar---this shouldn't happen!\n");
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!!! */
76 STATICFUN(EmptySVar_entry)
79 /* Don't wrap the calls; we're done with STG land */
81 fprintf(stderr, "Entered an empty SVar---this shouldn't happen!\n");
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!!! */
89 /* Array of pointers -- immutable */
90 STATICFUN(ImMutArrayOfPtrs_entry)
93 /* Don't wrap the calls; we're done with STG land */
95 fprintf(stderr, "Entered a primitive array (immutable, pointers)---this shouldn't happen!\n");
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!!! */
103 /* (end of Array whatnot) */
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] */
109 #if !defined(PAR) /* && !defined(GRAN) */
111 /* Ditto for Foreign Object entry point and info tables. [ADR]
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?
117 STATICFUN(ForeignObj_entry)
120 /* Don't wrap the calls; we're done with STG land */
122 fprintf(stderr, "Compiler bug: Entered a ForeignObj---this shouldn't happen!\n");
127 ForeignObj_ITBL(ForeignObj_info,ForeignObj_entry,UpdErr,0,INFO_OTHER_TAG,,,const,EF_,ForeignObj_K,"FOREIGN_OBJ","ForeignObj");
129 /* End of ForeignObj stuff */
131 /* Ditto for the unused Stable Pointer info table. [ADR]
134 void raiseError PROTO((StgStablePtr));
135 extern StgStablePtr errorHandler; /* NB: prone to magic-value-ery (WDP 95/12) */
137 /* Unused Stable Pointer (ie unused slot in a stable pointer table) */
138 STATICFUN(UnusedSP_entry)
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");
144 (void) STGCALL1(void,(void *, StgStablePtr), raiseError, errorHandler);
148 STATIC_ITBL(UnusedSP_info,UnusedSP_entry,UpdErr,0,INFO_OTHER_TAG,0,0,const,IF_,CON_K,"UNUSED_STABLE_PTR","USP");
150 SET_STATIC_HDR(UnusedSP_closure,UnusedSP_info,CC_SUBSUMED,,ED_RO_)
153 /* Entry point and Info table for Stable Pointer Table. */
155 STATICFUN(EmptyStablePointerTable_entry)
158 /* Don't wrap the calls; we're done with STG land */
160 fprintf(stderr, "Entered *empty* stable pointer table---this shouldn't happen!\n");
165 STATICFUN(StablePointerTable_entry)
168 /* Don't wrap the calls; we're done with STG land */
170 fprintf(stderr, "Entered the stable pointer table---this shouldn't happen!\n");
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!!! */
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!!! */
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.
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 */
193 /* End of SP stuff */
196 /* Not a natural home for these, but
197 the following symbols may be referenced in
198 an object file, but never entered
200 P_ PrelGHC_void_closure = (P_) 0xbadbadbaL;
201 P_ PrelGHC_ZcCCallable_static_info = (P_) 0xbadbadbaL;
202 P_ PrelGHC_ZcCReturnable_static_info = (P_) 0xbadbadbaL;
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;
211 STGFUN(startStgWorld)
214 /* At this point we are in the threaded-code world.
216 TopClosure points to a closure of type PrimIO (), which should be
217 performed (by applying it to the state of the world).
219 The smInfo storage-management info block is assumed to be
220 up to date, and is used to load the STG registers.
223 RestoreAllStgRegs(); /* inline! */
225 /* ------- STG registers are now valid! -------------------------*/
227 /* Put a suitable return address on the B stack */
228 RetReg = (StgRetAddr) UNVEC(stopThreadDirectReturn,vtbl_stopStgWorld);
230 /* Put an IoWorld token on the A stack */
232 (P_)*SpB = (P_) realWorldZh_closure;
234 Node = (P_) TopClosure; /* Point to the closure for main/errorIO-arg */
236 InfoPtr=(D_)(INFO_PTR(Node));
237 JMP_(ENTRY_CODE(InfoPtr));
240 #endif /* ! CONCURRENT */
244 %************************************************************************
246 \subsection[thread-return]{Polymorphic end-of-thread code}
248 %************************************************************************
253 Here's the polymorphic return for the end of a thread.
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.
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
273 STGFUN(stopThreadDirectReturn)
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
283 We just tidy up the register stuff (real regs in *_SAVE, then
284 *_SAVE -> smInfo locs).
288 SET_TASK_ACTIVITY(ST_OVERHEAD);
291 SaveAllStgRegs(); /* inline! */
296 RESUME_(miniInterpretEnd);
304 I_ ErrorIO_call_count = 0;
307 EXTFUN(EnterNodeCode);
309 STGFUN(ErrorIO_innards)
310 /* Assumes that "TopClosure" has been set already */
315 if (ErrorIO_call_count >= 16 /* MAGIC CONSTANT */ ) {
316 /* Don't wrap the calls; we're done with STG land */
318 fprintf(stderr, "too many nested calls to `error'\n");
321 ErrorIO_call_count++; /* NB: undo later if decide to let someone else handle it */
323 /* Unlock all global closures held by this thread! (ToDo) --JSM */
325 switch(TSO_TYPE(CurrentTSO)) {
327 /* Re-initialize stack pointers (cf. NewThread) */
329 SpB = SuB = STKO_BSTK_BOT(StkOReg) + BREL(1);
330 SuA = STKO_ASTK_BOT(StkOReg) + AREL(1);
332 SuA = stackInfo.botA + AREL(1);
333 SuB = stackInfo.botB + BREL(1);
336 SpB = SuB = STKO_BSTK_BOT(StkOReg) + BREL(1);
337 SuA = STKO_ASTK_BOT(StkOReg) + AREL(1);
344 /* Re-initialize stack pointers (cf. NewThread) */
345 SpB = SuB = STKO_BSTK_BOT(StkOReg) + BREL(1);
346 SuA = STKO_ASTK_BOT(StkOReg) + AREL(1);
350 ErrorIO_call_count--; /* undo the damage, as someone else will deal with it */
351 /* Let the main thread eventually handle it */
352 JMP_(stopThreadDirectReturn);
358 /* Don't wrap the calls; we're done with STG land */
360 fprintf(stderr,"ErrorIO: %lx unknown\n", TSO_TYPE(CurrentTSO));
364 /* Finish stack setup as if for a top-level task and enter the error node */
366 /* Put an IoWorld token on the B stack */
368 *SpB = (P_) realWorldZh_closure;
371 *SpA = (P_) realWorldZh_closure;
373 STKO_LINK(StkOReg) = PrelBase_Z91Z93_closure;
374 STKO_RETURN(StkOReg) = NULL;
377 STKO_ADEP(StkOReg) = STKO_BDEP(StkOReg) = 0;
381 Node = (P_) TopClosure;
382 RetReg = (StgRetAddr) UNVEC(stopThreadDirectReturn,vtbl_stopStgWorld);
389 We cannot afford to call @error@ too many times
390 (e.g., \tr{error x where x = error x}), so we keep count.
393 #else /* !CONCURRENT */
396 ErrorIO_innards(STG_NO_ARGS)
397 /* Assumes that "TopClosure" has been set already */
402 if (ErrorIO_call_count >= 16 /* MAGIC CONSTANT */ ) {
403 /* Don't wrap the calls; we're done with STG land */
405 fprintf(stderr, "too many nested calls to `error'\n");
408 ErrorIO_call_count++;
410 /* Copy the heap-related registers into smInfo. (Other registers get
411 saved in this process, but we aren't interested in them.)
413 Get a new stack (which re-initialises the smInfo stack stuff),
414 and start the world again.
416 /* ToDo: chk this has been handled in parallel world */
418 SaveAllStgRegs(); /* inline! */
420 if (! initStacks( &StorageMgrInfo )) {
421 /* Don't wrap the calls; we're done with STG land */
423 fprintf(stderr, "initStacks failed!\n");
427 JMP_( startStgWorld );
431 #endif /* !CONCURRENT */
435 #if defined(PAR) || defined(GRAN)
437 STATICFUN(RBH_Save_0_entry)
440 fprintf(stderr,"Oops, entered an RBH save\n");
445 STATICFUN(RBH_Save_1_entry)
448 fprintf(stderr,"Oops, entered an RBH save\n");
453 STATICFUN(RBH_Save_2_entry)
456 fprintf(stderr,"Oops, entered an RBH save\n");
461 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");
462 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");
463 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");
465 #endif /* PAR || GRAN */
469 %/****************************************************************
471 %* Other Bits and Pieces *
473 %****************************************************************/
476 /* If we don't need the slow entry code for a closure, we put in a
477 pointer to this in the closure's slow entry code pointer instead.
480 STGFUN(__std_entry_error__) {
482 /* Don't wrap the calls; we're done with STG land */
484 fprintf(stderr, "Called non-existent slow-entry code!!!\n");
491 STGFUN(STK_STUB_entry) {
493 /* Don't wrap the calls; we're done with STG land */
495 fprintf(stderr, "Entered from a stubbed stack slot!\n");
502 STATIC_ITBL(STK_STUB_info,STK_STUB_entry,UpdErr,0,INFO_OTHER_TAG,0,0,const,EF_,INTERNAL_KIND,"STK_STUB","STK_STUB");
505 SET_STATIC_HDR(STK_STUB_closure,STK_STUB_info,CC_SUBSUMED,,EXTDATA_RO)
517 SpB[BREL(0)] = (W_) RetReg;
518 SpB[BREL(1)] = (W_) &&cont;
519 RetReg = (StgRetAddr) vtbl_seq;
521 InfoPtr = (D_)(INFO_PTR(Node));
522 JMP_(ENTRY_CODE(InfoPtr));
530 %/****************************************************************
532 %* Some GC info tables *
534 %****************************************************************/
536 These have to be in a .lhc file, so they will be reversed correctly.
539 #include "../storage/SMinternal.h"
541 #if defined(_INFO_COPYING)
543 STGFUN(Caf_Evac_Upd_entry) {
545 /* Don't wrap the calls; we're done with STG land */
547 fprintf(stderr,"Entered Caf_Evac_Upd %lx: Should never occur!\n", (W_) Node);
552 CAF_EVAC_UPD_ITBL(Caf_Evac_Upd_info,Caf_Evac_Upd_entry,const/*not static*/);
556 STGFUN(Forward_Ref_New_entry) {
558 /* Don't wrap the calls; we're done with STG land */
560 fprintf(stderr,"Entered Forward_Ref_New %lx: Should never occur!\n", (W_) Node);
561 EXIT(EXIT_FAILURE); /* abort(); */
564 FORWARDREF_ITBL(Forward_Ref_New_info,Forward_Ref_New_entry,const/*not static*/,_Evacuate_Old_Forward_Ref);
566 STGFUN(Forward_Ref_Old_entry) {
568 /* Don't wrap the calls; we're done with STG land */
570 fprintf(stderr,"Entered Forward_Ref_Old %lx: Should never occur!\n", (W_) Node);
571 EXIT(EXIT_FAILURE); /* abort(); */
574 FORWARDREF_ITBL(Forward_Ref_Old_info,Forward_Ref_Old_entry,const/*not static*/,_Evacuate_New_Forward_Ref);
576 STGFUN(OldRoot_Forward_Ref_entry) {
578 /* Don't wrap the calls; we're done with STG land */
580 fprintf(stderr,"Entered OldRoot_Forward_Ref %lx: Should never occur!\n", (W_) Node);
581 EXIT(EXIT_FAILURE); /* abort(); */
584 FORWARDREF_ITBL(OldRoot_Forward_Ref_info,OldRoot_Forward_Ref_entry,const/*not static*/,_Evacuate_OldRoot_Forward);
587 STGFUN(Forward_Ref_entry) {
589 /* Don't wrap the calls; we're done with STG land */
591 fprintf(stderr,"Entered Forward_Ref %lx: Should never occur!\n", (W_) Node);
592 EXIT(EXIT_FAILURE); /* abort(); */
595 FORWARDREF_ITBL(Forward_Ref_info,Forward_Ref_entry,const/*not static*/,_Evacuate_Forward_Ref);
598 #endif /* _INFO_COPYING */
601 OLDROOT_ITBL(OldRoot_info,Ind_Entry,const,EF_);
606 %/***************************************************************
608 %* Cost Centre stuff ... *
610 %****************************************************************/
612 For cost centres we need prelude cost centres and register routine.
614 N.B. ALL prelude cost centres should be declared here as none will
615 be declared when the prelude is compiled.
617 ToDo: Explicit cost centres in prelude for Input and Output costs.
620 #if defined(PROFILING)
622 STGFUN(startCcRegisteringWorld)
626 * We used to push miniInterpretEnd on the register stack, but
627 * miniInterpretEnd must only be entered with the RESUME_ macro,
628 * whereas the other addresses on the register stack must only be
629 * entered with the JMP_ macro. Now, we push NULL and test for
630 * it explicitly at each pop.
632 PUSH_REGISTER_STACK(NULL);
637 CC_DECLARE(CC_CAFs, "CAFs_in_...", "PRELUDE", "PRELUDE", CC_IS_CAF,/*not static*/);
638 CC_DECLARE(CC_DICTs, "DICTs_in_...", "PRELUDE", "PRELUDE", CC_IS_DICT,/*not static*/);
640 START_REGISTER_PRELUDE(_regPrel);
641 REGISTER_CC(CC_CAFs);
642 REGISTER_CC(CC_DICTs);
647 We also need cost centre declarations and registering routines for other
648 built-in prelude-like modules.
650 ToDo: What built-in prelude-like modules exist ?
653 START_REGISTER_PRELUDE(_regByteOps); /* used in Glasgow tests only? */
656 /* _regPrelude is above */
658 START_REGISTER_PRELUDE(_regPrelGHC);