* Copyright (c) 1994-1998.
*
* $RCSfile: Evaluator.c,v $
- * $Revision: 1.45 $
- * $Date: 2000/03/20 15:49:56 $
+ * $Revision: 1.53 $
+ * $Date: 2000/05/18 09:54:47 $
* ---------------------------------------------------------------------------*/
#include "Rts.h"
/* Make it possible for the evaluator to get hold of bytecode
for a given function by name. Useful but a hack. Sigh.
*/
-extern void* getHugs_AsmObject_for ( char* s );
-extern int /*Bool*/ combined;
+extern void* /* StgClosure* */ getHugs_BCO_cptr_for ( char* s );
+extern int /* Bool */ combined;
-/* --------------------------------------------------------------------------
- * Crude profiling stuff (mainly to assess effect of optimiser)
- * ------------------------------------------------------------------------*/
-
-#ifdef CRUDE_PROFILING
-
-#define M_CPTAB 10000
-#define CP_NIL (-1)
-
-int cpInUse = -1;
-int cpCurr;
-
-typedef
- struct { int /*StgVar*/ who;
- int /*StgVar*/ twho;
- int enters;
- int bytes;
- int insns;
- }
- CPRecord;
-
-CPRecord cpTab[M_CPTAB];
-
-void cp_init ( void )
-{
- int i;
- cpCurr = CP_NIL;
- cpInUse = 0;
- for (i = 0; i < M_CPTAB; i++)
- cpTab[i].who = CP_NIL;
-}
-
-
-
-void cp_enter ( StgBCO* b )
-{
- int is_ret_cont;
- int h;
- int /*StgVar*/ v = b->stgexpr;
- if ((void*)v == NULL) return;
-
- is_ret_cont = 0;
- if (v > 500000000) {
- is_ret_cont = 1;
- v -= 1000000000;
- }
-
- if (v < 0)
- h = (-v) % M_CPTAB; else
- h = v % M_CPTAB;
-
- assert (h >= 0 && h < M_CPTAB);
- while (cpTab[h].who != v && cpTab[h].who != CP_NIL) {
- h++; if (h == M_CPTAB) h = 0;
- };
- cpCurr = h;
- if (cpTab[cpCurr].who == CP_NIL) {
- cpTab[cpCurr].who = v;
- if (!is_ret_cont) cpTab[cpCurr].enters = 1;
- cpTab[cpCurr].bytes = cpTab[cpCurr].insns = 0;
- cpInUse++;
- if (cpInUse * 2 > M_CPTAB) {
- fprintf(stderr, "\nCRUDE_PROFILING hash table is too full\n" );
- assert(0);
- }
- } else {
- if (!is_ret_cont) cpTab[cpCurr].enters++;
- }
-
-
-}
-
-void cp_bill_words ( int nw )
-{
- if (cpCurr == CP_NIL) return;
- cpTab[cpCurr].bytes += sizeof(StgWord)*nw;
-}
-
-
-void cp_bill_insns ( int ni )
-{
- if (cpCurr == CP_NIL) return;
- cpTab[cpCurr].insns += ni;
-}
-
-
-static double percent ( double a, double b )
-{
- return (100.0 * a) / b;
-}
-
-
-void cp_show ( void )
-{
- int i, j, max, maxN, totE, totB, totI, cumE, cumB, cumI;
- char nm[200];
-
- if (cpInUse == -1) return;
-
- fflush(stdout);fflush(stderr);
- printf ( "\n\n" );
-
- totE = totB = totI = 0;
- for (i = 0; i < M_CPTAB; i++) {
- cpTab[i].twho = cpTab[i].who;
- if (cpTab[i].who != CP_NIL) {
- totE += cpTab[i].enters;
- totB += cpTab[i].bytes;
- totI += cpTab[i].insns;
- }
- }
-
- printf ( "Totals: "
- "%6d (%7.3f M) enters, "
- "%6d (%7.3f M) insns, "
- "%6d (%7.3f M) bytes\n\n",
- totE, totE/1000000.0, totI, totI/1000000.0, totB, totB/1000000.0 );
-
- cumE = cumB = cumI = 0;
- for (j = 0; j < 32; j++) {
-
- maxN = max = -1;
- for (i = 0; i < M_CPTAB; i++)
- if (cpTab[i].who != CP_NIL &&
- cpTab[i].enters > maxN) {
- maxN = cpTab[i].enters;
- max = i;
- }
- if (max == -1) break;
-
- cumE += cpTab[max].enters;
- cumB += cpTab[max].bytes;
- cumI += cpTab[max].insns;
-
- strcpy(nm, maybeName(cpTab[max].who));
- if (strcmp(nm, "(unknown)")==0)
- sprintf ( nm, "id%d", -cpTab[max].who);
-
- printf ( "%20s %7d es (%4.1f%%, %4.1f%% c) "
- "%7d bs (%4.1f%%, %4.1f%% c) "
- "%7d is (%4.1f%%, %4.1f%% c)\n",
- nm,
- cpTab[max].enters, percent(cpTab[max].enters,totE), percent(cumE,totE),
- cpTab[max].bytes, percent(cpTab[max].bytes,totB), percent(cumB,totB),
- cpTab[max].insns, percent(cpTab[max].insns,totI), percent(cumI,totI)
- );
-
- cpTab[max].twho = cpTab[max].who;
- cpTab[max].who = CP_NIL;
- }
-
- for (i = 0; i < M_CPTAB; i++)
- cpTab[i].who = cpTab[i].twho;
-
- printf ( "\n" );
-}
-
-#endif
/* --------------------------------------------------------------------------
{ \
StgUpdateFrame *__frame; \
__frame = (StgUpdateFrame *)(xSp + (xSp_offset)) - 1; \
- SET_INFO(__frame, (StgInfoTable *)&Upd_frame_info); \
+ SET_INFO(__frame, (StgInfoTable *)&upd_frame_info); \
__frame->link = xSu; \
__frame->updatee = (StgClosure *)(target); \
xSu = __frame; \
enterLoop:
+ numEnters++;
+
#ifdef DEBUG
assert(gSp == tSp);
assert(gSu == tSu);
cap->rCurrentTSO->why_blocked = BlockedOnDelay;
ACQUIRE_LOCK(&sched_mutex);
-#if defined(HAVE_SETITIMER)
+#if defined(HAVE_SETITIMER) || defined(mingw32_TARGET_OS)
cap->rCurrentTSO->block_info.delay
= hugsBlock.delay + ticks_since_select;
#else
RETURN(HeapOverflow);
}
-# if CRUDE_PROFILING
- cp_enter ( bco );
-# endif
-
-
bciPtr = &(bcoInstr(bco,0));
LoopTopLabel
LLL;
);
-# if CRUDE_PROFILING
- SSS; cp_bill_insns(1); LLL;
-# endif
-
Dispatch
Case(i_INTERNAL_ERROR):
xPopUpdateFrame(obj);
break;
case STOP_FRAME:
+ barf("STOP frame during pap update");
+#if 0
+ cap->rCurrentTSO->what_next = ThreadComplete;
SSS; PopStopFrame(obj); LLL;
RETURN(ThreadFinished);
+#endif
case SEQ_FRAME:
SSS; PopSeqFrame(); LLL;
ASSERT(xSp != (P_)xSu);
StgClosure* o;
SSS; o = (StgClosure*)grabHpNonUpd(Stablezh_sizeW); LLL;
SET_HDR(o,StablePtr_con_info,??);
- payloadWord(o,0) = xPopTaggedStable();
+ payloadWord(o,0) = (W_)xPopTaggedStable();
IF_DEBUG(evaluator,
fprintf(stderr,"\tBuilt ");
SSS;
xPushCPtr(obj); /* code to restart with */
RETURN(StackOverflow);
}
- /* ToDo: look for xSp==xSu && stackInt(0) == UPD_FRAME
- and insert an indirection immediately */
SSS; bh = (StgBlockingQueue*)grabHpUpd(BLACKHOLE_sizeW()); LLL;
SET_INFO(bh,&CAF_BLACKHOLE_info);
bh->blocking_queue = EndTSOQueue;
IF_DEBUG(gccafs,
- fprintf(stderr,"Created CAF_BLACKHOLE %p for CAF %p in evaluator\n",bh,caf));
+ fprintf(stderr,"Created CAF_BLACKHOLE %p for CAF %p"
+ " in evaluator\n",bh,caf));
SET_INFO(caf,&CAF_ENTERED_info);
caf->value = (StgClosure*)bh;
- if (caf->mut_link == NULL) {
- SSS; recordOldToNewPtrs((StgMutClosure*)caf); LLL;
- }
+
+ SSS; newCAF_made_by_Hugs(caf); LLL;
+
xPushUpdateFrame(bh,0);
xSp -= sizeofW(StgUpdateFrame);
- caf->link = enteredCAFs;
- enteredCAFs = caf;
obj = caf->body;
goto enterLoop;
}
+ cap->rCurrentTSO->stack_size,xSu);
LLL;
);
+ cap->rCurrentTSO->what_next = ThreadComplete;
SSS; PopStopFrame(obj); LLL;
+ xPushPtr((P_)obj);
RETURN(ThreadFinished);
}
case RET_BCO:
inline void PushTaggedDouble ( StgDouble x )
{ gSp -= sizeofW(StgDouble); ASSIGN_DBL(gSp,x); PushTag(DOUBLE_TAG); }
inline void PushTaggedStablePtr ( StgStablePtr x )
- { gSp -= sizeofW(StgStablePtr); *gSp = x; PushTag(STABLE_TAG); }
+ { gSp -= sizeofW(StgStablePtr); *gSp = (W_)x; PushTag(STABLE_TAG); }
static inline void PushTaggedBool ( int x )
{ PushTaggedInt(x); }
{ StgDouble r; PopTag(DOUBLE_TAG); r = PK_DBL(gSp);
gSp += sizeofW(StgDouble); return r;}
inline StgStablePtr PopTaggedStablePtr ( void )
- { StgInt r; PopTag(STABLE_TAG); r = *stgCast(StgStablePtr*, gSp);
+ { StgStablePtr r; PopTag(STABLE_TAG); r = *stgCast(StgStablePtr*, gSp);
gSp += sizeofW(StgStablePtr); return r;}
static inline StgPtr grabHpUpd( nat size )
{
ASSERT( size >= MIN_UPD_SIZE + sizeofW(StgHeader) );
-#ifdef CRUDE_PROFILING
- cp_bill_words ( size );
-#endif
return allocate(size);
}
static inline StgPtr grabHpNonUpd( nat size )
{
ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
-#ifdef CRUDE_PROFILING
- cp_bill_words ( size );
-#endif
return allocate(size);
}
* thunks which are currently under evaluation.
*/
HaskellObj primRaiseClosure
- = asmClosureOfObject(getHugs_AsmObject_for("primRaise"));
+ = getHugs_BCO_cptr_for("primRaise");
HaskellObj reraiseClosure
= rts_apply ( primRaiseClosure, exception );
(thinks: probably not so, but anyway ...)
*/
HaskellObj error
- = asmClosureOfObject(getHugs_AsmObject_for("error"));
+ = getHugs_BCO_cptr_for("error");
HaskellObj unpack
- = asmClosureOfObject(getHugs_AsmObject_for("hugsprimUnpackString"));
+ = getHugs_BCO_cptr_for("hugsprimUnpackString");
HaskellObj thunk
= rts_apply ( unpack, rts_mkAddr ( (void*)msg ) );
thunk
}
+__attribute__ ((unused))
static void myStackCheck ( Capability* cap )
{
/* fprintf(stderr, "myStackCheck\n"); */
case i_intToAddr: OP_I_A((StgAddr)x); break; /* ToDo */
case i_addrToInt: OP_A_I((StgInt)x); break; /* ToDo */
- case i_intToStable: OP_I_s(x); break;
- case i_stableToInt: OP_s_I(x); break;
+ case i_intToStable: OP_I_s((StgStablePtr)x); break;
+ case i_stableToInt: OP_s_I((W_)x); break;
case i_indexCharOffAddr: OP_AI_C(indexCharOffAddrzh(r,x,y)); break;
case i_readCharOffAddr: OP_AI_C(indexCharOffAddrzh(r,x,y)); break;
#endif
#ifdef PROVIDE_FOREIGN
/* ForeignObj# operations */
- case i_makeForeignObj:
+ case i_mkForeignObj:
{
StgForeignObj *result
= stgCast(StgForeignObj*,allocate(sizeofW(StgForeignObj)));
deleteThread(tso);
if (tso == cap->rCurrentTSO) { /* suicide */
*return2 = ThreadFinished;
- return (void*)(1+(NULL));
+ return (void*)(1+(char*)(NULL));
}
break;
}
}
#endif /* FLOATS_AS_DOUBLES */
-
#endif /* INTERPRETER */
projects / ghc-hetmet.git / blobdiff