2 /* -----------------------------------------------------------------------------
5 * Copyright (c) 1994-1998.
7 * $RCSfile: Evaluator.c,v $
9 * $Date: 2000/03/20 15:49:56 $
10 * ---------------------------------------------------------------------------*/
20 #include "SchedAPI.h" /* for createGenThread */
21 #include "Schedule.h" /* for context_switch */
22 #include "Bytecodes.h"
23 #include "Assembler.h" /* for CFun stuff */
24 #include "ForeignCall.h"
25 #include "PrimOps.h" /* for __{encode,decode}{Float,Double} */
28 #include "Evaluator.h"
29 #include "sainteger.h"
33 #include "Disassembler.h"
38 #include <math.h> /* These are for primops */
39 #include <limits.h> /* These are for primops */
40 #include <float.h> /* These are for primops */
42 #include <ieee754.h> /* These are for primops */
46 /* Allegedly useful macro, taken from ClosureMacros.h */
47 #define payloadWord( c, i ) (*stgCast(StgWord*, ((c)->payload+(i))))
48 #define payloadPtr( c, i ) (*stgCast(StgPtr*, ((c)->payload+(i))))
50 /* An incredibly useful abbreviation.
51 * Interestingly, there are some uses of END_TSO_QUEUE_closure that
52 * can't use it because they use the closure at type StgClosure* or
53 * even StgPtr*. I suspect they should be changed. -- ADR
55 #define EndTSOQueue stgCast(StgTSO*,(void*)&END_TSO_QUEUE_closure)
57 /* These macros are rather delicate - read a good ANSI C book carefully
61 #define mycat(x,y) x##y
62 #define mycat2(x,y) mycat(x,y)
63 #define mycat3(x,y,z) mycat2(x,mycat2(y,z))
65 #if defined(__GNUC__) && !defined(DEBUG)
66 #define USE_GCC_LABELS 1
68 #define USE_GCC_LABELS 0
71 /* Make it possible for the evaluator to get hold of bytecode
72 for a given function by name. Useful but a hack. Sigh.
74 extern void* getHugs_AsmObject_for ( char* s );
75 extern int /*Bool*/ combined;
77 /* --------------------------------------------------------------------------
78 * Crude profiling stuff (mainly to assess effect of optimiser)
79 * ------------------------------------------------------------------------*/
81 #ifdef CRUDE_PROFILING
90 struct { int /*StgVar*/ who;
98 CPRecord cpTab[M_CPTAB];
100 void cp_init ( void )
105 for (i = 0; i < M_CPTAB; i++)
106 cpTab[i].who = CP_NIL;
111 void cp_enter ( StgBCO* b )
115 int /*StgVar*/ v = b->stgexpr;
116 if ((void*)v == NULL) return;
125 h = (-v) % M_CPTAB; else
128 assert (h >= 0 && h < M_CPTAB);
129 while (cpTab[h].who != v && cpTab[h].who != CP_NIL) {
130 h++; if (h == M_CPTAB) h = 0;
133 if (cpTab[cpCurr].who == CP_NIL) {
134 cpTab[cpCurr].who = v;
135 if (!is_ret_cont) cpTab[cpCurr].enters = 1;
136 cpTab[cpCurr].bytes = cpTab[cpCurr].insns = 0;
138 if (cpInUse * 2 > M_CPTAB) {
139 fprintf(stderr, "\nCRUDE_PROFILING hash table is too full\n" );
143 if (!is_ret_cont) cpTab[cpCurr].enters++;
149 void cp_bill_words ( int nw )
151 if (cpCurr == CP_NIL) return;
152 cpTab[cpCurr].bytes += sizeof(StgWord)*nw;
156 void cp_bill_insns ( int ni )
158 if (cpCurr == CP_NIL) return;
159 cpTab[cpCurr].insns += ni;
163 static double percent ( double a, double b )
165 return (100.0 * a) / b;
169 void cp_show ( void )
171 int i, j, max, maxN, totE, totB, totI, cumE, cumB, cumI;
174 if (cpInUse == -1) return;
176 fflush(stdout);fflush(stderr);
179 totE = totB = totI = 0;
180 for (i = 0; i < M_CPTAB; i++) {
181 cpTab[i].twho = cpTab[i].who;
182 if (cpTab[i].who != CP_NIL) {
183 totE += cpTab[i].enters;
184 totB += cpTab[i].bytes;
185 totI += cpTab[i].insns;
190 "%6d (%7.3f M) enters, "
191 "%6d (%7.3f M) insns, "
192 "%6d (%7.3f M) bytes\n\n",
193 totE, totE/1000000.0, totI, totI/1000000.0, totB, totB/1000000.0 );
195 cumE = cumB = cumI = 0;
196 for (j = 0; j < 32; j++) {
199 for (i = 0; i < M_CPTAB; i++)
200 if (cpTab[i].who != CP_NIL &&
201 cpTab[i].enters > maxN) {
202 maxN = cpTab[i].enters;
205 if (max == -1) break;
207 cumE += cpTab[max].enters;
208 cumB += cpTab[max].bytes;
209 cumI += cpTab[max].insns;
211 strcpy(nm, maybeName(cpTab[max].who));
212 if (strcmp(nm, "(unknown)")==0)
213 sprintf ( nm, "id%d", -cpTab[max].who);
215 printf ( "%20s %7d es (%4.1f%%, %4.1f%% c) "
216 "%7d bs (%4.1f%%, %4.1f%% c) "
217 "%7d is (%4.1f%%, %4.1f%% c)\n",
219 cpTab[max].enters, percent(cpTab[max].enters,totE), percent(cumE,totE),
220 cpTab[max].bytes, percent(cpTab[max].bytes,totB), percent(cumB,totB),
221 cpTab[max].insns, percent(cpTab[max].insns,totI), percent(cumI,totI)
224 cpTab[max].twho = cpTab[max].who;
225 cpTab[max].who = CP_NIL;
228 for (i = 0; i < M_CPTAB; i++)
229 cpTab[i].who = cpTab[i].twho;
237 /* --------------------------------------------------------------------------
238 * Hugs Hooks - a bit of a hack
239 * ------------------------------------------------------------------------*/
241 void setRtsFlags( int x );
242 void setRtsFlags( int x )
244 unsigned int w = 0x12345678;
245 unsigned char* pw = (unsigned char *)&w;
248 *(int*)(&(RtsFlags.DebugFlags)) = x;
253 w2 |= (w1 && 0xFF); w2 <<= 8; w1 >>= 8;
254 w2 |= (w1 && 0xFF); w2 <<= 8; w1 >>= 8;
255 w2 |= (w1 && 0xFF); w2 <<= 8; w1 >>= 8;
256 w2 |= (w1 && 0xFF); w2 <<= 8; w1 >>= 8;
257 *(int*)(&(RtsFlags.DebugFlags)) = (int)w2;
263 StgTSOBlockReason reason;
268 /* --------------------------------------------------------------------------
269 * Entering-objects and bytecode interpreter part of evaluator
270 * ------------------------------------------------------------------------*/
272 /* The primop (and all other) parts of this evaluator operate upon the
273 machine state which lives in MainRegTable. enter is different:
274 to make its closure- and bytecode-interpreting loops go fast, some of that
275 state is pulled out into local vars (viz, registers, if we are lucky).
276 That means that we need to save(load) the local state at every exit(reentry)
277 into enter. That is, around every procedure call it makes. Blargh!
278 If you modify this code, __be warned__ it will fail in mysterious ways if
279 you fail to preserve this property.
281 Currently the pulled-out state is Sp in xSp, Su in xSu and SpLim in xSpLim.
282 The SSS macros saves the state back in MainRegTable, and LLL loads it from
283 MainRegTable. RETURN(v) does SSS and then returns v; all exits should
284 be via RETURN and not plain return.
286 Since xSp, xSu and xSpLim are local vars in enter, they are not visible
287 in procedures called from enter. To fix this, either (1) turn the
288 procedures into macros, so they get copied inline, or (2) bracket
289 the procedure call with SSS and LLL so that the local and global
290 machine states are synchronised for the duration of the call.
294 /* Forward decls ... */
295 static void* enterBCO_primop1 ( int );
296 static void* enterBCO_primop2 ( int , int* /*StgThreadReturnCode* */,
297 StgBCO**, Capability*, HugsBlock * );
298 static inline void PopUpdateFrame ( StgClosure* obj );
299 static inline void PopCatchFrame ( void );
300 static inline void PopSeqFrame ( void );
301 static inline void PopStopFrame( StgClosure* obj );
302 static inline void PushTaggedRealWorld( void );
303 /* static inline void PushTaggedInteger ( mpz_ptr ); */
304 static inline StgPtr grabHpUpd( nat size );
305 static inline StgPtr grabHpNonUpd( nat size );
306 static StgClosure* raiseAnError ( StgClosure* exception );
308 static int enterCountI = 0;
310 StgDouble B__encodeDouble (B* s, I_ e);
311 void B__decodeDouble (B* man, I_* exp, StgDouble dbl);
312 #if ! FLOATS_AS_DOUBLES
313 StgFloat B__encodeFloat (B* s, I_ e);
314 void B__decodeFloat (B* man, I_* exp, StgFloat flt);
315 StgPtr CreateByteArrayToHoldInteger ( int );
316 B* IntegerInsideByteArray ( StgPtr );
317 void SloppifyIntegerEnd ( StgPtr );
323 #define gSp MainRegTable.rSp
324 #define gSu MainRegTable.rSu
325 #define gSpLim MainRegTable.rSpLim
328 /* Macros to save/load local state. */
330 #define SSS { tSp=gSp = xSp; tSu=gSu = xSu; tSpLim=gSpLim = xSpLim; }
331 #define LLL { tSp=xSp = gSp; tSu=xSu = gSu; tSpLim=xSpLim = gSpLim; }
333 #define SSS { gSp = xSp; gSu = xSu; gSpLim = xSpLim; }
334 #define LLL { xSp = gSp; xSu = gSu; xSpLim = gSpLim; }
337 #define RETURN(vvv) { \
338 StgThreadReturnCode retVal=(vvv); \
340 cap->rCurrentTSO->sp = gSp; \
341 cap->rCurrentTSO->su = gSu; \
342 cap->rCurrentTSO->splim = gSpLim; \
347 /* Macros to operate directly on the pulled-out machine state.
348 These mirror some of the small procedures used in the primop code
349 below, except you have to be careful about side effects,
350 ie xPushPtr(xStackPtr(n)) won't work! It certainly isn't the
351 same as PushPtr(StackPtr(n)). Also note that (1) some of
352 the macros, in particular xPopTagged*, do not make the tag
353 sanity checks that their non-x cousins do, and (2) some of
354 the macros depend critically on the semantics of C comma
355 expressions to work properly.
357 #define xPushPtr(ppp) { xSp--; *xSp=(StgWord)(ppp); }
358 #define xPopPtr() ((StgPtr)(*xSp++))
360 #define xPushCPtr(ppp) { xSp--; *xSp=(StgWord)(ppp); }
361 #define xPopCPtr() ((StgClosure*)(*xSp++))
363 #define xPushWord(ppp) { xSp--; *xSp=(StgWord)(ppp); }
364 #define xPopWord() ((StgWord)(*xSp++))
366 #define xStackPtr(nnn) ((StgPtr)(*(xSp+(nnn))))
367 #define xStackWord(nnn) ((StgWord)(*(xSp+(nnn))))
368 #define xSetStackWord(iii,www) xSp[iii]=(StgWord)(www)
370 #define xPushTag(ttt) { xSp--; *xSp=(StgWord)(ttt); }
371 #define xPopTag(ttt) { StackTag t = (StackTag)(*xSp++); \
374 #define xPushTaggedInt(xxx) { xSp -= sizeofW(StgInt); \
375 *xSp = (xxx); xPushTag(INT_TAG); }
376 #define xTaggedStackInt(iii) ((StgInt)(*(xSp+1+(iii))))
377 #define xPopTaggedInt() ((xSp++,xSp+=sizeofW(StgInt), \
378 (StgInt)(*(xSp-sizeofW(StgInt)))))
380 #define xPushTaggedWord(xxx) { xSp -= sizeofW(StgWord); \
381 *xSp = (xxx); xPushTag(WORD_TAG); }
382 #define xTaggedStackWord(iii) ((StgWord)(*(xSp+1+(iii))))
383 #define xPopTaggedWord() ((xSp++,xSp+=sizeofW(StgWord), \
384 (StgWord)(*(xSp-sizeofW(StgWord)))))
386 #define xPushTaggedAddr(xxx) { xSp -= sizeofW(StgAddr); \
387 *xSp = (StgWord)(xxx); xPushTag(ADDR_TAG); }
388 #define xTaggedStackAddr(iii) ((StgAddr)(*(xSp+1+(iii))))
389 #define xPopTaggedAddr() ((xSp++,xSp+=sizeofW(StgAddr), \
390 (StgAddr)(*(xSp-sizeofW(StgAddr)))))
392 #define xPushTaggedStable(xxx) { xSp -= sizeofW(StgStablePtr); \
393 *xSp = (StgWord)(xxx); xPushTag(STABLE_TAG); }
394 #define xTaggedStackStable(iii) ((StgStablePtr)(*(xSp+1+(iii))))
395 #define xPopTaggedStable() ((xSp++,xSp+=sizeofW(StgStablePtr), \
396 (StgStablePtr)(*(xSp-sizeofW(StgStablePtr)))))
398 #define xPushTaggedChar(xxx) { xSp -= sizeofW(StgChar); \
399 *xSp = (StgWord)(xxx); xPushTag(CHAR_TAG); }
400 #define xTaggedStackChar(iii) ((StgChar)(*(xSp+1+(iii))))
401 #define xPopTaggedChar() ((xSp++,xSp+=sizeofW(StgChar), \
402 (StgChar)(*(xSp-sizeofW(StgChar)))))
404 #define xPushTaggedFloat(xxx) { xSp -= sizeofW(StgFloat); \
405 ASSIGN_FLT(xSp,xxx); xPushTag(FLOAT_TAG); }
406 #define xTaggedStackFloat(iii) PK_FLT(xSp+1+(iii))
407 #define xPopTaggedFloat() ((xSp++,xSp+=sizeofW(StgFloat), \
408 PK_FLT(xSp-sizeofW(StgFloat))))
410 #define xPushTaggedDouble(xxx) { xSp -= sizeofW(StgDouble); \
411 ASSIGN_DBL(xSp,xxx); xPushTag(DOUBLE_TAG); }
412 #define xTaggedStackDouble(iii) PK_DBL(xSp+1+(iii))
413 #define xPopTaggedDouble() ((xSp++,xSp+=sizeofW(StgDouble), \
414 PK_DBL(xSp-sizeofW(StgDouble))))
417 #define xPushUpdateFrame(target, xSp_offset) \
419 StgUpdateFrame *__frame; \
420 __frame = (StgUpdateFrame *)(xSp + (xSp_offset)) - 1; \
421 SET_INFO(__frame, (StgInfoTable *)&Upd_frame_info); \
422 __frame->link = xSu; \
423 __frame->updatee = (StgClosure *)(target); \
427 #define xPopUpdateFrame(ooo) \
429 /* NB: doesn't assume that Sp == Su */ \
430 IF_DEBUG(evaluator, \
431 fprintf(stderr, "Updating "); \
432 printPtr(stgCast(StgPtr,xSu->updatee)); \
433 fprintf(stderr, " with "); \
435 fprintf(stderr,"xSp = %p\txSu = %p\n\n", xSp, xSu); \
437 UPD_IND(xSu->updatee,ooo); \
438 xSp = stgCast(StgStackPtr,xSu) + sizeofW(StgUpdateFrame); \
444 /* Instruction stream macros */
445 #define BCO_INSTR_8 *bciPtr++
446 #define BCO_INSTR_16 ((bciPtr += 2, (*(bciPtr-2) << 8) + *(bciPtr-1)))
447 #define PC (bciPtr - &(bcoInstr(bco,0)))
450 /* State on entry to enter():
451 * - current thread is in cap->rCurrentTSO;
452 * - allocation area is in cap->rCurrentNursery & cap->rNursery
455 StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 )
457 /* use of register here is primarily to make it clear to compilers
458 that these entities are non-aliasable.
460 register StgPtr xSp; /* local state -- stack pointer */
461 register StgUpdateFrame* xSu; /* local state -- frame pointer */
462 register StgPtr xSpLim; /* local state -- stack lim pointer */
463 register StgClosure* obj; /* object currently under evaluation */
464 char eCount; /* enter counter, for context switching */
467 HugsBlock hugsBlock = { NotBlocked, 0 };
471 StgPtr tSp; StgUpdateFrame* tSu; StgPtr tSpLim;
474 gSp = cap->rCurrentTSO->sp;
475 gSu = cap->rCurrentTSO->su;
476 gSpLim = cap->rCurrentTSO->splim;
479 /* use the t values to check that Su/Sp/SpLim do not change unexpectedly */
480 tSp = gSp; tSu = gSu; tSpLim = gSpLim;
486 /* Load the local state from global state, and Party On, Dudes! */
487 /* From here onwards, we operate with the local state and
488 save/reload it as necessary.
497 assert(gSpLim == tSpLim);
501 ASSERT(xSpLim <= xSp && xSp <= stgCast(StgPtr,xSu));
503 "\n---------------------------------------------------------------\n");
504 fprintf(stderr,"(%d) Entering: ",enterCountI); printObj(obj);
505 fprintf(stderr,"xSp = %p\txSu = %p\n", xSp, xSu);
506 fprintf(stderr, "\n" );
507 printStack(xSp,cap->rCurrentTSO->stack+cap->rCurrentTSO->stack_size,xSu);
508 fprintf(stderr, "\n\n");
515 ((++eCount) & 0x0F) == 0
520 if (context_switch) {
521 switch(hugsBlock.reason) {
523 xPushCPtr(obj); /* code to restart with */
524 RETURN(ThreadYielding);
526 case BlockedOnDelay: /* fall through */
527 case BlockedOnRead: /* fall through */
528 case BlockedOnWrite: {
529 ASSERT(cap->rCurrentTSO->why_blocked == NotBlocked);
530 cap->rCurrentTSO->why_blocked = BlockedOnDelay;
531 ACQUIRE_LOCK(&sched_mutex);
533 #if defined(HAVE_SETITIMER)
534 cap->rCurrentTSO->block_info.delay
535 = hugsBlock.delay + ticks_since_select;
537 cap->rCurrentTSO->block_info.target
538 = hugsBlock.delay + getourtimeofday();
540 APPEND_TO_BLOCKED_QUEUE(cap->rCurrentTSO);
542 RELEASE_LOCK(&sched_mutex);
544 xPushCPtr(obj); /* code to restart with */
545 RETURN(ThreadBlocked);
548 barf("Unknown context switch reasoning");
553 switch ( get_itbl(obj)->type ) {
555 barf("Invalid object %p",obj);
559 /* ---------------------------------------------------- */
560 /* Start of the bytecode evaluator */
561 /* ---------------------------------------------------- */
564 # define Ins(x) &&l##x
565 static void *labs[] = { INSTRLIST };
567 # define LoopTopLabel
568 # define Case(x) l##x
569 # define Continue goto *labs[BCO_INSTR_8]
570 # define Dispatch Continue;
573 # define LoopTopLabel insnloop:
574 # define Case(x) case x
575 # define Continue goto insnloop
576 # define Dispatch switch (BCO_INSTR_8) {
577 # define EndDispatch }
580 register StgWord8* bciPtr; /* instruction pointer */
581 register StgBCO* bco = (StgBCO*)obj;
584 /* Don't need to SSS ... LLL around doYouWantToGC */
585 wantToGC = doYouWantToGC();
587 xPushCPtr((StgClosure*)bco); /* code to restart with */
588 RETURN(HeapOverflow);
596 bciPtr = &(bcoInstr(bco,0));
600 ASSERT((StgWord)(PC) < bco->n_instrs);
602 fprintf(stderr,"Sp = %p\tSu = %p\tpc = %d\t", xSp, xSu, PC);
606 fprintf(stderr,"\n");
607 for (i = 8; i >= 0; i--)
608 fprintf(stderr, "%d %p\n", i, (StgPtr)(*(gSp+i)));
610 fprintf(stderr,"\n");
615 SSS; cp_bill_insns(1); LLL;
620 Case(i_INTERNAL_ERROR):
621 barf("INTERNAL_ERROR at %p:%d",bco,PC-1);
623 barf("PANIC at %p:%d",bco,PC-1);
627 if (xSp - n < xSpLim) {
628 xPushCPtr((StgClosure*)bco); /* code to restart with */
629 RETURN(StackOverflow);
633 Case(i_STK_CHECK_big):
635 int n = BCO_INSTR_16;
636 if (xSp - n < xSpLim) {
637 xPushCPtr((StgClosure*)bco); /* code to restart with */
638 RETURN(StackOverflow);
645 if ((StgPtr*)(xSp + n) > (StgPtr*)xSu) {
646 StgWord words = (P_)xSu - xSp;
648 /* first build a PAP */
649 ASSERT((P_)xSu >= xSp); /* was (words >= 0) but that's always true */
650 if (words == 0) { /* optimisation */
651 /* Skip building the PAP and update with an indirection. */
654 /* In the evaluator, we avoid the need to do
655 * a heap check here by including the size of
656 * the PAP in the heap check we performed
657 * when we entered the BCO.
661 SSS; pap = (StgPAP*)grabHpNonUpd(PAP_sizeW(words)); LLL;
662 SET_HDR(pap,&PAP_info,CC_pap);
665 for (i = 0; i < (I_)words; ++i) {
666 payloadWord(pap,i) = xSp[i];
669 obj = stgCast(StgClosure*,pap);
672 /* now deal with "update frame" */
673 /* as an optimisation, we process all on top of stack */
674 /* instead of just the top one */
675 ASSERT(xSp==(P_)xSu);
677 switch (get_itbl(xSu)->type) {
679 /* Hit a catch frame during an arg satisfaction check,
680 * so the thing returning (1) has not thrown an
681 * exception, and (2) is of functional type. Just
682 * zap the catch frame and carry on down the stack
683 * (looking for more arguments, basically).
685 SSS; PopCatchFrame(); LLL;
688 xPopUpdateFrame(obj);
691 SSS; PopStopFrame(obj); LLL;
692 RETURN(ThreadFinished);
694 SSS; PopSeqFrame(); LLL;
695 ASSERT(xSp != (P_)xSu);
696 /* Hit a SEQ frame during an arg satisfaction check.
697 * So now return to bco_info which is under the
698 * SEQ frame. The following code is copied from a
699 * case RET_BCO further down. (The reason why we're
700 * here is that something of functional type has
701 * been seq-d on, and we're now returning to the
702 * algebraic-case-continuation which forced the
703 * evaluation in the first place.)
715 barf("Invalid update frame during argcheck");
717 } while (xSp==(P_)xSu);
725 int words = BCO_INSTR_8;
726 SSS; p = grabHpUpd(AP_sizeW(words)); LLL;
730 Case(i_ALLOC_CONSTR):
733 StgInfoTable* info = bcoConstAddr(bco,BCO_INSTR_8);
734 SSS; p = grabHpNonUpd(sizeW_fromITBL(info)); LLL;
735 SET_HDR((StgClosure*)p,info,??);
739 Case(i_ALLOC_CONSTR_big):
742 int x = BCO_INSTR_16;
743 StgInfoTable* info = bcoConstAddr(bco,x);
744 SSS; p = grabHpNonUpd(sizeW_fromITBL(info)); LLL;
745 SET_HDR((StgClosure*)p,info,??);
751 int x = BCO_INSTR_8; /* ToDo: Word not Int! */
753 StgAP_UPD* o = stgCast(StgAP_UPD*,xStackPtr(x));
754 SET_HDR(o,&AP_UPD_info,??);
756 o->fun = stgCast(StgClosure*,xPopPtr());
757 for(x=0; x < y; ++x) {
758 payloadWord(o,x) = xPopWord();
761 fprintf(stderr,"\tBuilt ");
763 printObj(stgCast(StgClosure*,o));
774 o = stgCast(StgAP_UPD*,xStackPtr(x));
775 SET_HDR(o,&AP_UPD_info,??);
777 o->fun = stgCast(StgClosure*,xPopPtr());
778 for(x=0; x < y; ++x) {
779 payloadWord(o,x) = xPopWord();
782 fprintf(stderr,"\tBuilt ");
784 printObj(stgCast(StgClosure*,o));
793 StgPAP* o = stgCast(StgPAP*,xStackPtr(x));
794 SET_HDR(o,&PAP_info,??);
796 o->fun = stgCast(StgClosure*,xPopPtr());
797 for(x=0; x < y; ++x) {
798 payloadWord(o,x) = xPopWord();
801 fprintf(stderr,"\tBuilt ");
803 printObj(stgCast(StgClosure*,o));
810 int offset = BCO_INSTR_8;
811 StgClosure* o = stgCast(StgClosure*,xStackPtr(offset));
812 const StgInfoTable* info = get_itbl(o);
813 nat p = info->layout.payload.ptrs;
814 nat np = info->layout.payload.nptrs;
816 for(i=0; i < p; ++i) {
817 o->payload[i] = xPopCPtr();
819 for(i=0; i < np; ++i) {
820 payloadWord(o,p+i) = 0xdeadbeef;
823 fprintf(stderr,"\tBuilt ");
825 printObj(stgCast(StgClosure*,o));
832 int offset = BCO_INSTR_16;
833 StgClosure* o = stgCast(StgClosure*,xStackPtr(offset));
834 const StgInfoTable* info = get_itbl(o);
835 nat p = info->layout.payload.ptrs;
836 nat np = info->layout.payload.nptrs;
838 for(i=0; i < p; ++i) {
839 o->payload[i] = xPopCPtr();
841 for(i=0; i < np; ++i) {
842 payloadWord(o,p+i) = 0xdeadbeef;
845 fprintf(stderr,"\tBuilt ");
847 printObj(stgCast(StgClosure*,o));
856 ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
857 /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
859 xSetStackWord(x+y,xStackWord(x));
869 ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
870 /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
872 xSetStackWord(x+y,xStackWord(x));
884 xPushPtr(bcoConstPtr(bco,BCO_INSTR_8));
885 xPushPtr(stgCast(StgPtr,&ret_bco_info));
890 int tag = BCO_INSTR_8;
891 StgWord offset = BCO_INSTR_16;
892 if (constrTag( (StgClosure*)xStackPtr(0) ) != tag) {
899 StgClosure* o = stgCast(StgClosure*,xStackPtr(0));
900 const StgInfoTable* itbl = get_itbl(o);
901 int i = itbl->layout.payload.ptrs;
902 ASSERT( itbl->type == CONSTR
903 || itbl->type == CONSTR_STATIC
904 || itbl->type == CONSTR_NOCAF_STATIC
905 || itbl->type == CONSTR_1_0
906 || itbl->type == CONSTR_0_1
907 || itbl->type == CONSTR_2_0
908 || itbl->type == CONSTR_1_1
909 || itbl->type == CONSTR_0_2
912 xPushCPtr(o->payload[i]);
918 int n = BCO_INSTR_16;
919 StgPtr p = xStackPtr(n);
925 StgPtr p = xStackPtr(BCO_INSTR_8);
931 xPushPtr(stgCast(StgPtr,bcoConstPtr(bco,BCO_INSTR_8)));
936 int n = BCO_INSTR_16;
937 xPushPtr(stgCast(StgPtr,bcoConstPtr(bco,n)));
942 SSS; PushTaggedRealWorld(); LLL;
947 StgInt i = xTaggedStackInt(BCO_INSTR_8);
953 xPushTaggedInt(bcoConstInt(bco,BCO_INSTR_8));
956 Case(i_CONST_INT_big):
958 int n = BCO_INSTR_16;
959 xPushTaggedInt(bcoConstInt(bco,n));
965 SSS; o = (StgClosure*)grabHpNonUpd(Izh_sizeW); LLL;
966 SET_HDR(o,Izh_con_info,??);
967 payloadWord(o,0) = xPopTaggedInt();
969 fprintf(stderr,"\tBuilt ");
971 printObj(stgCast(StgClosure*,o));
974 xPushPtr(stgCast(StgPtr,o));
979 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
980 /* ASSERT(isIntLike(con)); */
981 xPushTaggedInt(payloadWord(con,0));
986 StgWord offset = BCO_INSTR_16;
987 StgInt x = xPopTaggedInt();
988 StgInt y = xPopTaggedInt();
994 Case(i_CONST_INTEGER):
998 char* s = bcoConstAddr(bco,BCO_INSTR_8);
1000 n = size_fromStr(s);
1001 p = CreateByteArrayToHoldInteger(n);
1002 do_fromStr ( s, n, IntegerInsideByteArray(p));
1003 SloppifyIntegerEnd(p);
1010 StgWord w = xTaggedStackWord(BCO_INSTR_8);
1016 xPushTaggedWord(bcoConstWord(bco,BCO_INSTR_8));
1022 SSS; o = (StgClosure*)grabHpNonUpd(Wzh_sizeW); LLL;
1023 SET_HDR(o,Wzh_con_info,??);
1024 payloadWord(o,0) = xPopTaggedWord();
1026 fprintf(stderr,"\tBuilt ");
1028 printObj(stgCast(StgClosure*,o));
1031 xPushPtr(stgCast(StgPtr,o));
1034 Case(i_UNPACK_WORD):
1036 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1037 /* ASSERT(isWordLike(con)); */
1038 xPushTaggedWord(payloadWord(con,0));
1043 StgAddr a = xTaggedStackAddr(BCO_INSTR_8);
1049 xPushTaggedAddr(bcoConstAddr(bco,BCO_INSTR_8));
1052 Case(i_CONST_ADDR_big):
1054 int n = BCO_INSTR_16;
1055 xPushTaggedAddr(bcoConstAddr(bco,n));
1061 SSS; o = (StgClosure*)grabHpNonUpd(Azh_sizeW); LLL;
1062 SET_HDR(o,Azh_con_info,??);
1063 payloadPtr(o,0) = xPopTaggedAddr();
1065 fprintf(stderr,"\tBuilt ");
1067 printObj(stgCast(StgClosure*,o));
1070 xPushPtr(stgCast(StgPtr,o));
1073 Case(i_UNPACK_ADDR):
1075 StgClosure* con = (StgClosure*)xStackPtr(0);
1076 /* ASSERT(isAddrLike(con)); */
1077 xPushTaggedAddr(payloadPtr(con,0));
1082 StgChar c = xTaggedStackChar(BCO_INSTR_8);
1088 xPushTaggedChar(bcoConstChar(bco,BCO_INSTR_8));
1094 SSS; o = (StgClosure*)grabHpNonUpd(Czh_sizeW); LLL;
1095 SET_HDR(o,Czh_con_info,??);
1096 payloadWord(o,0) = xPopTaggedChar();
1097 xPushPtr(stgCast(StgPtr,o));
1099 fprintf(stderr,"\tBuilt ");
1101 printObj(stgCast(StgClosure*,o));
1106 Case(i_UNPACK_CHAR):
1108 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1109 /* ASSERT(isCharLike(con)); */
1110 xPushTaggedChar(payloadWord(con,0));
1115 StgFloat f = xTaggedStackFloat(BCO_INSTR_8);
1116 xPushTaggedFloat(f);
1119 Case(i_CONST_FLOAT):
1121 xPushTaggedFloat(bcoConstFloat(bco,BCO_INSTR_8));
1127 SSS; o = (StgClosure*)grabHpNonUpd(Fzh_sizeW); LLL;
1128 SET_HDR(o,Fzh_con_info,??);
1129 ASSIGN_FLT(&payloadWord(o,0),xPopTaggedFloat());
1131 fprintf(stderr,"\tBuilt ");
1133 printObj(stgCast(StgClosure*,o));
1136 xPushPtr(stgCast(StgPtr,o));
1139 Case(i_UNPACK_FLOAT):
1141 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1142 /* ASSERT(isFloatLike(con)); */
1143 xPushTaggedFloat(PK_FLT(&payloadWord(con,0)));
1148 StgDouble d = xTaggedStackDouble(BCO_INSTR_8);
1149 xPushTaggedDouble(d);
1152 Case(i_CONST_DOUBLE):
1154 xPushTaggedDouble(bcoConstDouble(bco,BCO_INSTR_8));
1157 Case(i_CONST_DOUBLE_big):
1159 int n = BCO_INSTR_16;
1160 xPushTaggedDouble(bcoConstDouble(bco,n));
1163 Case(i_PACK_DOUBLE):
1166 SSS; o = (StgClosure*)grabHpNonUpd(Dzh_sizeW); LLL;
1167 SET_HDR(o,Dzh_con_info,??);
1168 ASSIGN_DBL(&payloadWord(o,0),xPopTaggedDouble());
1170 fprintf(stderr,"\tBuilt ");
1171 printObj(stgCast(StgClosure*,o));
1173 xPushPtr(stgCast(StgPtr,o));
1176 Case(i_UNPACK_DOUBLE):
1178 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1179 /* ASSERT(isDoubleLike(con)); */
1180 xPushTaggedDouble(PK_DBL(&payloadWord(con,0)));
1185 StgStablePtr s = xTaggedStackStable(BCO_INSTR_8);
1186 xPushTaggedStable(s);
1189 Case(i_PACK_STABLE):
1192 SSS; o = (StgClosure*)grabHpNonUpd(Stablezh_sizeW); LLL;
1193 SET_HDR(o,StablePtr_con_info,??);
1194 payloadWord(o,0) = xPopTaggedStable();
1196 fprintf(stderr,"\tBuilt ");
1198 printObj(stgCast(StgClosure*,o));
1201 xPushPtr(stgCast(StgPtr,o));
1204 Case(i_UNPACK_STABLE):
1206 StgClosure* con = (StgClosure*)xStackPtr(0);
1207 /* ASSERT(isStableLike(con)); */
1208 xPushTaggedStable(payloadWord(con,0));
1216 SSS; p = enterBCO_primop1 ( i ); LLL;
1217 if (p) { obj = p; goto enterLoop; };
1222 int i, trc, pc_saved;
1225 trc = 12345678; /* Assume != any StgThreadReturnCode */
1230 p = enterBCO_primop2 ( i, &trc, &bco_tmp, cap,
1234 bciPtr = &(bcoInstr(bco,pc_saved));
1236 if (trc == 12345678) {
1237 /* we want to enter p */
1238 obj = p; goto enterLoop;
1240 /* trc is the the StgThreadReturnCode for
1242 RETURN((StgThreadReturnCode)trc);
1248 /* combined insns, created by peephole opt */
1251 int x = BCO_INSTR_8;
1252 int y = BCO_INSTR_8;
1253 ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
1254 /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
1261 xSetStackWord(x+y,xStackWord(x));
1271 p = xStackPtr(BCO_INSTR_8);
1273 p = xStackPtr(BCO_INSTR_8);
1280 xPushPtr(bcoConstPtr(bco,BCO_INSTR_8));
1281 xPushPtr(stgCast(StgPtr,&ret_bco_info));
1282 p = xStackPtr(BCO_INSTR_8);
1288 StgPtr retaddr = bcoConstPtr(bco,BCO_INSTR_8);
1289 StgPtr ptr = xStackPtr(BCO_INSTR_8);
1291 /* A shortcut. We're going to push the address of a
1292 return continuation, and then enter a variable, so
1293 that when the var is evaluated, we return to the
1294 continuation. The shortcut is: if the var is a
1295 constructor, don't bother to enter it. Instead,
1296 push the variable on the stack (since this is what
1297 the continuation expects) and jump directly to the
1300 if (get_itbl((StgClosure*)ptr)->type == CONSTR) {
1302 obj = (StgClosure*)retaddr;
1304 fprintf(stderr, "object to enter is a constructor -- "
1305 "jumping directly to return continuation\n" );
1310 /* This is the normal, non-short-cut route */
1312 xPushPtr(stgCast(StgPtr,&ret_bco_info));
1313 obj = (StgClosure*)ptr;
1318 Case(i_VAR_DOUBLE_big):
1319 Case(i_CONST_FLOAT_big):
1320 Case(i_VAR_FLOAT_big):
1321 Case(i_CONST_CHAR_big):
1322 Case(i_VAR_CHAR_big):
1323 Case(i_VAR_ADDR_big):
1324 Case(i_VAR_STABLE_big):
1325 Case(i_CONST_INTEGER_big):
1326 Case(i_VAR_INT_big):
1327 Case(i_VAR_WORD_big):
1328 Case(i_RETADDR_big):
1332 disInstr ( bco, PC );
1333 barf("\nUnrecognised instruction");
1337 barf("enterBCO: ran off end of loop");
1341 # undef LoopTopLabel
1347 /* ---------------------------------------------------- */
1348 /* End of the bytecode evaluator */
1349 /* ---------------------------------------------------- */
1353 StgBlockingQueue* bh;
1354 StgCAF* caf = (StgCAF*)obj;
1355 if (xSp - sizeofW(StgUpdateFrame) < xSpLim) {
1356 xPushCPtr(obj); /* code to restart with */
1357 RETURN(StackOverflow);
1359 /* ToDo: look for xSp==xSu && stackInt(0) == UPD_FRAME
1360 and insert an indirection immediately */
1361 SSS; bh = (StgBlockingQueue*)grabHpUpd(BLACKHOLE_sizeW()); LLL;
1362 SET_INFO(bh,&CAF_BLACKHOLE_info);
1363 bh->blocking_queue = EndTSOQueue;
1365 fprintf(stderr,"Created CAF_BLACKHOLE %p for CAF %p in evaluator\n",bh,caf));
1366 SET_INFO(caf,&CAF_ENTERED_info);
1367 caf->value = (StgClosure*)bh;
1368 if (caf->mut_link == NULL) {
1369 SSS; recordOldToNewPtrs((StgMutClosure*)caf); LLL;
1371 xPushUpdateFrame(bh,0);
1372 xSp -= sizeofW(StgUpdateFrame);
1373 caf->link = enteredCAFs;
1380 StgCAF* caf = (StgCAF*)obj;
1381 obj = caf->value; /* it's just a fancy indirection */
1387 case SE_CAF_BLACKHOLE:
1389 /* Let the scheduler figure out what to do :-) */
1390 cap->rCurrentTSO->what_next = ThreadEnterGHC;
1392 RETURN(ThreadYielding);
1396 StgAP_UPD* ap = stgCast(StgAP_UPD*,obj);
1398 if (xSp - (i + sizeofW(StgUpdateFrame)) < xSpLim) {
1399 xPushCPtr(obj); /* code to restart with */
1400 RETURN(StackOverflow);
1402 /* ToDo: look for xSp==xSu && stackInt(0) == UPD_FRAME
1403 and insert an indirection immediately */
1404 xPushUpdateFrame(ap,0);
1405 xSp -= sizeofW(StgUpdateFrame);
1407 xPushWord(payloadWord(ap,i));
1410 #ifdef EAGER_BLACKHOLING
1411 #warn LAZY_BLACKHOLING is default for StgHugs
1412 #error Dont know if EAGER_BLACKHOLING works in StgHugs
1414 /* superfluous - but makes debugging easier */
1415 StgBlackHole* bh = stgCast(StgBlackHole*,ap);
1416 SET_INFO(bh,&BLACKHOLE_info);
1417 bh->blocking_queue = EndTSOQueue;
1419 fprintf(stderr,"Eagerly blackholed AP_UPD %p in evaluator\n",bh));
1422 #endif /* EAGER_BLACKHOLING */
1427 StgPAP* pap = stgCast(StgPAP*,obj);
1428 int i = pap->n_args; /* ToDo: stack check */
1429 /* ToDo: if PAP is in whnf, we can update any update frames
1433 xPushWord(payloadWord(pap,i));
1440 obj = stgCast(StgInd*,obj)->indirectee;
1445 obj = stgCast(StgIndOldGen*,obj)->indirectee;
1454 case CONSTR_INTLIKE:
1455 case CONSTR_CHARLIKE:
1457 case CONSTR_NOCAF_STATIC:
1460 switch (get_itbl(stgCast(StgClosure*,xSp))->type) {
1462 SSS; PopCatchFrame(); LLL;
1465 xPopUpdateFrame(obj);
1468 SSS; PopSeqFrame(); LLL;
1472 ASSERT(xSp==(P_)xSu);
1475 fprintf(stderr, "hit a STOP_FRAME\n");
1477 fprintf(stderr,"xSp = %p\txSu = %p\n", xSp, xSu);
1478 printStack(xSp,cap->rCurrentTSO->stack
1479 + cap->rCurrentTSO->stack_size,xSu);
1482 SSS; PopStopFrame(obj); LLL;
1483 RETURN(ThreadFinished);
1493 /* was: goto enterLoop;
1494 But we know that obj must be a bco now, so jump directly.
1497 case RET_SMALL: /* return to GHC */
1501 cap->rCurrentTSO->what_next = ThreadEnterGHC;
1503 RETURN(ThreadYielding);
1505 belch("entered CONSTR with invalid continuation on stack");
1508 printObj(stgCast(StgClosure*,xSp));
1511 barf("bailing out");
1518 //fprintf(stderr, "enterCountI = %d\n", enterCountI);
1519 //fprintf(stderr, "entering unknown closure -- yielding to sched\n");
1522 cap->rCurrentTSO->what_next = ThreadEnterGHC;
1523 xPushCPtr(obj); /* code to restart with */
1524 RETURN(ThreadYielding);
1527 barf("Ran off the end of enter - yoiks");
1544 #undef xSetStackWord
1547 #undef xPushTaggedInt
1548 #undef xPopTaggedInt
1549 #undef xTaggedStackInt
1550 #undef xPushTaggedWord
1551 #undef xPopTaggedWord
1552 #undef xTaggedStackWord
1553 #undef xPushTaggedAddr
1554 #undef xTaggedStackAddr
1555 #undef xPopTaggedAddr
1556 #undef xPushTaggedStable
1557 #undef xTaggedStackStable
1558 #undef xPopTaggedStable
1559 #undef xPushTaggedChar
1560 #undef xTaggedStackChar
1561 #undef xPopTaggedChar
1562 #undef xPushTaggedFloat
1563 #undef xTaggedStackFloat
1564 #undef xPopTaggedFloat
1565 #undef xPushTaggedDouble
1566 #undef xTaggedStackDouble
1567 #undef xPopTaggedDouble
1568 #undef xPopUpdateFrame
1569 #undef xPushUpdateFrame
1572 /* --------------------------------------------------------------------------
1573 * Supporting routines for primops
1574 * ------------------------------------------------------------------------*/
1576 static inline void PushTag ( StackTag t )
1578 inline void PushPtr ( StgPtr x )
1579 { *(--stgCast(StgPtr*,gSp)) = x; }
1580 static inline void PushCPtr ( StgClosure* x )
1581 { *(--stgCast(StgClosure**,gSp)) = x; }
1582 static inline void PushInt ( StgInt x )
1583 { *(--stgCast(StgInt*,gSp)) = x; }
1584 static inline void PushWord ( StgWord x )
1585 { *(--stgCast(StgWord*,gSp)) = x; }
1588 static inline void checkTag ( StackTag t1, StackTag t2 )
1589 { ASSERT(t1 == t2);}
1590 static inline void PopTag ( StackTag t )
1591 { checkTag(t,*(gSp++)); }
1592 inline StgPtr PopPtr ( void )
1593 { return *stgCast(StgPtr*,gSp)++; }
1594 static inline StgClosure* PopCPtr ( void )
1595 { return *stgCast(StgClosure**,gSp)++; }
1596 static inline StgInt PopInt ( void )
1597 { return *stgCast(StgInt*,gSp)++; }
1598 static inline StgWord PopWord ( void )
1599 { return *stgCast(StgWord*,gSp)++; }
1601 static inline StgPtr stackPtr ( StgStackOffset i )
1602 { return *stgCast(StgPtr*, gSp+i); }
1603 static inline StgInt stackInt ( StgStackOffset i )
1604 { return *stgCast(StgInt*, gSp+i); }
1605 static inline StgWord stackWord ( StgStackOffset i )
1606 { return *stgCast(StgWord*,gSp+i); }
1608 static inline void setStackWord ( StgStackOffset i, StgWord w )
1611 static inline void PushTaggedRealWorld( void )
1612 { PushTag(REALWORLD_TAG); }
1613 inline void PushTaggedInt ( StgInt x )
1614 { gSp -= sizeofW(StgInt); *gSp = x; PushTag(INT_TAG); }
1615 inline void PushTaggedWord ( StgWord x )
1616 { gSp -= sizeofW(StgWord); *gSp = x; PushTag(WORD_TAG); }
1617 inline void PushTaggedAddr ( StgAddr x )
1618 { gSp -= sizeofW(StgAddr); *gSp = (W_)x; PushTag(ADDR_TAG); }
1619 inline void PushTaggedChar ( StgChar x )
1620 { gSp -= sizeofW(StgChar); *gSp = stgCast(StgWord,x); PushTag(CHAR_TAG); }
1621 inline void PushTaggedFloat ( StgFloat x )
1622 { gSp -= sizeofW(StgFloat); ASSIGN_FLT(gSp,x); PushTag(FLOAT_TAG); }
1623 inline void PushTaggedDouble ( StgDouble x )
1624 { gSp -= sizeofW(StgDouble); ASSIGN_DBL(gSp,x); PushTag(DOUBLE_TAG); }
1625 inline void PushTaggedStablePtr ( StgStablePtr x )
1626 { gSp -= sizeofW(StgStablePtr); *gSp = x; PushTag(STABLE_TAG); }
1627 static inline void PushTaggedBool ( int x )
1628 { PushTaggedInt(x); }
1632 static inline void PopTaggedRealWorld ( void )
1633 { PopTag(REALWORLD_TAG); }
1634 inline StgInt PopTaggedInt ( void )
1635 { StgInt r; PopTag(INT_TAG); r = *stgCast(StgInt*, gSp);
1636 gSp += sizeofW(StgInt); return r;}
1637 inline StgWord PopTaggedWord ( void )
1638 { StgWord r; PopTag(WORD_TAG); r = *stgCast(StgWord*, gSp);
1639 gSp += sizeofW(StgWord); return r;}
1640 inline StgAddr PopTaggedAddr ( void )
1641 { StgAddr r; PopTag(ADDR_TAG); r = *stgCast(StgAddr*, gSp);
1642 gSp += sizeofW(StgAddr); return r;}
1643 inline StgChar PopTaggedChar ( void )
1644 { StgChar r; PopTag(CHAR_TAG); r = stgCast(StgChar, *gSp);
1645 gSp += sizeofW(StgChar); return r;}
1646 inline StgFloat PopTaggedFloat ( void )
1647 { StgFloat r; PopTag(FLOAT_TAG); r = PK_FLT(gSp);
1648 gSp += sizeofW(StgFloat); return r;}
1649 inline StgDouble PopTaggedDouble ( void )
1650 { StgDouble r; PopTag(DOUBLE_TAG); r = PK_DBL(gSp);
1651 gSp += sizeofW(StgDouble); return r;}
1652 inline StgStablePtr PopTaggedStablePtr ( void )
1653 { StgInt r; PopTag(STABLE_TAG); r = *stgCast(StgStablePtr*, gSp);
1654 gSp += sizeofW(StgStablePtr); return r;}
1658 static inline StgInt taggedStackInt ( StgStackOffset i )
1659 { checkTag(INT_TAG,gSp[i]); return *stgCast(StgInt*, gSp+1+i); }
1660 static inline StgWord taggedStackWord ( StgStackOffset i )
1661 { checkTag(WORD_TAG,gSp[i]); return *stgCast(StgWord*, gSp+1+i); }
1662 static inline StgAddr taggedStackAddr ( StgStackOffset i )
1663 { checkTag(ADDR_TAG,gSp[i]); return *stgCast(StgAddr*, gSp+1+i); }
1664 static inline StgChar taggedStackChar ( StgStackOffset i )
1665 { checkTag(CHAR_TAG,gSp[i]); return stgCast(StgChar, *(gSp+1+i)) ; }
1666 static inline StgFloat taggedStackFloat ( StgStackOffset i )
1667 { checkTag(FLOAT_TAG,gSp[i]); return PK_FLT(gSp+1+i); }
1668 static inline StgDouble taggedStackDouble ( StgStackOffset i )
1669 { checkTag(DOUBLE_TAG,gSp[i]); return PK_DBL(gSp+1+i); }
1670 static inline StgStablePtr taggedStackStable ( StgStackOffset i )
1671 { checkTag(STABLE_TAG,gSp[i]); return *stgCast(StgStablePtr*, gSp+1+i); }
1674 /* --------------------------------------------------------------------------
1677 * Should we allocate from a nursery or use the
1678 * doYouWantToGC/allocate interface? We'd already implemented a
1679 * nursery-style scheme when the doYouWantToGC/allocate interface
1681 * One reason to prefer the doYouWantToGC/allocate interface is to
1682 * support operations which allocate an unknown amount in the heap
1683 * (array ops, gmp ops, etc)
1684 * ------------------------------------------------------------------------*/
1686 static inline StgPtr grabHpUpd( nat size )
1688 ASSERT( size >= MIN_UPD_SIZE + sizeofW(StgHeader) );
1689 #ifdef CRUDE_PROFILING
1690 cp_bill_words ( size );
1692 return allocate(size);
1695 static inline StgPtr grabHpNonUpd( nat size )
1697 ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
1698 #ifdef CRUDE_PROFILING
1699 cp_bill_words ( size );
1701 return allocate(size);
1704 /* --------------------------------------------------------------------------
1705 * Manipulate "update frame" list:
1706 * o Update frames (based on stg_do_update and friends in Updates.hc)
1707 * o Error handling/catching (based on catchzh_fast and friends in Prims.hc)
1708 * o Seq frames (based on seq_frame_entry in Prims.hc)
1710 * ------------------------------------------------------------------------*/
1712 static inline void PopUpdateFrame ( StgClosure* obj )
1714 /* NB: doesn't assume that gSp == gSu */
1716 fprintf(stderr, "Updating ");
1717 printPtr(stgCast(StgPtr,gSu->updatee));
1718 fprintf(stderr, " with ");
1720 fprintf(stderr,"gSp = %p\tgSu = %p\n\n", gSp, gSu);
1722 #ifdef EAGER_BLACKHOLING
1723 #warn LAZY_BLACKHOLING is default for StgHugs
1724 #error Dont know if EAGER_BLACKHOLING works in StgHugs
1725 ASSERT(get_itbl(gSu->updatee)->type == BLACKHOLE
1726 || get_itbl(gSu->updatee)->type == SE_BLACKHOLE
1727 || get_itbl(gSu->updatee)->type == CAF_BLACKHOLE
1728 || get_itbl(gSu->updatee)->type == SE_CAF_BLACKHOLE
1730 #endif /* EAGER_BLACKHOLING */
1731 UPD_IND(gSu->updatee,obj);
1732 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgUpdateFrame);
1736 static inline void PopStopFrame ( StgClosure* obj )
1738 /* Move gSu just off the end of the stack, we're about to gSpam the
1739 * STOP_FRAME with the return value.
1741 gSu = stgCast(StgUpdateFrame*,gSp+1);
1742 *stgCast(StgClosure**,gSp) = obj;
1745 static inline void PushCatchFrame ( StgClosure* handler )
1748 /* ToDo: stack check! */
1749 gSp -= sizeofW(StgCatchFrame);
1750 fp = stgCast(StgCatchFrame*,gSp);
1751 SET_HDR(fp,(StgInfoTable*)&catch_frame_info,CCCS);
1752 fp->handler = handler;
1754 gSu = stgCast(StgUpdateFrame*,fp);
1757 static inline void PopCatchFrame ( void )
1759 /* NB: doesn't assume that gSp == gSu */
1760 /* fprintf(stderr,"Popping catch frame\n"); */
1761 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgCatchFrame);
1762 gSu = stgCast(StgCatchFrame*,gSu)->link;
1765 static inline void PushSeqFrame ( void )
1768 /* ToDo: stack check! */
1769 gSp -= sizeofW(StgSeqFrame);
1770 fp = stgCast(StgSeqFrame*,gSp);
1771 SET_HDR(fp,(StgInfoTable*)&seq_frame_info,CCCS);
1773 gSu = stgCast(StgUpdateFrame*,fp);
1776 static inline void PopSeqFrame ( void )
1778 /* NB: doesn't assume that gSp == gSu */
1779 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgSeqFrame);
1780 gSu = stgCast(StgSeqFrame*,gSu)->link;
1783 static inline StgClosure* raiseAnError ( StgClosure* exception )
1785 /* This closure represents the expression 'primRaise E' where E
1786 * is the exception raised (:: Exception).
1787 * It is used to overwrite all the
1788 * thunks which are currently under evaluation.
1790 HaskellObj primRaiseClosure
1791 = asmClosureOfObject(getHugs_AsmObject_for("primRaise"));
1792 HaskellObj reraiseClosure
1793 = rts_apply ( primRaiseClosure, exception );
1796 switch (get_itbl(gSu)->type) {
1798 UPD_IND(gSu->updatee,reraiseClosure);
1799 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgUpdateFrame);
1805 case CATCH_FRAME: /* found it! */
1807 StgCatchFrame* fp = stgCast(StgCatchFrame*,gSu);
1808 StgClosure *handler = fp->handler;
1810 gSp += sizeofW(StgCatchFrame); /* Pop */
1811 PushCPtr(exception);
1815 barf("raiseError: uncaught exception: STOP_FRAME");
1817 barf("raiseError: weird activation record");
1823 static StgClosure* makeErrorCall ( const char* msg )
1825 /* Note! the msg string should be allocated in a
1826 place which will not get freed -- preferably
1827 read-only data of the program. That's because
1828 the thunk we build here may linger indefinitely.
1829 (thinks: probably not so, but anyway ...)
1832 = asmClosureOfObject(getHugs_AsmObject_for("error"));
1834 = asmClosureOfObject(getHugs_AsmObject_for("hugsprimUnpackString"));
1836 = rts_apply ( unpack, rts_mkAddr ( (void*)msg ) );
1838 = rts_apply ( error, thunk );
1840 (StgClosure*) thunk;
1843 #define raiseIndex(where) makeErrorCall("Array index out of range in " where)
1844 #define raiseDiv0(where) makeErrorCall("Division by zero in " where)
1846 /* --------------------------------------------------------------------------
1848 * ------------------------------------------------------------------------*/
1850 #define OP_CC_B(e) \
1852 unsigned char x = PopTaggedChar(); \
1853 unsigned char y = PopTaggedChar(); \
1854 PushTaggedBool(e); \
1859 unsigned char x = PopTaggedChar(); \
1868 #define OP_IW_I(e) \
1870 StgInt x = PopTaggedInt(); \
1871 StgWord y = PopTaggedWord(); \
1875 #define OP_II_I(e) \
1877 StgInt x = PopTaggedInt(); \
1878 StgInt y = PopTaggedInt(); \
1882 #define OP_II_B(e) \
1884 StgInt x = PopTaggedInt(); \
1885 StgInt y = PopTaggedInt(); \
1886 PushTaggedBool(e); \
1891 PushTaggedAddr(e); \
1896 StgInt x = PopTaggedInt(); \
1897 PushTaggedAddr(e); \
1902 StgInt x = PopTaggedInt(); \
1908 PushTaggedChar(e); \
1913 StgInt x = PopTaggedInt(); \
1914 PushTaggedChar(e); \
1919 PushTaggedWord(e); \
1924 StgInt x = PopTaggedInt(); \
1925 PushTaggedWord(e); \
1930 StgInt x = PopTaggedInt(); \
1931 PushTaggedStablePtr(e); \
1936 PushTaggedFloat(e); \
1941 StgInt x = PopTaggedInt(); \
1942 PushTaggedFloat(e); \
1947 PushTaggedDouble(e); \
1952 StgInt x = PopTaggedInt(); \
1953 PushTaggedDouble(e); \
1956 #define OP_WW_B(e) \
1958 StgWord x = PopTaggedWord(); \
1959 StgWord y = PopTaggedWord(); \
1960 PushTaggedBool(e); \
1963 #define OP_WW_W(e) \
1965 StgWord x = PopTaggedWord(); \
1966 StgWord y = PopTaggedWord(); \
1967 PushTaggedWord(e); \
1972 StgWord x = PopTaggedWord(); \
1978 StgStablePtr x = PopTaggedStablePtr(); \
1984 StgWord x = PopTaggedWord(); \
1985 PushTaggedWord(e); \
1988 #define OP_AA_B(e) \
1990 StgAddr x = PopTaggedAddr(); \
1991 StgAddr y = PopTaggedAddr(); \
1992 PushTaggedBool(e); \
1996 StgAddr x = PopTaggedAddr(); \
1999 #define OP_AI_C(s) \
2001 StgAddr x = PopTaggedAddr(); \
2002 int y = PopTaggedInt(); \
2005 PushTaggedChar(r); \
2007 #define OP_AI_I(s) \
2009 StgAddr x = PopTaggedAddr(); \
2010 int y = PopTaggedInt(); \
2015 #define OP_AI_A(s) \
2017 StgAddr x = PopTaggedAddr(); \
2018 int y = PopTaggedInt(); \
2021 PushTaggedAddr(s); \
2023 #define OP_AI_F(s) \
2025 StgAddr x = PopTaggedAddr(); \
2026 int y = PopTaggedInt(); \
2029 PushTaggedFloat(r); \
2031 #define OP_AI_D(s) \
2033 StgAddr x = PopTaggedAddr(); \
2034 int y = PopTaggedInt(); \
2037 PushTaggedDouble(r); \
2039 #define OP_AI_s(s) \
2041 StgAddr x = PopTaggedAddr(); \
2042 int y = PopTaggedInt(); \
2045 PushTaggedStablePtr(r); \
2047 #define OP_AIC_(s) \
2049 StgAddr x = PopTaggedAddr(); \
2050 int y = PopTaggedInt(); \
2051 StgChar z = PopTaggedChar(); \
2054 #define OP_AII_(s) \
2056 StgAddr x = PopTaggedAddr(); \
2057 int y = PopTaggedInt(); \
2058 StgInt z = PopTaggedInt(); \
2061 #define OP_AIA_(s) \
2063 StgAddr x = PopTaggedAddr(); \
2064 int y = PopTaggedInt(); \
2065 StgAddr z = PopTaggedAddr(); \
2068 #define OP_AIF_(s) \
2070 StgAddr x = PopTaggedAddr(); \
2071 int y = PopTaggedInt(); \
2072 StgFloat z = PopTaggedFloat(); \
2075 #define OP_AID_(s) \
2077 StgAddr x = PopTaggedAddr(); \
2078 int y = PopTaggedInt(); \
2079 StgDouble z = PopTaggedDouble(); \
2082 #define OP_AIs_(s) \
2084 StgAddr x = PopTaggedAddr(); \
2085 int y = PopTaggedInt(); \
2086 StgStablePtr z = PopTaggedStablePtr(); \
2091 #define OP_FF_B(e) \
2093 StgFloat x = PopTaggedFloat(); \
2094 StgFloat y = PopTaggedFloat(); \
2095 PushTaggedBool(e); \
2098 #define OP_FF_F(e) \
2100 StgFloat x = PopTaggedFloat(); \
2101 StgFloat y = PopTaggedFloat(); \
2102 PushTaggedFloat(e); \
2107 StgFloat x = PopTaggedFloat(); \
2108 PushTaggedFloat(e); \
2113 StgFloat x = PopTaggedFloat(); \
2114 PushTaggedBool(e); \
2119 StgFloat x = PopTaggedFloat(); \
2125 StgFloat x = PopTaggedFloat(); \
2126 PushTaggedDouble(e); \
2129 #define OP_DD_B(e) \
2131 StgDouble x = PopTaggedDouble(); \
2132 StgDouble y = PopTaggedDouble(); \
2133 PushTaggedBool(e); \
2136 #define OP_DD_D(e) \
2138 StgDouble x = PopTaggedDouble(); \
2139 StgDouble y = PopTaggedDouble(); \
2140 PushTaggedDouble(e); \
2145 StgDouble x = PopTaggedDouble(); \
2146 PushTaggedBool(e); \
2151 StgDouble x = PopTaggedDouble(); \
2152 PushTaggedDouble(e); \
2157 StgDouble x = PopTaggedDouble(); \
2163 StgDouble x = PopTaggedDouble(); \
2164 PushTaggedFloat(e); \
2168 StgPtr CreateByteArrayToHoldInteger ( int nbytes )
2170 StgWord words = (nbytes+sizeof(W_)-1)/sizeof(W_);
2171 StgWord size = sizeofW(StgArrWords) + words;
2172 StgArrWords* arr = (StgArrWords*)allocate(size);
2173 SET_HDR(arr,&ARR_WORDS_info,CCCS);
2175 ASSERT((W_)nbytes <= arr->words * sizeof(W_));
2178 for (i = 0; i < words; ++i) {
2179 arr->payload[i] = 0xdeadbeef;
2181 { B* b = (B*) &(arr->payload[0]);
2182 b->used = b->sign = 0;
2188 B* IntegerInsideByteArray ( StgPtr arr0 )
2191 StgArrWords* arr = (StgArrWords*)arr0;
2192 ASSERT(GET_INFO(arr) == &ARR_WORDS_info);
2193 b = (B*) &(arr->payload[0]);
2197 void SloppifyIntegerEnd ( StgPtr arr0 )
2199 StgArrWords* arr = (StgArrWords*)arr0;
2200 B* b = (B*) & (arr->payload[0]);
2201 I_ nwunused = arr->words - sizeofW(B) - (b->used+sizeof(W_)-1)/sizeof(W_);
2202 if (nwunused >= ((I_)sizeofW(StgArrWords))) {
2204 b->size -= nwunused * sizeof(W_);
2205 if (b->size < b->used) b->size = b->used;
2208 arr->words -= nwunused;
2209 slop = (StgArrWords*)&(arr->payload[arr->words]);
2210 SET_HDR(slop,&ARR_WORDS_info,CCCS);
2211 slop->words = nwunused - sizeofW(StgArrWords);
2212 ASSERT( &(slop->payload[slop->words]) ==
2213 &(arr->payload[arr->words + nwunused]) );
2217 #define OP_Z_Z(op) \
2219 B* x = IntegerInsideByteArray(PopPtr()); \
2220 int n = mycat2(size_,op)(x); \
2221 StgPtr p = CreateByteArrayToHoldInteger(n); \
2222 mycat2(do_,op)(x,n,IntegerInsideByteArray(p)); \
2223 SloppifyIntegerEnd(p); \
2226 #define OP_ZZ_Z(op) \
2228 B* x = IntegerInsideByteArray(PopPtr()); \
2229 B* y = IntegerInsideByteArray(PopPtr()); \
2230 int n = mycat2(size_,op)(x,y); \
2231 StgPtr p = CreateByteArrayToHoldInteger(n); \
2232 mycat2(do_,op)(x,y,n,IntegerInsideByteArray(p)); \
2233 SloppifyIntegerEnd(p); \
2240 #define HEADER_mI(ty,where) \
2241 StgArrWords* x = stgCast(StgArrWords*,PopPtr()); \
2242 nat i = PopTaggedInt(); \
2243 if (i * sizeof(ty) + (sizeof(ty)) > sizeof(StgWord) * x->words) { \
2244 return (raiseIndex(where)); \
2246 #define OP_mI_ty(ty,where,s) \
2248 HEADER_mI(mycat2(Stg,ty),where) \
2249 { mycat2(Stg,ty) r; \
2251 mycat2(PushTagged,ty)(r); \
2254 #define OP_mIty_(ty,where,s) \
2256 HEADER_mI(mycat2(Stg,ty),where) \
2258 mycat2(Stg,ty) z = mycat2(PopTagged,ty)(); \
2264 static void myStackCheck ( Capability* cap )
2266 /* fprintf(stderr, "myStackCheck\n"); */
2267 if (!(gSpLim <= gSp && gSp <= stgCast(StgPtr,gSu))) {
2268 fprintf(stderr, "myStackCheck: invalid initial gSp/gSu \n" );
2272 if (!( (P_)gSu >= (P_)cap->rCurrentTSO->stack
2274 (P_)gSu <= (P_)(cap->rCurrentTSO->stack
2275 + cap->rCurrentTSO->stack_size))) {
2276 fprintf ( stderr, "myStackCheck: gSu out of stack\n" );
2279 switch (get_itbl(stgCast(StgClosure*,gSu))->type) {
2281 gSu = (StgUpdateFrame*) ((StgCatchFrame*)(gSu))->link;
2284 gSu = (StgUpdateFrame*) ((StgUpdateFrame*)(gSu))->link;
2287 gSu = (StgUpdateFrame*) ((StgSeqFrame*)(gSu))->link;
2292 fprintf(stderr, "myStackCheck: invalid activation record\n"); assert(0);
2299 /* --------------------------------------------------------------------------
2300 * Primop stuff for bytecode interpreter
2301 * ------------------------------------------------------------------------*/
2303 /* Returns & of the next thing to enter (if throwing an exception),
2304 or NULL in the normal case.
2306 static void* enterBCO_primop1 ( int primop1code )
2309 barf("enterBCO_primop1 in combined mode");
2311 switch (primop1code) {
2312 case i_pushseqframe:
2314 StgClosure* c = PopCPtr();
2319 case i_pushcatchframe:
2321 StgClosure* e = PopCPtr();
2322 StgClosure* h = PopCPtr();
2328 case i_gtChar: OP_CC_B(x>y); break;
2329 case i_geChar: OP_CC_B(x>=y); break;
2330 case i_eqChar: OP_CC_B(x==y); break;
2331 case i_neChar: OP_CC_B(x!=y); break;
2332 case i_ltChar: OP_CC_B(x<y); break;
2333 case i_leChar: OP_CC_B(x<=y); break;
2334 case i_charToInt: OP_C_I(x); break;
2335 case i_intToChar: OP_I_C(x); break;
2337 case i_gtInt: OP_II_B(x>y); break;
2338 case i_geInt: OP_II_B(x>=y); break;
2339 case i_eqInt: OP_II_B(x==y); break;
2340 case i_neInt: OP_II_B(x!=y); break;
2341 case i_ltInt: OP_II_B(x<y); break;
2342 case i_leInt: OP_II_B(x<=y); break;
2343 case i_minInt: OP__I(INT_MIN); break;
2344 case i_maxInt: OP__I(INT_MAX); break;
2345 case i_plusInt: OP_II_I(x+y); break;
2346 case i_minusInt: OP_II_I(x-y); break;
2347 case i_timesInt: OP_II_I(x*y); break;
2350 int x = PopTaggedInt();
2351 int y = PopTaggedInt();
2353 return (raiseDiv0("quotInt"));
2355 /* ToDo: protect against minInt / -1 errors
2356 * (repeat for all other division primops) */
2362 int x = PopTaggedInt();
2363 int y = PopTaggedInt();
2365 return (raiseDiv0("remInt"));
2372 StgInt x = PopTaggedInt();
2373 StgInt y = PopTaggedInt();
2375 return (raiseDiv0("quotRemInt"));
2377 PushTaggedInt(x%y); /* last result */
2378 PushTaggedInt(x/y); /* first result */
2381 case i_negateInt: OP_I_I(-x); break;
2383 case i_andInt: OP_II_I(x&y); break;
2384 case i_orInt: OP_II_I(x|y); break;
2385 case i_xorInt: OP_II_I(x^y); break;
2386 case i_notInt: OP_I_I(~x); break;
2387 case i_shiftLInt: OP_II_I(x<<y); break;
2388 case i_shiftRAInt: OP_II_I(x>>y); break; /* ToDo */
2389 case i_shiftRLInt: OP_II_I(x>>y); break; /* ToDo */
2391 case i_gtWord: OP_WW_B(x>y); break;
2392 case i_geWord: OP_WW_B(x>=y); break;
2393 case i_eqWord: OP_WW_B(x==y); break;
2394 case i_neWord: OP_WW_B(x!=y); break;
2395 case i_ltWord: OP_WW_B(x<y); break;
2396 case i_leWord: OP_WW_B(x<=y); break;
2397 case i_minWord: OP__W(0); break;
2398 case i_maxWord: OP__W(UINT_MAX); break;
2399 case i_plusWord: OP_WW_W(x+y); break;
2400 case i_minusWord: OP_WW_W(x-y); break;
2401 case i_timesWord: OP_WW_W(x*y); break;
2404 StgWord x = PopTaggedWord();
2405 StgWord y = PopTaggedWord();
2407 return (raiseDiv0("quotWord"));
2409 PushTaggedWord(x/y);
2414 StgWord x = PopTaggedWord();
2415 StgWord y = PopTaggedWord();
2417 return (raiseDiv0("remWord"));
2419 PushTaggedWord(x%y);
2424 StgWord x = PopTaggedWord();
2425 StgWord y = PopTaggedWord();
2427 return (raiseDiv0("quotRemWord"));
2429 PushTaggedWord(x%y); /* last result */
2430 PushTaggedWord(x/y); /* first result */
2433 case i_negateWord: OP_W_W(-x); break;
2434 case i_andWord: OP_WW_W(x&y); break;
2435 case i_orWord: OP_WW_W(x|y); break;
2436 case i_xorWord: OP_WW_W(x^y); break;
2437 case i_notWord: OP_W_W(~x); break;
2438 case i_shiftLWord: OP_WW_W(x<<y); break;
2439 case i_shiftRAWord: OP_WW_W(x>>y); break; /* ToDo */
2440 case i_shiftRLWord: OP_WW_W(x>>y); break; /* ToDo */
2441 case i_intToWord: OP_I_W(x); break;
2442 case i_wordToInt: OP_W_I(x); break;
2444 case i_gtAddr: OP_AA_B(x>y); break;
2445 case i_geAddr: OP_AA_B(x>=y); break;
2446 case i_eqAddr: OP_AA_B(x==y); break;
2447 case i_neAddr: OP_AA_B(x!=y); break;
2448 case i_ltAddr: OP_AA_B(x<y); break;
2449 case i_leAddr: OP_AA_B(x<=y); break;
2450 case i_intToAddr: OP_I_A((StgAddr)x); break; /* ToDo */
2451 case i_addrToInt: OP_A_I((StgInt)x); break; /* ToDo */
2453 case i_intToStable: OP_I_s(x); break;
2454 case i_stableToInt: OP_s_I(x); break;
2456 case i_indexCharOffAddr: OP_AI_C(indexCharOffAddrzh(r,x,y)); break;
2457 case i_readCharOffAddr: OP_AI_C(indexCharOffAddrzh(r,x,y)); break;
2458 case i_writeCharOffAddr: OP_AIC_(writeCharOffAddrzh(x,y,z)); break;
2460 case i_indexIntOffAddr: OP_AI_I(indexIntOffAddrzh(r,x,y)); break;
2461 case i_readIntOffAddr: OP_AI_I(indexIntOffAddrzh(r,x,y)); break;
2462 case i_writeIntOffAddr: OP_AII_(writeIntOffAddrzh(x,y,z)); break;
2464 case i_indexAddrOffAddr: OP_AI_A(indexAddrOffAddrzh(r,x,y)); break;
2465 case i_readAddrOffAddr: OP_AI_A(indexAddrOffAddrzh(r,x,y)); break;
2466 case i_writeAddrOffAddr: OP_AIA_(writeAddrOffAddrzh(x,y,z)); break;
2468 case i_indexFloatOffAddr: OP_AI_F(indexFloatOffAddrzh(r,x,y)); break;
2469 case i_readFloatOffAddr: OP_AI_F(indexFloatOffAddrzh(r,x,y)); break;
2470 case i_writeFloatOffAddr: OP_AIF_(writeFloatOffAddrzh(x,y,z)); break;
2472 case i_indexDoubleOffAddr: OP_AI_D(indexDoubleOffAddrzh(r,x,y)); break;
2473 case i_readDoubleOffAddr: OP_AI_D(indexDoubleOffAddrzh(r,x,y)); break;
2474 case i_writeDoubleOffAddr: OP_AID_(writeDoubleOffAddrzh(x,y,z)); break;
2476 case i_indexStableOffAddr: OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break;
2477 case i_readStableOffAddr: OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break;
2478 case i_writeStableOffAddr: OP_AIs_(writeStablePtrOffAddrzh(x,y,z)); break;
2480 case i_compareInteger:
2482 B* x = IntegerInsideByteArray(PopPtr());
2483 B* y = IntegerInsideByteArray(PopPtr());
2484 StgInt r = do_cmp(x,y);
2485 PushTaggedInt(r<0 ? -1 : (r>0 ? 1 : 0));
2488 case i_negateInteger: OP_Z_Z(neg); break;
2489 case i_plusInteger: OP_ZZ_Z(add); break;
2490 case i_minusInteger: OP_ZZ_Z(sub); break;
2491 case i_timesInteger: OP_ZZ_Z(mul); break;
2492 case i_quotRemInteger:
2494 B* x = IntegerInsideByteArray(PopPtr());
2495 B* y = IntegerInsideByteArray(PopPtr());
2496 int n = size_qrm(x,y);
2497 StgPtr q = CreateByteArrayToHoldInteger(n);
2498 StgPtr r = CreateByteArrayToHoldInteger(n);
2499 if (do_getsign(y)==0)
2500 return (raiseDiv0("quotRemInteger"));
2501 do_qrm(x,y,n,IntegerInsideByteArray(q),
2502 IntegerInsideByteArray(r));
2503 SloppifyIntegerEnd(q);
2504 SloppifyIntegerEnd(r);
2509 case i_intToInteger:
2511 int n = size_fromInt();
2512 StgPtr p = CreateByteArrayToHoldInteger(n);
2513 do_fromInt( PopTaggedInt(), n, IntegerInsideByteArray(p));
2517 case i_wordToInteger:
2519 int n = size_fromWord();
2520 StgPtr p = CreateByteArrayToHoldInteger(n);
2521 do_fromWord( PopTaggedWord(), n, IntegerInsideByteArray(p));
2525 case i_integerToInt: PushTaggedInt(do_toInt(
2526 IntegerInsideByteArray(PopPtr())
2530 case i_integerToWord: PushTaggedWord(do_toWord(
2531 IntegerInsideByteArray(PopPtr())
2535 case i_integerToFloat: PushTaggedFloat(do_toFloat(
2536 IntegerInsideByteArray(PopPtr())
2540 case i_integerToDouble: PushTaggedDouble(do_toDouble(
2541 IntegerInsideByteArray(PopPtr())
2545 case i_gtFloat: OP_FF_B(x>y); break;
2546 case i_geFloat: OP_FF_B(x>=y); break;
2547 case i_eqFloat: OP_FF_B(x==y); break;
2548 case i_neFloat: OP_FF_B(x!=y); break;
2549 case i_ltFloat: OP_FF_B(x<y); break;
2550 case i_leFloat: OP_FF_B(x<=y); break;
2551 case i_minFloat: OP__F(FLT_MIN); break;
2552 case i_maxFloat: OP__F(FLT_MAX); break;
2553 case i_radixFloat: OP__I(FLT_RADIX); break;
2554 case i_digitsFloat: OP__I(FLT_MANT_DIG); break;
2555 case i_minExpFloat: OP__I(FLT_MIN_EXP); break;
2556 case i_maxExpFloat: OP__I(FLT_MAX_EXP); break;
2557 case i_plusFloat: OP_FF_F(x+y); break;
2558 case i_minusFloat: OP_FF_F(x-y); break;
2559 case i_timesFloat: OP_FF_F(x*y); break;
2562 StgFloat x = PopTaggedFloat();
2563 StgFloat y = PopTaggedFloat();
2564 PushTaggedFloat(x/y);
2567 case i_negateFloat: OP_F_F(-x); break;
2568 case i_floatToInt: OP_F_I(x); break;
2569 case i_intToFloat: OP_I_F(x); break;
2570 case i_expFloat: OP_F_F(exp(x)); break;
2571 case i_logFloat: OP_F_F(log(x)); break;
2572 case i_sqrtFloat: OP_F_F(sqrt(x)); break;
2573 case i_sinFloat: OP_F_F(sin(x)); break;
2574 case i_cosFloat: OP_F_F(cos(x)); break;
2575 case i_tanFloat: OP_F_F(tan(x)); break;
2576 case i_asinFloat: OP_F_F(asin(x)); break;
2577 case i_acosFloat: OP_F_F(acos(x)); break;
2578 case i_atanFloat: OP_F_F(atan(x)); break;
2579 case i_sinhFloat: OP_F_F(sinh(x)); break;
2580 case i_coshFloat: OP_F_F(cosh(x)); break;
2581 case i_tanhFloat: OP_F_F(tanh(x)); break;
2582 case i_powerFloat: OP_FF_F(pow(x,y)); break;
2584 case i_encodeFloatZ:
2586 StgPtr sig = PopPtr();
2587 StgInt exp = PopTaggedInt();
2589 B__encodeFloat(IntegerInsideByteArray(sig), exp)
2593 case i_decodeFloatZ:
2595 StgFloat f = PopTaggedFloat();
2596 StgPtr sig = CreateByteArrayToHoldInteger(size_fltmantissa());
2598 B__decodeFloat(IntegerInsideByteArray(sig), &exp, f);
2604 case i_isNaNFloat: OP_F_B(isFloatNaN(x)); break;
2605 case i_isInfiniteFloat: OP_F_B(isFloatInfinite(x)); break;
2606 case i_isNegativeZeroFloat: OP_F_B(isFloatNegativeZero(x)); break;
2607 case i_isDenormalizedFloat: OP_F_B(isFloatDenormalized(x)); break;
2608 case i_gtDouble: OP_DD_B(x>y); break;
2609 case i_geDouble: OP_DD_B(x>=y); break;
2610 case i_eqDouble: OP_DD_B(x==y); break;
2611 case i_neDouble: OP_DD_B(x!=y); break;
2612 case i_ltDouble: OP_DD_B(x<y); break;
2613 case i_leDouble: OP_DD_B(x<=y) break;
2614 case i_minDouble: OP__D(DBL_MIN); break;
2615 case i_maxDouble: OP__D(DBL_MAX); break;
2616 case i_radixDouble: OP__I(FLT_RADIX); break;
2617 case i_digitsDouble: OP__I(DBL_MANT_DIG); break;
2618 case i_minExpDouble: OP__I(DBL_MIN_EXP); break;
2619 case i_maxExpDouble: OP__I(DBL_MAX_EXP); break;
2620 case i_plusDouble: OP_DD_D(x+y); break;
2621 case i_minusDouble: OP_DD_D(x-y); break;
2622 case i_timesDouble: OP_DD_D(x*y); break;
2623 case i_divideDouble:
2625 StgDouble x = PopTaggedDouble();
2626 StgDouble y = PopTaggedDouble();
2627 PushTaggedDouble(x/y);
2630 case i_negateDouble: OP_D_D(-x); break;
2631 case i_doubleToInt: OP_D_I(x); break;
2632 case i_intToDouble: OP_I_D(x); break;
2633 case i_doubleToFloat: OP_D_F(x); break;
2634 case i_floatToDouble: OP_F_F(x); break;
2635 case i_expDouble: OP_D_D(exp(x)); break;
2636 case i_logDouble: OP_D_D(log(x)); break;
2637 case i_sqrtDouble: OP_D_D(sqrt(x)); break;
2638 case i_sinDouble: OP_D_D(sin(x)); break;
2639 case i_cosDouble: OP_D_D(cos(x)); break;
2640 case i_tanDouble: OP_D_D(tan(x)); break;
2641 case i_asinDouble: OP_D_D(asin(x)); break;
2642 case i_acosDouble: OP_D_D(acos(x)); break;
2643 case i_atanDouble: OP_D_D(atan(x)); break;
2644 case i_sinhDouble: OP_D_D(sinh(x)); break;
2645 case i_coshDouble: OP_D_D(cosh(x)); break;
2646 case i_tanhDouble: OP_D_D(tanh(x)); break;
2647 case i_powerDouble: OP_DD_D(pow(x,y)); break;
2649 case i_encodeDoubleZ:
2651 StgPtr sig = PopPtr();
2652 StgInt exp = PopTaggedInt();
2654 B__encodeDouble(IntegerInsideByteArray(sig), exp)
2658 case i_decodeDoubleZ:
2660 StgDouble d = PopTaggedDouble();
2661 StgPtr sig = CreateByteArrayToHoldInteger(size_dblmantissa());
2663 B__decodeDouble(IntegerInsideByteArray(sig), &exp, d);
2669 case i_isNaNDouble: OP_D_B(isDoubleNaN(x)); break;
2670 case i_isInfiniteDouble: OP_D_B(isDoubleInfinite(x)); break;
2671 case i_isNegativeZeroDouble: OP_D_B(isDoubleNegativeZero(x)); break;
2672 case i_isDenormalizedDouble: OP_D_B(isDoubleDenormalized(x)); break;
2673 case i_isIEEEDouble:
2675 PushTaggedBool(rtsTrue);
2679 barf("Unrecognised primop1");
2686 /* For normal cases, return NULL and leave *return2 unchanged.
2687 To return the address of the next thing to enter,
2688 return the address of it and leave *return2 unchanged.
2689 To return a StgThreadReturnCode to the scheduler,
2690 set *return2 to it and return a non-NULL value.
2691 To cause a context switch, set context_switch (its a global),
2692 and optionally set hugsBlock to your rational.
2694 static void* enterBCO_primop2 ( int primop2code,
2695 int* /*StgThreadReturnCode* */ return2,
2698 HugsBlock *hugsBlock )
2701 /* A small concession: we need to allow ccalls,
2702 even in combined mode.
2704 if (primop2code != i_ccall_ccall_IO &&
2705 primop2code != i_ccall_stdcall_IO)
2706 barf("enterBCO_primop2 in combined mode");
2709 switch (primop2code) {
2710 case i_raise: /* raise#{err} */
2712 StgClosure* err = PopCPtr();
2713 return (raiseAnError(err));
2718 StgClosure* init = PopCPtr();
2720 = stgCast(StgMutVar*,allocate(sizeofW(StgMutVar)));
2721 SET_HDR(mv,&MUT_VAR_info,CCCS);
2723 PushPtr(stgCast(StgPtr,mv));
2728 StgMutVar* mv = stgCast(StgMutVar*,PopPtr());
2734 StgMutVar* mv = stgCast(StgMutVar*,PopPtr());
2735 StgClosure* value = PopCPtr();
2741 nat n = PopTaggedInt(); /* or Word?? */
2742 StgClosure* init = PopCPtr();
2743 StgWord size = sizeofW(StgMutArrPtrs) + n;
2746 = stgCast(StgMutArrPtrs*,allocate(size));
2747 SET_HDR(arr,&MUT_ARR_PTRS_info,CCCS);
2749 for (i = 0; i < n; ++i) {
2750 arr->payload[i] = init;
2752 PushPtr(stgCast(StgPtr,arr));
2758 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2759 nat i = PopTaggedInt(); /* or Word?? */
2760 StgWord n = arr->ptrs;
2762 return (raiseIndex("{index,read}Array"));
2764 PushCPtr(arr->payload[i]);
2769 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2770 nat i = PopTaggedInt(); /* or Word? */
2771 StgClosure* v = PopCPtr();
2772 StgWord n = arr->ptrs;
2774 return (raiseIndex("{index,read}Array"));
2776 arr->payload[i] = v;
2780 case i_sizeMutableArray:
2782 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2783 PushTaggedInt(arr->ptrs);
2786 case i_unsafeFreezeArray:
2788 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2789 SET_INFO(arr,&MUT_ARR_PTRS_FROZEN_info);
2790 PushPtr(stgCast(StgPtr,arr));
2793 case i_unsafeFreezeByteArray:
2795 /* Delightfully simple :-) */
2799 case i_sameMutableArray:
2800 case i_sameMutableByteArray:
2802 StgPtr x = PopPtr();
2803 StgPtr y = PopPtr();
2804 PushTaggedBool(x==y);
2808 case i_newByteArray:
2810 nat n = PopTaggedInt(); /* or Word?? */
2811 StgInt words = (n+sizeof(W_)-1)/sizeof(W_);
2812 StgWord size = sizeofW(StgArrWords) + words;
2813 StgArrWords* arr = stgCast(StgArrWords*,allocate(size));
2814 SET_HDR(arr,&ARR_WORDS_info,CCCS);
2818 for (i = 0; i < n; ++i) {
2819 arr->payload[i] = 0xdeadbeef;
2822 PushPtr(stgCast(StgPtr,arr));
2826 /* Most of these generate alignment warnings on Sparcs and similar architectures.
2827 * These are harmless and are caused by the cast to C* in BYTE_ARR_CTS.
2829 case i_indexCharArray:
2830 OP_mI_ty(Char,"indexCharArray", indexCharArrayzh(r,x,i)); break;
2831 case i_readCharArray:
2832 OP_mI_ty(Char,"readCharArray", readCharArrayzh(r,x,i)); break;
2833 case i_writeCharArray:
2834 OP_mIty_(Char,"writeCharArray", writeCharArrayzh(x,i,z)); break;
2836 case i_indexIntArray:
2837 OP_mI_ty(Int,"indexIntArray", indexIntArrayzh(r,x,i)); break;
2838 case i_readIntArray:
2839 OP_mI_ty(Int,"readIntArray", readIntArrayzh(r,x,i)); break;
2840 case i_writeIntArray:
2841 OP_mIty_(Int,"writeIntArray", writeIntArrayzh(x,i,z)); break;
2843 case i_indexAddrArray:
2844 OP_mI_ty(Addr,"indexAddrArray", indexAddrArrayzh(r,x,i)); break;
2845 case i_readAddrArray:
2846 OP_mI_ty(Addr,"readAddrArray", readAddrArrayzh(r,x,i)); break;
2847 case i_writeAddrArray:
2848 OP_mIty_(Addr,"writeAddrArray", writeAddrArrayzh(x,i,z)); break;
2850 case i_indexFloatArray:
2851 OP_mI_ty(Float,"indexFloatArray", indexFloatArrayzh(r,x,i)); break;
2852 case i_readFloatArray:
2853 OP_mI_ty(Float,"readFloatArray", readFloatArrayzh(r,x,i)); break;
2854 case i_writeFloatArray:
2855 OP_mIty_(Float,"writeFloatArray", writeFloatArrayzh(x,i,z)); break;
2857 case i_indexDoubleArray:
2858 OP_mI_ty(Double,"indexDoubleArray", indexDoubleArrayzh(r,x,i)); break;
2859 case i_readDoubleArray:
2860 OP_mI_ty(Double,"readDoubleArray", readDoubleArrayzh(r,x,i)); break;
2861 case i_writeDoubleArray:
2862 OP_mIty_(Double,"writeDoubleArray", writeDoubleArrayzh(x,i,z)); break;
2865 #ifdef PROVIDE_STABLE
2866 case i_indexStableArray:
2867 OP_mI_ty(StablePtr,"indexStableArray", indexStablePtrArrayzh(r,x,i)); break;
2868 case i_readStableArray:
2869 OP_mI_ty(StablePtr,"readStableArray", readStablePtrArrayzh(r,x,i)); break;
2870 case i_writeStableArray:
2871 OP_mIty_(StablePtr,"writeStableArray", writeStablePtrArrayzh(x,i,z)); break;
2877 #ifdef PROVIDE_COERCE
2878 case i_unsafeCoerce:
2880 /* Another nullop */
2884 #ifdef PROVIDE_PTREQUALITY
2885 case i_reallyUnsafePtrEquality:
2886 { /* identical to i_sameRef */
2887 StgPtr x = PopPtr();
2888 StgPtr y = PopPtr();
2889 PushTaggedBool(x==y);
2893 #ifdef PROVIDE_FOREIGN
2894 /* ForeignObj# operations */
2895 case i_makeForeignObj:
2897 StgForeignObj *result
2898 = stgCast(StgForeignObj*,allocate(sizeofW(StgForeignObj)));
2899 SET_HDR(result,&FOREIGN_info,CCCS);
2900 result -> data = PopTaggedAddr();
2901 PushPtr(stgCast(StgPtr,result));
2904 #endif /* PROVIDE_FOREIGN */
2909 = stgCast(StgWeak*,allocate(sizeofW(StgWeak)));
2910 SET_HDR(w, &WEAK_info, CCCS);
2912 w->value = PopCPtr();
2913 w->finaliser = PopCPtr();
2914 w->link = weak_ptr_list;
2916 IF_DEBUG(weak, fprintf(stderr,"New weak pointer at %p\n",w));
2917 PushPtr(stgCast(StgPtr,w));
2922 StgWeak *w = stgCast(StgWeak*,PopPtr());
2923 if (w->header.info == &WEAK_info) {
2924 PushCPtr(w->value); /* last result */
2925 PushTaggedInt(1); /* first result */
2927 PushPtr(stgCast(StgPtr,w));
2928 /* ToDo: error thunk would be better */
2933 #endif /* PROVIDE_WEAK */
2935 case i_makeStablePtr:
2937 StgPtr p = PopPtr();
2938 StgStablePtr sp = getStablePtr ( p );
2939 PushTaggedStablePtr(sp);
2942 case i_deRefStablePtr:
2945 StgStablePtr sp = PopTaggedStablePtr();
2946 p = deRefStablePtr(sp);
2950 case i_freeStablePtr:
2952 StgStablePtr sp = PopTaggedStablePtr();
2957 case i_createAdjThunkARCH:
2959 StgStablePtr stableptr = PopTaggedStablePtr();
2960 StgAddr typestr = PopTaggedAddr();
2961 StgChar callconv = PopTaggedChar();
2962 StgAddr adj_thunk = createAdjThunk(stableptr,typestr,callconv);
2963 PushTaggedAddr(adj_thunk);
2969 StgInt n = prog_argc;
2975 StgInt n = PopTaggedInt();
2976 StgAddr a = (StgAddr)prog_argv[n];
2983 StgMVar *mvar = stgCast(StgMVar*,allocate(sizeofW(StgMVar)));
2984 SET_INFO(mvar,&EMPTY_MVAR_info);
2985 mvar->head = mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
2986 mvar->value = stgCast(StgClosure*,&END_TSO_QUEUE_closure);
2987 PushPtr(stgCast(StgPtr,mvar));
2992 StgMVar *mvar = (StgMVar*)PopCPtr();
2993 if (GET_INFO(mvar) == &EMPTY_MVAR_info) {
2995 /* The MVar is empty. Attach ourselves to the TSO's
2998 if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
2999 mvar->head = cap->rCurrentTSO;
3001 mvar->tail->link = cap->rCurrentTSO;
3003 cap->rCurrentTSO->link = (StgTSO *)&END_TSO_QUEUE_closure;
3004 cap->rCurrentTSO->why_blocked = BlockedOnMVar;
3005 cap->rCurrentTSO->block_info.closure = (StgClosure *)mvar;
3006 mvar->tail = cap->rCurrentTSO;
3008 /* At this point, the top-of-stack holds the MVar,
3009 and underneath is the world token (). So the
3010 stack is in the same state as when primTakeMVar
3011 was entered (primTakeMVar is handwritten bytecode).
3012 Push obj, which is this BCO, and return to the
3013 scheduler. When the MVar is filled, the scheduler
3014 will re-enter primTakeMVar, with the args still on
3015 the top of the stack.
3017 PushCPtr((StgClosure*)(*bco));
3018 *return2 = ThreadBlocked;
3019 return (void*)(1+(char*)(NULL));
3022 PushCPtr(mvar->value);
3023 mvar->value = (StgClosure *)&END_TSO_QUEUE_closure;
3024 SET_INFO(mvar,&EMPTY_MVAR_info);
3030 StgMVar* mvar = stgCast(StgMVar*,PopPtr());
3031 StgClosure* value = PopCPtr();
3032 if (GET_INFO(mvar) == &FULL_MVAR_info) {
3033 return (makeErrorCall("putMVar {full MVar}"));
3035 /* wake up the first thread on the
3036 * queue, it will continue with the
3037 * takeMVar operation and mark the
3040 mvar->value = value;
3042 if (mvar->head != (StgTSO *)&END_TSO_QUEUE_closure) {
3043 ASSERT(mvar->head->why_blocked == BlockedOnMVar);
3044 mvar->head = unblockOne(mvar->head);
3045 if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
3046 mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
3050 /* unlocks the MVar in the SMP case */
3051 SET_INFO(mvar,&FULL_MVAR_info);
3053 /* yield for better communication performance */
3059 { /* identical to i_sameRef */
3060 StgMVar* x = (StgMVar*)PopPtr();
3061 StgMVar* y = (StgMVar*)PopPtr();
3062 PushTaggedBool(x==y);
3065 #ifdef PROVIDE_CONCURRENT
3068 StgClosure* closure;
3071 closure = PopCPtr();
3072 tso = createGenThread (RtsFlags.GcFlags.initialStkSize,closure);
3074 scheduleThread(tso);
3076 /* Later: Change to use tso as the ThreadId */
3077 PushTaggedWord(tid);
3083 StgWord n = PopTaggedWord();
3087 // Map from ThreadId to Thread Structure */
3088 for (t = all_threads; t != END_TSO_QUEUE; t = t->global_link) {
3097 while (tso->what_next == ThreadRelocated) {
3102 if (tso == cap->rCurrentTSO) { /* suicide */
3103 *return2 = ThreadFinished;
3104 return (void*)(1+(NULL));
3108 case i_raiseInThread:
3109 ASSERT(0); /* not (yet) supported */
3112 StgInt n = PopTaggedInt();
3114 hugsBlock->reason = BlockedOnDelay;
3115 hugsBlock->delay = n;
3120 StgInt n = PopTaggedInt();
3122 hugsBlock->reason = BlockedOnRead;
3123 hugsBlock->delay = n;
3128 StgInt n = PopTaggedInt();
3130 hugsBlock->reason = BlockedOnWrite;
3131 hugsBlock->delay = n;
3136 /* The definition of yield include an enter right after
3137 * the primYield, at which time context_switch is tested.
3144 StgWord tid = cap->rCurrentTSO->id;
3145 PushTaggedWord(tid);
3148 case i_cmpThreadIds:
3150 StgWord tid1 = PopTaggedWord();
3151 StgWord tid2 = PopTaggedWord();
3152 if (tid1 < tid2) PushTaggedInt(-1);
3153 else if (tid1 > tid2) PushTaggedInt(1);
3154 else PushTaggedInt(0);
3157 #endif /* PROVIDE_CONCURRENT */
3159 case i_ccall_ccall_Id:
3160 case i_ccall_ccall_IO:
3161 case i_ccall_stdcall_Id:
3162 case i_ccall_stdcall_IO:
3165 CFunDescriptor* descriptor;
3166 void (*funPtr)(void);
3168 descriptor = PopTaggedAddr();
3169 funPtr = PopTaggedAddr();
3170 cc = (primop2code == i_ccall_stdcall_Id ||
3171 primop2code == i_ccall_stdcall_IO)
3173 r = ccall(descriptor,funPtr,bco,cc,cap);
3176 return makeErrorCall(
3177 "unhandled type or too many args/results in ccall");
3179 barf("ccall not configured correctly for this platform");
3180 barf("unknown return code from ccall");
3183 barf("Unrecognised primop2");
3189 /* -----------------------------------------------------------------------------
3190 * ccall support code:
3191 * marshall moves args from C stack to Haskell stack
3192 * unmarshall moves args from Haskell stack to C stack
3193 * argSize calculates how much gSpace you need on the C stack
3194 * ---------------------------------------------------------------------------*/
3196 /* Pop arguments off the C stack and Push them onto the Hugs stack.
3197 * Used when preparing for C calling Haskell or in regSponse to
3198 * Haskell calling C.
3200 nat marshall(char arg_ty, void* arg)
3204 PushTaggedInt(*((int*)arg));
3205 return ARG_SIZE(INT_TAG);
3208 PushTaggedInteger(*((mpz_ptr*)arg));
3209 return ARG_SIZE(INTEGER_TAG);
3212 PushTaggedWord(*((unsigned int*)arg));
3213 return ARG_SIZE(WORD_TAG);
3215 PushTaggedChar(*((char*)arg));
3216 return ARG_SIZE(CHAR_TAG);
3218 PushTaggedFloat(*((float*)arg));
3219 return ARG_SIZE(FLOAT_TAG);
3221 PushTaggedDouble(*((double*)arg));
3222 return ARG_SIZE(DOUBLE_TAG);
3224 PushTaggedAddr(*((void**)arg));
3225 return ARG_SIZE(ADDR_TAG);
3227 PushTaggedStablePtr(*((StgStablePtr*)arg));
3228 return ARG_SIZE(STABLE_TAG);
3229 #ifdef PROVIDE_FOREIGN
3231 /* Not allowed in this direction - you have to
3232 * call makeForeignPtr explicitly
3234 barf("marshall: ForeignPtr#\n");
3239 /* Not allowed in this direction */
3240 barf("marshall: [Mutable]ByteArray#\n");
3243 barf("marshall: unrecognised arg type %d\n",arg_ty);
3248 /* Pop arguments off the Hugs stack and Push them onto the C stack.
3249 * Used when preparing for Haskell calling C or in regSponse to
3250 * C calling Haskell.
3252 nat unmarshall(char res_ty, void* res)
3256 *((int*)res) = PopTaggedInt();
3257 return ARG_SIZE(INT_TAG);
3260 *((mpz_ptr*)res) = PopTaggedInteger();
3261 return ARG_SIZE(INTEGER_TAG);
3264 *((unsigned int*)res) = PopTaggedWord();
3265 return ARG_SIZE(WORD_TAG);
3267 *((int*)res) = PopTaggedChar();
3268 return ARG_SIZE(CHAR_TAG);
3270 *((float*)res) = PopTaggedFloat();
3271 return ARG_SIZE(FLOAT_TAG);
3273 *((double*)res) = PopTaggedDouble();
3274 return ARG_SIZE(DOUBLE_TAG);
3276 *((void**)res) = PopTaggedAddr();
3277 return ARG_SIZE(ADDR_TAG);
3279 *((StgStablePtr*)res) = PopTaggedStablePtr();
3280 return ARG_SIZE(STABLE_TAG);
3281 #ifdef PROVIDE_FOREIGN
3284 StgForeignObj *result = stgCast(StgForeignObj*,PopPtr());
3285 *((void**)res) = result->data;
3286 return sizeofW(StgPtr);
3292 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
3293 *((void**)res) = stgCast(void*,&(arr->payload));
3294 return sizeofW(StgPtr);
3297 barf("unmarshall: unrecognised result type %d\n",res_ty);
3301 nat argSize( const char* ks )
3304 for( ; *ks != '\0'; ++ks) {
3307 sz += sizeof(StgWord) * ARG_SIZE(INT_TAG);
3311 sz += sizeof(StgWord) * ARG_SIZE(INTEGER_TAG);
3315 sz += sizeof(StgWord) * ARG_SIZE(WORD_TAG);
3318 sz += sizeof(StgWord) * ARG_SIZE(CHAR_TAG);
3321 sz += sizeof(StgWord) * ARG_SIZE(FLOAT_TAG);
3324 sz += sizeof(StgWord) * ARG_SIZE(DOUBLE_TAG);
3327 sz += sizeof(StgWord) * ARG_SIZE(ADDR_TAG);
3330 sz += sizeof(StgWord) * ARG_SIZE(STABLE_TAG);
3332 #ifdef PROVIDE_FOREIGN
3337 sz += sizeof(StgPtr);
3340 barf("argSize: unrecognised result type %d\n",*ks);
3348 /* -----------------------------------------------------------------------------
3349 * encode/decode Float/Double code for standalone Hugs
3350 * Code based on the HBC code (lib/fltcode.c) and more recently GHC
3351 * (ghc/rts/StgPrimFloat.c)
3352 * ---------------------------------------------------------------------------*/
3354 #if IEEE_FLOATING_POINT
3355 #define MY_DMINEXP ((DBL_MIN_EXP) - (DBL_MANT_DIG) - 1)
3356 /* DMINEXP is defined in values.h on Linux (for example) */
3357 #define DHIGHBIT 0x00100000
3358 #define DMSBIT 0x80000000
3360 #define MY_FMINEXP ((FLT_MIN_EXP) - (FLT_MANT_DIG) - 1)
3361 #define FHIGHBIT 0x00800000
3362 #define FMSBIT 0x80000000
3364 #error The following code doesnt work in a non-IEEE FP environment
3367 #ifdef WORDS_BIGENDIAN
3376 StgDouble B__encodeDouble (B* s, I_ e) /* result = s * 2^e */
3381 /* Convert a B to a double; knows a lot about internal rep! */
3382 for(r = 0.0, i = s->used-1; i >= 0; i--)
3383 r = (r * B_BASE_FLT) + s->stuff[i];
3385 /* Now raise to the exponent */
3386 if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
3389 /* handle the sign */
3390 if (s->sign < 0) r = -r;
3397 #if ! FLOATS_AS_DOUBLES
3398 StgFloat B__encodeFloat (B* s, I_ e) /* result = s * 2^e */
3403 /* Convert a B to a float; knows a lot about internal rep! */
3404 for(r = 0.0, i = s->used-1; i >= 0; i--)
3405 r = (r * B_BASE_FLT) + s->stuff[i];
3407 /* Now raise to the exponent */
3408 if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
3411 /* handle the sign */
3412 if (s->sign < 0) r = -r;
3416 #endif /* FLOATS_AS_DOUBLES */
3420 /* This only supports IEEE floating point */
3421 void B__decodeDouble (B* man, I_* exp, StgDouble dbl)
3423 /* Do some bit fiddling on IEEE */
3424 nat low, high; /* assuming 32 bit ints */
3426 union { double d; int i[2]; } u; /* assuming 32 bit ints, 64 bit double */
3428 u.d = dbl; /* grab chunks of the double */
3432 ASSERT(B_BASE == 256);
3434 /* Assume that the supplied B is the right size */
3437 if (low == 0 && (high & ~DMSBIT) == 0) {
3438 man->sign = man->used = 0;
3443 iexp = ((high >> 20) & 0x7ff) + MY_DMINEXP;
3447 if (iexp != MY_DMINEXP) /* don't add hidden bit to denorms */
3451 /* A denorm, normalize the mantissa */
3452 while (! (high & DHIGHBIT)) {
3462 man->stuff[7] = (((W_)high) >> 24) & 0xff;
3463 man->stuff[6] = (((W_)high) >> 16) & 0xff;
3464 man->stuff[5] = (((W_)high) >> 8) & 0xff;
3465 man->stuff[4] = (((W_)high) ) & 0xff;
3467 man->stuff[3] = (((W_)low) >> 24) & 0xff;
3468 man->stuff[2] = (((W_)low) >> 16) & 0xff;
3469 man->stuff[1] = (((W_)low) >> 8) & 0xff;
3470 man->stuff[0] = (((W_)low) ) & 0xff;
3472 if (sign < 0) man->sign = -1;
3474 do_renormalise(man);
3478 #if ! FLOATS_AS_DOUBLES
3479 void B__decodeFloat (B* man, I_* exp, StgFloat flt)
3481 /* Do some bit fiddling on IEEE */
3482 int high, sign; /* assuming 32 bit ints */
3483 union { float f; int i; } u; /* assuming 32 bit float and int */
3485 u.f = flt; /* grab the float */
3488 ASSERT(B_BASE == 256);
3490 /* Assume that the supplied B is the right size */
3493 if ((high & ~FMSBIT) == 0) {
3494 man->sign = man->used = 0;
3499 *exp = ((high >> 23) & 0xff) + MY_FMINEXP;
3503 if (*exp != MY_FMINEXP) /* don't add hidden bit to denorms */
3507 /* A denorm, normalize the mantissa */
3508 while (! (high & FHIGHBIT)) {
3513 man->stuff[3] = (((W_)high) >> 24) & 0xff;
3514 man->stuff[2] = (((W_)high) >> 16) & 0xff;
3515 man->stuff[1] = (((W_)high) >> 8) & 0xff;
3516 man->stuff[0] = (((W_)high) ) & 0xff;
3518 if (sign < 0) man->sign = -1;
3520 do_renormalise(man);
3523 #endif /* FLOATS_AS_DOUBLES */
3525 #endif /* INTERPRETER */