From 53d50b9c155b7deb44267100aa58497b0eedde9f Mon Sep 17 00:00:00 2001 From: sewardj Date: Thu, 14 Dec 2000 15:19:48 +0000 Subject: [PATCH] [project @ 2000-12-14 15:19:47 by sewardj] Add info tables to do compiled->interpreted returns and vice versa. Rename various stuff from ...Hugs... to ...Interp... --- ghc/includes/StgMiscClosures.h | 20 +-- ghc/includes/TSO.h | 4 +- ghc/rts/Evaluator.h | 4 +- ghc/rts/HeapStackCheck.h | 4 +- ghc/rts/HeapStackCheck.hc | 10 +- ghc/rts/Interpreter.c | 30 ++-- ghc/rts/Linker.c | 4 +- ghc/rts/Schedule.c | 17 +-- ghc/rts/StgMiscClosures.hc | 331 +++++++++------------------------------- 9 files changed, 124 insertions(+), 300 deletions(-) diff --git a/ghc/includes/StgMiscClosures.h b/ghc/includes/StgMiscClosures.h index 5e87573..b049288 100644 --- a/ghc/includes/StgMiscClosures.h +++ b/ghc/includes/StgMiscClosures.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: StgMiscClosures.h,v 1.23 2000/12/04 12:31:20 simonmar Exp $ + * $Id: StgMiscClosures.h,v 1.24 2000/12/14 15:19:47 sewardj Exp $ * * (c) The GHC Team, 1998-1999 * @@ -55,15 +55,15 @@ STGFUN(stg_dummy_ret_entry); #ifdef GHCI /* entry code for constructors created by the metacircular interpreter */ -STGFUN(stg_mci_constr_entry); -STGFUN(stg_mci_constr1_entry); -STGFUN(stg_mci_constr2_entry); -STGFUN(stg_mci_constr3_entry); -STGFUN(stg_mci_constr4_entry); -STGFUN(stg_mci_constr5_entry); -STGFUN(stg_mci_constr6_entry); -STGFUN(stg_mci_constr7_entry); -STGFUN(stg_mci_constr8_entry); +STGFUN(stg_bco_constr_entry); +STGFUN(stg_bco_constr1_entry); +STGFUN(stg_bco_constr2_entry); +STGFUN(stg_bco_constr3_entry); +STGFUN(stg_bco_constr4_entry); +STGFUN(stg_bco_constr5_entry); +STGFUN(stg_bco_constr6_entry); +STGFUN(stg_bco_constr7_entry); +STGFUN(stg_bco_constr8_entry); #endif #if defined(PAR) || defined(GRAN) diff --git a/ghc/includes/TSO.h b/ghc/includes/TSO.h index 509e55f..1f7aa8e 100644 --- a/ghc/includes/TSO.h +++ b/ghc/includes/TSO.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: TSO.h,v 1.18 2000/08/25 13:12:07 simonmar Exp $ + * $Id: TSO.h,v 1.19 2000/12/14 15:19:47 sewardj Exp $ * * (c) The GHC Team, 1998-1999 * @@ -80,7 +80,7 @@ typedef enum { typedef enum { ThreadEnterGHC, /* enter top thunk on stack */ ThreadRunGHC, /* return to address on top of stack */ - ThreadEnterHugs, /* enter top thunk on stack (w/ interpreter) */ + ThreadEnterInterp, /* enter top thunk on stack (w/ interpreter) */ ThreadKilled, /* thread has died, don't run it */ ThreadRelocated, /* thread has moved, link points to new locn */ ThreadComplete /* thread has finished */ diff --git a/ghc/rts/Evaluator.h b/ghc/rts/Evaluator.h index 8c3e9a9..84a44b8 100644 --- a/ghc/rts/Evaluator.h +++ b/ghc/rts/Evaluator.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: Evaluator.h,v 1.8 2000/10/09 11:21:18 daan Exp $ + * $Id: Evaluator.h,v 1.9 2000/12/14 15:19:47 sewardj Exp $ * * (c) The GHC Team, 1998-1999 * @@ -26,7 +26,7 @@ * * ------------------------------------------------------------------------*/ -extern StgThreadReturnCode enter ( Capability* cap, StgClosurePtr obj ); +extern StgThreadReturnCode interpretBCO ( Capability* cap ); extern nat marshall ( char arg_ty, void* arg ); extern nat unmarshall ( char res_ty, void* res ); diff --git a/ghc/rts/HeapStackCheck.h b/ghc/rts/HeapStackCheck.h index 939b425..72a8ce0 100644 --- a/ghc/rts/HeapStackCheck.h +++ b/ghc/rts/HeapStackCheck.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: HeapStackCheck.h,v 1.5 1999/11/09 15:57:42 simonmar Exp $ + * $Id: HeapStackCheck.h,v 1.6 2000/12/14 15:19:47 sewardj Exp $ * * (c) The GHC Team, 1998-1999 * @@ -46,7 +46,7 @@ EXTFUN(stg_gen_chk); EXTFUN(stg_gen_hp); EXTFUN(stg_gen_yield); EXTFUN(stg_yield_noregs); -EXTFUN(stg_yield_to_Hugs); +EXTFUN(stg_yield_to_interpreter); EXTFUN(stg_gen_block); EXTFUN(stg_block_noregs); EXTFUN(stg_block_1); diff --git a/ghc/rts/HeapStackCheck.hc b/ghc/rts/HeapStackCheck.hc index 23de4fe..36c6090 100644 --- a/ghc/rts/HeapStackCheck.hc +++ b/ghc/rts/HeapStackCheck.hc @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: HeapStackCheck.hc,v 1.14 2000/03/31 03:09:36 hwloidl Exp $ + * $Id: HeapStackCheck.hc,v 1.15 2000/12/14 15:19:48 sewardj Exp $ * * (c) The GHC Team, 1998-1999 * @@ -105,9 +105,9 @@ R1.i = ThreadYielding; \ JMP_(StgReturn); -#define YIELD_TO_HUGS \ +#define YIELD_TO_INTERPRETER \ SaveThreadState(); \ - CurrentTSO->what_next = ThreadEnterHugs; \ + CurrentTSO->what_next = ThreadEnterInterp; \ R1.i = ThreadYielding; \ JMP_(StgReturn); @@ -1177,11 +1177,11 @@ FN_(stg_yield_noregs) FE_ } -FN_(stg_yield_to_Hugs) +FN_(stg_yield_to_interpreter) { FB_ /* No need to save everything - no live registers */ - YIELD_TO_HUGS + YIELD_TO_INTERPRETER FE_ } diff --git a/ghc/rts/Interpreter.c b/ghc/rts/Interpreter.c index 7ee75ba..eb6fd24 100644 --- a/ghc/rts/Interpreter.c +++ b/ghc/rts/Interpreter.c @@ -1,3 +1,5 @@ + + #if 0 /* ----------------------------------------------------------------------------- * Bytecode evaluator @@ -5,8 +7,8 @@ * Copyright (c) 1994-2000. * * $RCSfile: Interpreter.c,v $ - * $Revision: 1.2 $ - * $Date: 2000/12/11 17:59:01 $ + * $Revision: 1.3 $ + * $Date: 2000/12/14 15:19:48 $ * ---------------------------------------------------------------------------*/ #include "Rts.h" @@ -20,7 +22,6 @@ #include "SchedAPI.h" /* for createGenThread */ #include "Schedule.h" /* for context_switch */ #include "Bytecodes.h" -#include "Assembler.h" /* for CFun stuff */ #include "ForeignCall.h" #include "PrimOps.h" /* for __{encode,decode}{Float,Double} */ #include "Prelude.h" @@ -44,6 +45,13 @@ #endif /* 0 */ +#include +int /*StgThreadReturnCode*/ interpretBCO ( void* /* Capability* */ cap ) +{ + fprintf(stderr, "Greetings, earthlings. I am not yet implemented. Bye!\n"); + exit(1); +} + #if 0 /* -------------------------------------------------------------------------- * The new bytecode interpreter @@ -56,7 +64,7 @@ #define BCO_PTR(n) bco_ptrs[n] -StgThreadReturnCode enter ( Capability* cap ) +StgThreadReturnCode interpretBCO ( Capability* cap ) { /* On entry, the closure to interpret is on the top of the stack. */ @@ -156,23 +164,23 @@ StgThreadReturnCode enter ( Capability* cap ) case bci_PUSH_AS: { int o_bco = BCO_NEXT; int o_itbl = BCO_NEXT; - StackWord(-1) = BCO_LITW(o_itbl); + StackWord(-1) = BCO_LIT(o_itbl); StackWord(-2) = BCO_PTR(o_bco); Sp -= 2; goto nextInsn; } - case bci_PUSH_LIT:{ - int o = BCO_NEXT; - StackWord(-1) = BCO_LIT(o); - Sp --; - goto nextInsn; - } case bci_PUSH_TAG: { W_ tag = (W_)(BCO_NEXT); StackWord(-1) = tag; Sp --; goto nextInsn; } + case bci_PUSH_LIT:{ + int o = BCO_NEXT; + StackWord(-1) = BCO_LIT(o); + Sp --; + goto nextInsn; + } case bci_SLIDE: { int n = BCO_NEXT; int by = BCO_NEXT; diff --git a/ghc/rts/Linker.c b/ghc/rts/Linker.c index de9897f..ad35ae8 100644 --- a/ghc/rts/Linker.c +++ b/ghc/rts/Linker.c @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: Linker.c,v 1.4 2000/12/14 10:36:49 sewardj Exp $ + * $Id: Linker.c,v 1.5 2000/12/14 15:19:48 sewardj Exp $ * * (c) The GHC Team, 2000 * @@ -192,7 +192,7 @@ static int ocResolve_PEi386 ( ObjectCode* oc ); SymX(stable_ptr_table) \ SymX(shutdownHaskellAndExit) \ Sym(stg_enterStackTop) \ - Sym(stg_yield_to_Hugs) \ + Sym(stg_yield_to_interpreter) \ Sym(StgReturn) \ Sym(init_stack) \ SymX(blockAsyncExceptionszh_fast) \ diff --git a/ghc/rts/Schedule.c b/ghc/rts/Schedule.c index f0c6019..732d339 100644 --- a/ghc/rts/Schedule.c +++ b/ghc/rts/Schedule.c @@ -1,5 +1,5 @@ /* --------------------------------------------------------------------------- - * $Id: Schedule.c,v 1.83 2000/12/04 12:31:21 simonmar Exp $ + * $Id: Schedule.c,v 1.84 2000/12/14 15:19:48 sewardj Exp $ * * (c) The GHC Team, 1998-2000 * @@ -267,7 +267,7 @@ rtsTime TimeOfLastYield; char *whatNext_strs[] = { "ThreadEnterGHC", "ThreadRunGHC", - "ThreadEnterHugs", + "ThreadEnterInterp", "ThreadKilled", "ThreadComplete" }; @@ -886,14 +886,11 @@ schedule( void ) case ThreadRunGHC: ret = StgRun((StgFunPtr) stg_returnToStackTop, cap); break; - case ThreadEnterHugs: -#ifdef INTERPRETER + case ThreadEnterInterp: +#ifdef GHCI { - StgClosure* c; - IF_DEBUG(scheduler,sched_belch("entering Hugs")); - c = (StgClosure *)(cap->rCurrentTSO->sp[0]); - cap->rCurrentTSO->sp += 1; - ret = enter(cap,c); + IF_DEBUG(scheduler,sched_belch("entering interpreter")); + ret = interpretBCO(cap); break; } #else @@ -986,7 +983,7 @@ schedule( void ) * GC is finished. */ IF_DEBUG(scheduler, - if (t->what_next == ThreadEnterHugs) { + if (t->what_next == ThreadEnterInterp) { /* ToDo: or maybe a timer expired when we were in Hugs? * or maybe someone hit ctrl-C */ diff --git a/ghc/rts/StgMiscClosures.hc b/ghc/rts/StgMiscClosures.hc index c49536c..8fcdfde 100644 --- a/ghc/rts/StgMiscClosures.hc +++ b/ghc/rts/StgMiscClosures.hc @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: StgMiscClosures.hc,v 1.53 2000/12/11 12:37:00 simonmar Exp $ + * $Id: StgMiscClosures.hc,v 1.54 2000/12/14 15:19:48 sewardj Exp $ * * (c) The GHC Team, 1998-2000 * @@ -48,235 +48,102 @@ STGFUN(stg_##type##_entry) \ /* ----------------------------------------------------------------------------- - Support for the metacircular interpreter. + Support for the bytecode interpreter. -------------------------------------------------------------------------- */ #ifdef GHCI /* 9 bits of return code for constructors created by mci_make_constr. */ -FN_(stg_mci_constr_entry) +FN_(stg_bco_constr_entry) { /* R1 points at the constructor */ FB_ - STGCALL2(fprintf,stderr,"mci_constr_entry (direct return)!\n"); + STGCALL2(fprintf,stderr,"stg_bco_constr_entry (direct return)!\n"); /* Pointless, since SET_TAG doesn't do anything */ SET_TAG( GET_TAG(GET_INFO(R1.cl))); JMP_(ENTRY_CODE((P_)(*Sp))); FE_ } -FN_(stg_mci_constr1_entry) { FB_ JMP_(RET_VEC((P_)(*Sp),0)); FE_ } -FN_(stg_mci_constr2_entry) { FB_ JMP_(RET_VEC((P_)(*Sp),1)); FE_ } -FN_(stg_mci_constr3_entry) { FB_ JMP_(RET_VEC((P_)(*Sp),2)); FE_ } -FN_(stg_mci_constr4_entry) { FB_ JMP_(RET_VEC((P_)(*Sp),3)); FE_ } -FN_(stg_mci_constr5_entry) { FB_ JMP_(RET_VEC((P_)(*Sp),4)); FE_ } -FN_(stg_mci_constr6_entry) { FB_ JMP_(RET_VEC((P_)(*Sp),5)); FE_ } -FN_(stg_mci_constr7_entry) { FB_ JMP_(RET_VEC((P_)(*Sp),6)); FE_ } -FN_(stg_mci_constr8_entry) { FB_ JMP_(RET_VEC((P_)(*Sp),7)); FE_ } +FN_(stg_bco_constr1_entry) { FB_ JMP_(RET_VEC((P_)(*Sp),0)); FE_ } +FN_(stg_bco_constr2_entry) { FB_ JMP_(RET_VEC((P_)(*Sp),1)); FE_ } +FN_(stg_bco_constr3_entry) { FB_ JMP_(RET_VEC((P_)(*Sp),2)); FE_ } +FN_(stg_bco_constr4_entry) { FB_ JMP_(RET_VEC((P_)(*Sp),3)); FE_ } +FN_(stg_bco_constr5_entry) { FB_ JMP_(RET_VEC((P_)(*Sp),4)); FE_ } +FN_(stg_bco_constr6_entry) { FB_ JMP_(RET_VEC((P_)(*Sp),5)); FE_ } +FN_(stg_bco_constr7_entry) { FB_ JMP_(RET_VEC((P_)(*Sp),6)); FE_ } +FN_(stg_bco_constr8_entry) { FB_ JMP_(RET_VEC((P_)(*Sp),7)); FE_ } +/* 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. -/* Since this stuff is ostensibly in some other module, we need - to supply an __init_ function. -*/ -EXTFUN(__init_MCIzumakezuconstr); -START_MOD_INIT(__init_MCIzumakezuconstr) -END_MOD_INIT() - - -INFO_TABLE(mci_make_constr_info, mci_make_constr_entry, 0,0,FUN_STATIC,static,EF_,0,0); -INFO_TABLE(mci_make_constr0_info, mci_make_constr0_entry, 0,0,FUN_STATIC,static,EF_,0,0); -INFO_TABLE(mci_make_constrI_info, mci_make_constrI_entry, 0,0,FUN_STATIC,static,EF_,0,0); -INFO_TABLE(mci_make_constrP_info, mci_make_constrP_entry, 0,0,FUN_STATIC,static,EF_,0,0); -INFO_TABLE(mci_make_constrPP_info, mci_make_constrPP_entry, 0,0,FUN_STATIC,static,EF_,0,0); -INFO_TABLE(mci_make_constrPPP_info,mci_make_constrPPP_entry,0,0,FUN_STATIC,static,EF_,0,0); - -SET_STATIC_HDR(MCIzumakezuconstr_mcizumakezuconstr_closure, - mci_make_constr_info,0,,EI_) - ,{ /* payload */ } -}; -SET_STATIC_HDR(MCIzumakezuconstr_mcizumakezuconstr0_closure, - mci_make_constr0_info,0,,EI_) - ,{ /* payload */ } -}; -SET_STATIC_HDR(MCIzumakezuconstr_mcizumakezuconstrI_closure, - mci_make_constrI_info,0,,EI_) - ,{ /* payload */ } -}; -SET_STATIC_HDR(MCIzumakezuconstr_mcizumakezuconstrP_closure, - mci_make_constrP_info,0,,EI_) - ,{ /* payload */ } -}; -SET_STATIC_HDR(MCIzumakezuconstr_mcizumakezuconstrPP_closure, - mci_make_constrPP_info,0,,EI_) - ,{ /* payload */ } -}; -SET_STATIC_HDR(MCIzumakezuconstr_mcizumakezuconstrPPP_closure, - mci_make_constrPPP_info,0,,EI_) - ,{ /* payload */ } -}; - + On entry, the stack (growing down) looks like this: -/* Make a constructor with no args. */ -STGFUN(mci_make_constr0_entry) -{ - nat size, np, nw; - StgClosure* con; - StgInfoTable* itbl; - FB_ - /* Sp[0 & 1] are tag, Addr# - */ - itbl = ((StgInfoTable**)Sp)[1]; - np = INFO_PTR_TO_STRUCT(itbl)->layout.payload.ptrs; - nw = INFO_PTR_TO_STRUCT(itbl)->layout.payload.nptrs; - size = sizeofW(StgHeader) + stg_max(MIN_NONUPD_SIZE, np+nw); - /* STGCALL5(fprintf,stderr,"np %d nw %d size %d\n",np,nw,size); */ - - /* The total number of words to copy off the stack is np + nw. - That doesn't include tag words, tho. - */ - HP_CHK_GEN_TICKY(size, NO_PTRS, mci_make_constr_entry, ); - TICK_ALLOC_PRIM(sizeofW(StgHeader), size-sizeofW(StgHeader), 0); - CCS_ALLOC(CCCS,size); /* ccs prof */ - - con = (StgClosure*)(Hp + 1 - size); - SET_HDR(con, itbl,CCCS); - - Sp = Sp +2; /* Zap the Addr# arg */ - R1.cl = con; - - JMP_(ENTRY_CODE(GET_INFO(R1.cl))); - FE_ -} - -/* Make a constructor with 1 Int# arg */ -STGFUN(mci_make_constrI_entry) -{ - nat size, np, nw; - StgClosure* con; - StgInfoTable* itbl; - FB_ - /* Sp[0 & 1] are tag, Addr# - Sp[2 & 3] are tag, Int# - */ - itbl = ((StgInfoTable**)Sp)[1]; - np = INFO_PTR_TO_STRUCT(itbl)->layout.payload.ptrs; - nw = INFO_PTR_TO_STRUCT(itbl)->layout.payload.nptrs; - size = sizeofW(StgHeader) + stg_max(MIN_NONUPD_SIZE, np+nw); - /* STGCALL5(fprintf,stderr,"np %d nw %d size %d\n",np,nw,size); */ - - /* The total number of words to copy off the stack is np + nw. - That doesn't include tag words, tho. - */ - HP_CHK_GEN_TICKY(size, NO_PTRS, mci_make_constrI_entry, ); - TICK_ALLOC_PRIM(sizeofW(StgHeader), size-sizeofW(StgHeader), 0); - CCS_ALLOC(CCCS,size); /* ccs prof */ - - con = (StgClosure*)(Hp + 1 - size); - SET_HDR(con, itbl,CCCS); - - con->payload[0] = ((StgClosure**)Sp)[3]; - Sp = Sp +1/*word*/ +1/*tag*/; /* Zap the Int# arg */ - Sp = Sp +2; /* Zap the Addr# arg */ - R1.cl = con; - - JMP_(ENTRY_CODE(GET_INFO(R1.cl))); - FE_ -} - -STGFUN(mci_make_constrP_entry) -{ - FB_ - DUMP_ERRMSG("mci_make_constrP_entry: unimplemented!\n"); - STGCALL1(shutdownHaskellAndExit, EXIT_FAILURE); - return 0; - FE_ -} + 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. +*/ +/* When the returned value is in R1 ... */ +#define STG_BCORET_R1_Template(label) \ + 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_ \ + } -/* Make a constructor with 2 pointer args. */ -STGFUN(mci_make_constrPP_entry) -{ - nat size, np, nw; - StgClosure* con; - StgInfoTable* itbl; - FB_ - /* Sp[0 & 1] are tag, Addr# - Sp[2] first arg - Sp[3] second arg - */ - itbl = ((StgInfoTable**)Sp)[1]; - np = INFO_PTR_TO_STRUCT(itbl)->layout.payload.ptrs; - nw = INFO_PTR_TO_STRUCT(itbl)->layout.payload.nptrs; - size = sizeofW(StgHeader) + stg_max(MIN_NONUPD_SIZE, np+nw); - /* STGCALL5(fprintf,stderr,"np %d nw %d size %d\n",np,nw,size); */ - - /* The total number of words to copy off the stack is np + nw. - That doesn't include tag words, tho. - */ - HP_CHK_GEN_TICKY(size, NO_PTRS, mci_make_constrPP_entry, ); - TICK_ALLOC_PRIM(sizeofW(StgHeader), size-sizeofW(StgHeader), 0); - CCS_ALLOC(CCCS,size); /* ccs prof */ - - con = (StgClosure*)(Hp + 1 - size); - SET_HDR(con, itbl,CCCS); - - con->payload[0] = ((StgClosure**)Sp)[2]; - con->payload[1] = ((StgClosure**)Sp)[3]; - Sp = Sp +2; /* Zap 2 ptr args */ - Sp = Sp +2; /* Zap the Addr# arg */ - R1.cl = con; +STG_BCORET_R1_Template(stg_bcoret_R1_entry); +STG_BCORET_R1_Template(stg_bcoret_R1_0_entry); +STG_BCORET_R1_Template(stg_bcoret_R1_1_entry); +STG_BCORET_R1_Template(stg_bcoret_R1_2_entry); +STG_BCORET_R1_Template(stg_bcoret_R1_3_entry); +STG_BCORET_R1_Template(stg_bcoret_R1_4_entry); +STG_BCORET_R1_Template(stg_bcoret_R1_5_entry); +STG_BCORET_R1_Template(stg_bcoret_R1_6_entry); +STG_BCORET_R1_Template(stg_bcoret_R1_7_entry); - JMP_(GET_ENTRY(R1.cl)); - FE_ -} +VEC_POLY_INFO_TABLE(stg_bcoret_R1,0, NULL/*srt*/, 0/*srt_off*/, 0/*srt_len*/, RET_BCO,, EF_); -STGFUN(mci_make_constrPPP_entry) -{ - FB_ - DUMP_ERRMSG("mci_make_constrPPP_entry: unimplemented!\n"); - STGCALL1(shutdownHaskellAndExit, EXIT_FAILURE); - return 0; - FE_ -} - -/* It would be nice if this worked, but it doesn't. Yet. */ -STGFUN(mci_make_constr_entry) -{ - nat size, np, nw_heap, nw_really, i; - StgClosure* con; - StgInfoTable* itbl; +/* 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) { FB_ - /* Sp[0] should be the tag for the itbl */ - itbl = ((StgInfoTable**)Sp)[1]; - - np = INFO_PTR_TO_STRUCT(itbl)->layout.payload.ptrs; - nw_really = INFO_PTR_TO_STRUCT(itbl)->layout.payload.nptrs; - - nw_heap = stg_max((int)nw_really, MIN_NONUPD_SIZE-np); - size = CONSTR_sizeW( np, nw_heap ); - -#if 0 - fprintf(stderr, "np = %d, nw_really = %d, nw_heap = %d, size = %d\n", - np, nw_really, nw_heap, size); -#endif - - HP_CHK_GEN_TICKY(size, NO_PTRS, mci_make_constr_entry, ); - TICK_ALLOC_PRIM(sizeofW(StgHeader), size-sizeofW(StgHeader), 0); - CCS_ALLOC(CCCS,size); /* ccs prof */ - - con = (StgClosure*)(Hp + 1 - size); - SET_HDR(con, itbl,CCCS); - - /* set the pointer fields */ - for (i = 0; i < np; i++) { - con->payload[i] = &stg_dummy_ret_closure; - } - - Sp += 2; - - R1.cl = con; - JMP_(GET_ENTRY(R1.cl)); + Sp -= 1; + Sp[0] = R1.w; + JMP_(stg_yield_to_interpreter); FE_ } @@ -405,7 +272,7 @@ STGFUN(stg_CAF_UNENTERED_entry) /* ToDo: implement directly in GHC */ Sp -= 1; Sp[0] = R1.w; - JMP_(stg_yield_to_Hugs); + JMP_(stg_yield_to_interpreter); FE_ } @@ -656,18 +523,6 @@ STGFUN(stg_WHITEHOLE_entry) #endif /* ----------------------------------------------------------------------------- - The code for a BCO returns to the scheduler - -------------------------------------------------------------------------- */ -INFO_TABLE(stg_BCO_info,stg_BCO_entry,3,0,BCO,,EF_,"BCO","BCO"); -STGFUN(stg_BCO_entry) { - FB_ - Sp -= 1; - Sp[0] = R1.w; - JMP_(stg_yield_to_Hugs); - FE_ -} - -/* ----------------------------------------------------------------------------- Some static info tables for things that don't get entered, and therefore don't need entry code (i.e. boxed but unpointed objects) NON_ENTERABLE_ENTRY_CODE now defined at the beginning of the file @@ -910,42 +765,6 @@ SET_STATIC_HDR(stg_forceIO_closure,stg_forceIO_info,CCS_DONT_CARE,,EI_) /* ----------------------------------------------------------------------------- - Standard Infotables (for use in interpreter) - -------------------------------------------------------------------------- */ - -#ifdef INTERPRETER - -STGFUN(stg_Hugs_CONSTR_entry) -{ - /* R1 points at the constructor */ - JMP_(ENTRY_CODE(((StgPtr*)Sp)[0])); -} - -#define RET_BCO_ENTRY_TEMPLATE(label) \ - IFN_(label) \ - { \ - FB_ \ - Sp -= 1; \ - ((StgPtr*)Sp)[0] = R1.p; \ - JMP_(stg_yield_to_Hugs); \ - FE_ \ - } - -RET_BCO_ENTRY_TEMPLATE(stg_ret_bco_entry ); -RET_BCO_ENTRY_TEMPLATE(stg_ret_bco_0_entry); -RET_BCO_ENTRY_TEMPLATE(stg_ret_bco_1_entry); -RET_BCO_ENTRY_TEMPLATE(stg_ret_bco_2_entry); -RET_BCO_ENTRY_TEMPLATE(stg_ret_bco_3_entry); -RET_BCO_ENTRY_TEMPLATE(stg_ret_bco_4_entry); -RET_BCO_ENTRY_TEMPLATE(stg_ret_bco_5_entry); -RET_BCO_ENTRY_TEMPLATE(stg_ret_bco_6_entry); -RET_BCO_ENTRY_TEMPLATE(stg_ret_bco_7_entry); - -VEC_POLY_INFO_TABLE(stg_ret_bco,0, NULL/*srt*/, 0/*srt_off*/, 0/*srt_len*/, RET_BCO,, EF_); - -#endif /* INTERPRETER */ - -/* ----------------------------------------------------------------------------- CHARLIKE and INTLIKE closures. These are static representations of Chars and small Ints, so that -- 1.7.10.4