2 /* -----------------------------------------------------------------------------
5 * Copyright (c) 1994-1998.
7 * $RCSfile: Evaluator.c,v $
9 * $Date: 2000/04/14 15:18:06 $
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) || defined(mingw32_TARGET_OS)
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 SSS; bh = (StgBlockingQueue*)grabHpUpd(BLACKHOLE_sizeW()); LLL;
1360 SET_INFO(bh,&CAF_BLACKHOLE_info);
1361 bh->blocking_queue = EndTSOQueue;
1363 fprintf(stderr,"Created CAF_BLACKHOLE %p for CAF %p"
1364 " in evaluator\n",bh,caf));
1365 SET_INFO(caf,&CAF_ENTERED_info);
1366 caf->value = (StgClosure*)bh;
1368 SSS; newCAF_made_by_Hugs(caf); LLL;
1370 xPushUpdateFrame(bh,0);
1371 xSp -= sizeofW(StgUpdateFrame);
1377 StgCAF* caf = (StgCAF*)obj;
1378 obj = caf->value; /* it's just a fancy indirection */
1384 case SE_CAF_BLACKHOLE:
1386 /* Let the scheduler figure out what to do :-) */
1387 cap->rCurrentTSO->what_next = ThreadEnterGHC;
1389 RETURN(ThreadYielding);
1393 StgAP_UPD* ap = stgCast(StgAP_UPD*,obj);
1395 if (xSp - (i + sizeofW(StgUpdateFrame)) < xSpLim) {
1396 xPushCPtr(obj); /* code to restart with */
1397 RETURN(StackOverflow);
1399 /* ToDo: look for xSp==xSu && stackInt(0) == UPD_FRAME
1400 and insert an indirection immediately */
1401 xPushUpdateFrame(ap,0);
1402 xSp -= sizeofW(StgUpdateFrame);
1404 xPushWord(payloadWord(ap,i));
1407 #ifdef EAGER_BLACKHOLING
1408 #warn LAZY_BLACKHOLING is default for StgHugs
1409 #error Dont know if EAGER_BLACKHOLING works in StgHugs
1411 /* superfluous - but makes debugging easier */
1412 StgBlackHole* bh = stgCast(StgBlackHole*,ap);
1413 SET_INFO(bh,&BLACKHOLE_info);
1414 bh->blocking_queue = EndTSOQueue;
1416 fprintf(stderr,"Eagerly blackholed AP_UPD %p in evaluator\n",bh));
1419 #endif /* EAGER_BLACKHOLING */
1424 StgPAP* pap = stgCast(StgPAP*,obj);
1425 int i = pap->n_args; /* ToDo: stack check */
1426 /* ToDo: if PAP is in whnf, we can update any update frames
1430 xPushWord(payloadWord(pap,i));
1437 obj = stgCast(StgInd*,obj)->indirectee;
1442 obj = stgCast(StgIndOldGen*,obj)->indirectee;
1451 case CONSTR_INTLIKE:
1452 case CONSTR_CHARLIKE:
1454 case CONSTR_NOCAF_STATIC:
1457 switch (get_itbl(stgCast(StgClosure*,xSp))->type) {
1459 SSS; PopCatchFrame(); LLL;
1462 xPopUpdateFrame(obj);
1465 SSS; PopSeqFrame(); LLL;
1469 ASSERT(xSp==(P_)xSu);
1472 fprintf(stderr, "hit a STOP_FRAME\n");
1474 fprintf(stderr,"xSp = %p\txSu = %p\n", xSp, xSu);
1475 printStack(xSp,cap->rCurrentTSO->stack
1476 + cap->rCurrentTSO->stack_size,xSu);
1479 SSS; PopStopFrame(obj); LLL;
1480 RETURN(ThreadFinished);
1490 /* was: goto enterLoop;
1491 But we know that obj must be a bco now, so jump directly.
1494 case RET_SMALL: /* return to GHC */
1498 cap->rCurrentTSO->what_next = ThreadEnterGHC;
1500 RETURN(ThreadYielding);
1502 belch("entered CONSTR with invalid continuation on stack");
1505 printObj(stgCast(StgClosure*,xSp));
1508 barf("bailing out");
1515 //fprintf(stderr, "enterCountI = %d\n", enterCountI);
1516 //fprintf(stderr, "entering unknown closure -- yielding to sched\n");
1519 cap->rCurrentTSO->what_next = ThreadEnterGHC;
1520 xPushCPtr(obj); /* code to restart with */
1521 RETURN(ThreadYielding);
1524 barf("Ran off the end of enter - yoiks");
1541 #undef xSetStackWord
1544 #undef xPushTaggedInt
1545 #undef xPopTaggedInt
1546 #undef xTaggedStackInt
1547 #undef xPushTaggedWord
1548 #undef xPopTaggedWord
1549 #undef xTaggedStackWord
1550 #undef xPushTaggedAddr
1551 #undef xTaggedStackAddr
1552 #undef xPopTaggedAddr
1553 #undef xPushTaggedStable
1554 #undef xTaggedStackStable
1555 #undef xPopTaggedStable
1556 #undef xPushTaggedChar
1557 #undef xTaggedStackChar
1558 #undef xPopTaggedChar
1559 #undef xPushTaggedFloat
1560 #undef xTaggedStackFloat
1561 #undef xPopTaggedFloat
1562 #undef xPushTaggedDouble
1563 #undef xTaggedStackDouble
1564 #undef xPopTaggedDouble
1565 #undef xPopUpdateFrame
1566 #undef xPushUpdateFrame
1569 /* --------------------------------------------------------------------------
1570 * Supporting routines for primops
1571 * ------------------------------------------------------------------------*/
1573 static inline void PushTag ( StackTag t )
1575 inline void PushPtr ( StgPtr x )
1576 { *(--stgCast(StgPtr*,gSp)) = x; }
1577 static inline void PushCPtr ( StgClosure* x )
1578 { *(--stgCast(StgClosure**,gSp)) = x; }
1579 static inline void PushInt ( StgInt x )
1580 { *(--stgCast(StgInt*,gSp)) = x; }
1581 static inline void PushWord ( StgWord x )
1582 { *(--stgCast(StgWord*,gSp)) = x; }
1585 static inline void checkTag ( StackTag t1, StackTag t2 )
1586 { ASSERT(t1 == t2);}
1587 static inline void PopTag ( StackTag t )
1588 { checkTag(t,*(gSp++)); }
1589 inline StgPtr PopPtr ( void )
1590 { return *stgCast(StgPtr*,gSp)++; }
1591 static inline StgClosure* PopCPtr ( void )
1592 { return *stgCast(StgClosure**,gSp)++; }
1593 static inline StgInt PopInt ( void )
1594 { return *stgCast(StgInt*,gSp)++; }
1595 static inline StgWord PopWord ( void )
1596 { return *stgCast(StgWord*,gSp)++; }
1598 static inline StgPtr stackPtr ( StgStackOffset i )
1599 { return *stgCast(StgPtr*, gSp+i); }
1600 static inline StgInt stackInt ( StgStackOffset i )
1601 { return *stgCast(StgInt*, gSp+i); }
1602 static inline StgWord stackWord ( StgStackOffset i )
1603 { return *stgCast(StgWord*,gSp+i); }
1605 static inline void setStackWord ( StgStackOffset i, StgWord w )
1608 static inline void PushTaggedRealWorld( void )
1609 { PushTag(REALWORLD_TAG); }
1610 inline void PushTaggedInt ( StgInt x )
1611 { gSp -= sizeofW(StgInt); *gSp = x; PushTag(INT_TAG); }
1612 inline void PushTaggedWord ( StgWord x )
1613 { gSp -= sizeofW(StgWord); *gSp = x; PushTag(WORD_TAG); }
1614 inline void PushTaggedAddr ( StgAddr x )
1615 { gSp -= sizeofW(StgAddr); *gSp = (W_)x; PushTag(ADDR_TAG); }
1616 inline void PushTaggedChar ( StgChar x )
1617 { gSp -= sizeofW(StgChar); *gSp = stgCast(StgWord,x); PushTag(CHAR_TAG); }
1618 inline void PushTaggedFloat ( StgFloat x )
1619 { gSp -= sizeofW(StgFloat); ASSIGN_FLT(gSp,x); PushTag(FLOAT_TAG); }
1620 inline void PushTaggedDouble ( StgDouble x )
1621 { gSp -= sizeofW(StgDouble); ASSIGN_DBL(gSp,x); PushTag(DOUBLE_TAG); }
1622 inline void PushTaggedStablePtr ( StgStablePtr x )
1623 { gSp -= sizeofW(StgStablePtr); *gSp = x; PushTag(STABLE_TAG); }
1624 static inline void PushTaggedBool ( int x )
1625 { PushTaggedInt(x); }
1629 static inline void PopTaggedRealWorld ( void )
1630 { PopTag(REALWORLD_TAG); }
1631 inline StgInt PopTaggedInt ( void )
1632 { StgInt r; PopTag(INT_TAG); r = *stgCast(StgInt*, gSp);
1633 gSp += sizeofW(StgInt); return r;}
1634 inline StgWord PopTaggedWord ( void )
1635 { StgWord r; PopTag(WORD_TAG); r = *stgCast(StgWord*, gSp);
1636 gSp += sizeofW(StgWord); return r;}
1637 inline StgAddr PopTaggedAddr ( void )
1638 { StgAddr r; PopTag(ADDR_TAG); r = *stgCast(StgAddr*, gSp);
1639 gSp += sizeofW(StgAddr); return r;}
1640 inline StgChar PopTaggedChar ( void )
1641 { StgChar r; PopTag(CHAR_TAG); r = stgCast(StgChar, *gSp);
1642 gSp += sizeofW(StgChar); return r;}
1643 inline StgFloat PopTaggedFloat ( void )
1644 { StgFloat r; PopTag(FLOAT_TAG); r = PK_FLT(gSp);
1645 gSp += sizeofW(StgFloat); return r;}
1646 inline StgDouble PopTaggedDouble ( void )
1647 { StgDouble r; PopTag(DOUBLE_TAG); r = PK_DBL(gSp);
1648 gSp += sizeofW(StgDouble); return r;}
1649 inline StgStablePtr PopTaggedStablePtr ( void )
1650 { StgInt r; PopTag(STABLE_TAG); r = *stgCast(StgStablePtr*, gSp);
1651 gSp += sizeofW(StgStablePtr); return r;}
1655 static inline StgInt taggedStackInt ( StgStackOffset i )
1656 { checkTag(INT_TAG,gSp[i]); return *stgCast(StgInt*, gSp+1+i); }
1657 static inline StgWord taggedStackWord ( StgStackOffset i )
1658 { checkTag(WORD_TAG,gSp[i]); return *stgCast(StgWord*, gSp+1+i); }
1659 static inline StgAddr taggedStackAddr ( StgStackOffset i )
1660 { checkTag(ADDR_TAG,gSp[i]); return *stgCast(StgAddr*, gSp+1+i); }
1661 static inline StgChar taggedStackChar ( StgStackOffset i )
1662 { checkTag(CHAR_TAG,gSp[i]); return stgCast(StgChar, *(gSp+1+i)) ; }
1663 static inline StgFloat taggedStackFloat ( StgStackOffset i )
1664 { checkTag(FLOAT_TAG,gSp[i]); return PK_FLT(gSp+1+i); }
1665 static inline StgDouble taggedStackDouble ( StgStackOffset i )
1666 { checkTag(DOUBLE_TAG,gSp[i]); return PK_DBL(gSp+1+i); }
1667 static inline StgStablePtr taggedStackStable ( StgStackOffset i )
1668 { checkTag(STABLE_TAG,gSp[i]); return *stgCast(StgStablePtr*, gSp+1+i); }
1671 /* --------------------------------------------------------------------------
1674 * Should we allocate from a nursery or use the
1675 * doYouWantToGC/allocate interface? We'd already implemented a
1676 * nursery-style scheme when the doYouWantToGC/allocate interface
1678 * One reason to prefer the doYouWantToGC/allocate interface is to
1679 * support operations which allocate an unknown amount in the heap
1680 * (array ops, gmp ops, etc)
1681 * ------------------------------------------------------------------------*/
1683 static inline StgPtr grabHpUpd( nat size )
1685 ASSERT( size >= MIN_UPD_SIZE + sizeofW(StgHeader) );
1686 #ifdef CRUDE_PROFILING
1687 cp_bill_words ( size );
1689 return allocate(size);
1692 static inline StgPtr grabHpNonUpd( nat size )
1694 ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
1695 #ifdef CRUDE_PROFILING
1696 cp_bill_words ( size );
1698 return allocate(size);
1701 /* --------------------------------------------------------------------------
1702 * Manipulate "update frame" list:
1703 * o Update frames (based on stg_do_update and friends in Updates.hc)
1704 * o Error handling/catching (based on catchzh_fast and friends in Prims.hc)
1705 * o Seq frames (based on seq_frame_entry in Prims.hc)
1707 * ------------------------------------------------------------------------*/
1709 static inline void PopUpdateFrame ( StgClosure* obj )
1711 /* NB: doesn't assume that gSp == gSu */
1713 fprintf(stderr, "Updating ");
1714 printPtr(stgCast(StgPtr,gSu->updatee));
1715 fprintf(stderr, " with ");
1717 fprintf(stderr,"gSp = %p\tgSu = %p\n\n", gSp, gSu);
1719 #ifdef EAGER_BLACKHOLING
1720 #warn LAZY_BLACKHOLING is default for StgHugs
1721 #error Dont know if EAGER_BLACKHOLING works in StgHugs
1722 ASSERT(get_itbl(gSu->updatee)->type == BLACKHOLE
1723 || get_itbl(gSu->updatee)->type == SE_BLACKHOLE
1724 || get_itbl(gSu->updatee)->type == CAF_BLACKHOLE
1725 || get_itbl(gSu->updatee)->type == SE_CAF_BLACKHOLE
1727 #endif /* EAGER_BLACKHOLING */
1728 UPD_IND(gSu->updatee,obj);
1729 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgUpdateFrame);
1733 static inline void PopStopFrame ( StgClosure* obj )
1735 /* Move gSu just off the end of the stack, we're about to gSpam the
1736 * STOP_FRAME with the return value.
1738 gSu = stgCast(StgUpdateFrame*,gSp+1);
1739 *stgCast(StgClosure**,gSp) = obj;
1742 static inline void PushCatchFrame ( StgClosure* handler )
1745 /* ToDo: stack check! */
1746 gSp -= sizeofW(StgCatchFrame);
1747 fp = stgCast(StgCatchFrame*,gSp);
1748 SET_HDR(fp,(StgInfoTable*)&catch_frame_info,CCCS);
1749 fp->handler = handler;
1751 gSu = stgCast(StgUpdateFrame*,fp);
1754 static inline void PopCatchFrame ( void )
1756 /* NB: doesn't assume that gSp == gSu */
1757 /* fprintf(stderr,"Popping catch frame\n"); */
1758 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgCatchFrame);
1759 gSu = stgCast(StgCatchFrame*,gSu)->link;
1762 static inline void PushSeqFrame ( void )
1765 /* ToDo: stack check! */
1766 gSp -= sizeofW(StgSeqFrame);
1767 fp = stgCast(StgSeqFrame*,gSp);
1768 SET_HDR(fp,(StgInfoTable*)&seq_frame_info,CCCS);
1770 gSu = stgCast(StgUpdateFrame*,fp);
1773 static inline void PopSeqFrame ( void )
1775 /* NB: doesn't assume that gSp == gSu */
1776 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgSeqFrame);
1777 gSu = stgCast(StgSeqFrame*,gSu)->link;
1780 static inline StgClosure* raiseAnError ( StgClosure* exception )
1782 /* This closure represents the expression 'primRaise E' where E
1783 * is the exception raised (:: Exception).
1784 * It is used to overwrite all the
1785 * thunks which are currently under evaluation.
1787 HaskellObj primRaiseClosure
1788 = asmClosureOfObject(getHugs_AsmObject_for("primRaise"));
1789 HaskellObj reraiseClosure
1790 = rts_apply ( primRaiseClosure, exception );
1793 switch (get_itbl(gSu)->type) {
1795 UPD_IND(gSu->updatee,reraiseClosure);
1796 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgUpdateFrame);
1802 case CATCH_FRAME: /* found it! */
1804 StgCatchFrame* fp = stgCast(StgCatchFrame*,gSu);
1805 StgClosure *handler = fp->handler;
1807 gSp += sizeofW(StgCatchFrame); /* Pop */
1808 PushCPtr(exception);
1812 barf("raiseError: uncaught exception: STOP_FRAME");
1814 barf("raiseError: weird activation record");
1820 static StgClosure* makeErrorCall ( const char* msg )
1822 /* Note! the msg string should be allocated in a
1823 place which will not get freed -- preferably
1824 read-only data of the program. That's because
1825 the thunk we build here may linger indefinitely.
1826 (thinks: probably not so, but anyway ...)
1829 = asmClosureOfObject(getHugs_AsmObject_for("error"));
1831 = asmClosureOfObject(getHugs_AsmObject_for("hugsprimUnpackString"));
1833 = rts_apply ( unpack, rts_mkAddr ( (void*)msg ) );
1835 = rts_apply ( error, thunk );
1837 (StgClosure*) thunk;
1840 #define raiseIndex(where) makeErrorCall("Array index out of range in " where)
1841 #define raiseDiv0(where) makeErrorCall("Division by zero in " where)
1843 /* --------------------------------------------------------------------------
1845 * ------------------------------------------------------------------------*/
1847 #define OP_CC_B(e) \
1849 unsigned char x = PopTaggedChar(); \
1850 unsigned char y = PopTaggedChar(); \
1851 PushTaggedBool(e); \
1856 unsigned char x = PopTaggedChar(); \
1865 #define OP_IW_I(e) \
1867 StgInt x = PopTaggedInt(); \
1868 StgWord y = PopTaggedWord(); \
1872 #define OP_II_I(e) \
1874 StgInt x = PopTaggedInt(); \
1875 StgInt y = PopTaggedInt(); \
1879 #define OP_II_B(e) \
1881 StgInt x = PopTaggedInt(); \
1882 StgInt y = PopTaggedInt(); \
1883 PushTaggedBool(e); \
1888 PushTaggedAddr(e); \
1893 StgInt x = PopTaggedInt(); \
1894 PushTaggedAddr(e); \
1899 StgInt x = PopTaggedInt(); \
1905 PushTaggedChar(e); \
1910 StgInt x = PopTaggedInt(); \
1911 PushTaggedChar(e); \
1916 PushTaggedWord(e); \
1921 StgInt x = PopTaggedInt(); \
1922 PushTaggedWord(e); \
1927 StgInt x = PopTaggedInt(); \
1928 PushTaggedStablePtr(e); \
1933 PushTaggedFloat(e); \
1938 StgInt x = PopTaggedInt(); \
1939 PushTaggedFloat(e); \
1944 PushTaggedDouble(e); \
1949 StgInt x = PopTaggedInt(); \
1950 PushTaggedDouble(e); \
1953 #define OP_WW_B(e) \
1955 StgWord x = PopTaggedWord(); \
1956 StgWord y = PopTaggedWord(); \
1957 PushTaggedBool(e); \
1960 #define OP_WW_W(e) \
1962 StgWord x = PopTaggedWord(); \
1963 StgWord y = PopTaggedWord(); \
1964 PushTaggedWord(e); \
1969 StgWord x = PopTaggedWord(); \
1975 StgStablePtr x = PopTaggedStablePtr(); \
1981 StgWord x = PopTaggedWord(); \
1982 PushTaggedWord(e); \
1985 #define OP_AA_B(e) \
1987 StgAddr x = PopTaggedAddr(); \
1988 StgAddr y = PopTaggedAddr(); \
1989 PushTaggedBool(e); \
1993 StgAddr x = PopTaggedAddr(); \
1996 #define OP_AI_C(s) \
1998 StgAddr x = PopTaggedAddr(); \
1999 int y = PopTaggedInt(); \
2002 PushTaggedChar(r); \
2004 #define OP_AI_I(s) \
2006 StgAddr x = PopTaggedAddr(); \
2007 int y = PopTaggedInt(); \
2012 #define OP_AI_A(s) \
2014 StgAddr x = PopTaggedAddr(); \
2015 int y = PopTaggedInt(); \
2018 PushTaggedAddr(s); \
2020 #define OP_AI_F(s) \
2022 StgAddr x = PopTaggedAddr(); \
2023 int y = PopTaggedInt(); \
2026 PushTaggedFloat(r); \
2028 #define OP_AI_D(s) \
2030 StgAddr x = PopTaggedAddr(); \
2031 int y = PopTaggedInt(); \
2034 PushTaggedDouble(r); \
2036 #define OP_AI_s(s) \
2038 StgAddr x = PopTaggedAddr(); \
2039 int y = PopTaggedInt(); \
2042 PushTaggedStablePtr(r); \
2044 #define OP_AIC_(s) \
2046 StgAddr x = PopTaggedAddr(); \
2047 int y = PopTaggedInt(); \
2048 StgChar z = PopTaggedChar(); \
2051 #define OP_AII_(s) \
2053 StgAddr x = PopTaggedAddr(); \
2054 int y = PopTaggedInt(); \
2055 StgInt z = PopTaggedInt(); \
2058 #define OP_AIA_(s) \
2060 StgAddr x = PopTaggedAddr(); \
2061 int y = PopTaggedInt(); \
2062 StgAddr z = PopTaggedAddr(); \
2065 #define OP_AIF_(s) \
2067 StgAddr x = PopTaggedAddr(); \
2068 int y = PopTaggedInt(); \
2069 StgFloat z = PopTaggedFloat(); \
2072 #define OP_AID_(s) \
2074 StgAddr x = PopTaggedAddr(); \
2075 int y = PopTaggedInt(); \
2076 StgDouble z = PopTaggedDouble(); \
2079 #define OP_AIs_(s) \
2081 StgAddr x = PopTaggedAddr(); \
2082 int y = PopTaggedInt(); \
2083 StgStablePtr z = PopTaggedStablePtr(); \
2088 #define OP_FF_B(e) \
2090 StgFloat x = PopTaggedFloat(); \
2091 StgFloat y = PopTaggedFloat(); \
2092 PushTaggedBool(e); \
2095 #define OP_FF_F(e) \
2097 StgFloat x = PopTaggedFloat(); \
2098 StgFloat y = PopTaggedFloat(); \
2099 PushTaggedFloat(e); \
2104 StgFloat x = PopTaggedFloat(); \
2105 PushTaggedFloat(e); \
2110 StgFloat x = PopTaggedFloat(); \
2111 PushTaggedBool(e); \
2116 StgFloat x = PopTaggedFloat(); \
2122 StgFloat x = PopTaggedFloat(); \
2123 PushTaggedDouble(e); \
2126 #define OP_DD_B(e) \
2128 StgDouble x = PopTaggedDouble(); \
2129 StgDouble y = PopTaggedDouble(); \
2130 PushTaggedBool(e); \
2133 #define OP_DD_D(e) \
2135 StgDouble x = PopTaggedDouble(); \
2136 StgDouble y = PopTaggedDouble(); \
2137 PushTaggedDouble(e); \
2142 StgDouble x = PopTaggedDouble(); \
2143 PushTaggedBool(e); \
2148 StgDouble x = PopTaggedDouble(); \
2149 PushTaggedDouble(e); \
2154 StgDouble x = PopTaggedDouble(); \
2160 StgDouble x = PopTaggedDouble(); \
2161 PushTaggedFloat(e); \
2165 StgPtr CreateByteArrayToHoldInteger ( int nbytes )
2167 StgWord words = (nbytes+sizeof(W_)-1)/sizeof(W_);
2168 StgWord size = sizeofW(StgArrWords) + words;
2169 StgArrWords* arr = (StgArrWords*)allocate(size);
2170 SET_HDR(arr,&ARR_WORDS_info,CCCS);
2172 ASSERT((W_)nbytes <= arr->words * sizeof(W_));
2175 for (i = 0; i < words; ++i) {
2176 arr->payload[i] = 0xdeadbeef;
2178 { B* b = (B*) &(arr->payload[0]);
2179 b->used = b->sign = 0;
2185 B* IntegerInsideByteArray ( StgPtr arr0 )
2188 StgArrWords* arr = (StgArrWords*)arr0;
2189 ASSERT(GET_INFO(arr) == &ARR_WORDS_info);
2190 b = (B*) &(arr->payload[0]);
2194 void SloppifyIntegerEnd ( StgPtr arr0 )
2196 StgArrWords* arr = (StgArrWords*)arr0;
2197 B* b = (B*) & (arr->payload[0]);
2198 I_ nwunused = arr->words - sizeofW(B) - (b->used+sizeof(W_)-1)/sizeof(W_);
2199 if (nwunused >= ((I_)sizeofW(StgArrWords))) {
2201 b->size -= nwunused * sizeof(W_);
2202 if (b->size < b->used) b->size = b->used;
2205 arr->words -= nwunused;
2206 slop = (StgArrWords*)&(arr->payload[arr->words]);
2207 SET_HDR(slop,&ARR_WORDS_info,CCCS);
2208 slop->words = nwunused - sizeofW(StgArrWords);
2209 ASSERT( &(slop->payload[slop->words]) ==
2210 &(arr->payload[arr->words + nwunused]) );
2214 #define OP_Z_Z(op) \
2216 B* x = IntegerInsideByteArray(PopPtr()); \
2217 int n = mycat2(size_,op)(x); \
2218 StgPtr p = CreateByteArrayToHoldInteger(n); \
2219 mycat2(do_,op)(x,n,IntegerInsideByteArray(p)); \
2220 SloppifyIntegerEnd(p); \
2223 #define OP_ZZ_Z(op) \
2225 B* x = IntegerInsideByteArray(PopPtr()); \
2226 B* y = IntegerInsideByteArray(PopPtr()); \
2227 int n = mycat2(size_,op)(x,y); \
2228 StgPtr p = CreateByteArrayToHoldInteger(n); \
2229 mycat2(do_,op)(x,y,n,IntegerInsideByteArray(p)); \
2230 SloppifyIntegerEnd(p); \
2237 #define HEADER_mI(ty,where) \
2238 StgArrWords* x = stgCast(StgArrWords*,PopPtr()); \
2239 nat i = PopTaggedInt(); \
2240 if (i * sizeof(ty) + (sizeof(ty)) > sizeof(StgWord) * x->words) { \
2241 return (raiseIndex(where)); \
2243 #define OP_mI_ty(ty,where,s) \
2245 HEADER_mI(mycat2(Stg,ty),where) \
2246 { mycat2(Stg,ty) r; \
2248 mycat2(PushTagged,ty)(r); \
2251 #define OP_mIty_(ty,where,s) \
2253 HEADER_mI(mycat2(Stg,ty),where) \
2255 mycat2(Stg,ty) z = mycat2(PopTagged,ty)(); \
2261 static void myStackCheck ( Capability* cap )
2263 /* fprintf(stderr, "myStackCheck\n"); */
2264 if (!(gSpLim <= gSp && gSp <= stgCast(StgPtr,gSu))) {
2265 fprintf(stderr, "myStackCheck: invalid initial gSp/gSu \n" );
2269 if (!( (P_)gSu >= (P_)cap->rCurrentTSO->stack
2271 (P_)gSu <= (P_)(cap->rCurrentTSO->stack
2272 + cap->rCurrentTSO->stack_size))) {
2273 fprintf ( stderr, "myStackCheck: gSu out of stack\n" );
2276 switch (get_itbl(stgCast(StgClosure*,gSu))->type) {
2278 gSu = (StgUpdateFrame*) ((StgCatchFrame*)(gSu))->link;
2281 gSu = (StgUpdateFrame*) ((StgUpdateFrame*)(gSu))->link;
2284 gSu = (StgUpdateFrame*) ((StgSeqFrame*)(gSu))->link;
2289 fprintf(stderr, "myStackCheck: invalid activation record\n"); assert(0);
2296 /* --------------------------------------------------------------------------
2297 * Primop stuff for bytecode interpreter
2298 * ------------------------------------------------------------------------*/
2300 /* Returns & of the next thing to enter (if throwing an exception),
2301 or NULL in the normal case.
2303 static void* enterBCO_primop1 ( int primop1code )
2306 barf("enterBCO_primop1 in combined mode");
2308 switch (primop1code) {
2309 case i_pushseqframe:
2311 StgClosure* c = PopCPtr();
2316 case i_pushcatchframe:
2318 StgClosure* e = PopCPtr();
2319 StgClosure* h = PopCPtr();
2325 case i_gtChar: OP_CC_B(x>y); break;
2326 case i_geChar: OP_CC_B(x>=y); break;
2327 case i_eqChar: OP_CC_B(x==y); break;
2328 case i_neChar: OP_CC_B(x!=y); break;
2329 case i_ltChar: OP_CC_B(x<y); break;
2330 case i_leChar: OP_CC_B(x<=y); break;
2331 case i_charToInt: OP_C_I(x); break;
2332 case i_intToChar: OP_I_C(x); break;
2334 case i_gtInt: OP_II_B(x>y); break;
2335 case i_geInt: OP_II_B(x>=y); break;
2336 case i_eqInt: OP_II_B(x==y); break;
2337 case i_neInt: OP_II_B(x!=y); break;
2338 case i_ltInt: OP_II_B(x<y); break;
2339 case i_leInt: OP_II_B(x<=y); break;
2340 case i_minInt: OP__I(INT_MIN); break;
2341 case i_maxInt: OP__I(INT_MAX); break;
2342 case i_plusInt: OP_II_I(x+y); break;
2343 case i_minusInt: OP_II_I(x-y); break;
2344 case i_timesInt: OP_II_I(x*y); break;
2347 int x = PopTaggedInt();
2348 int y = PopTaggedInt();
2350 return (raiseDiv0("quotInt"));
2352 /* ToDo: protect against minInt / -1 errors
2353 * (repeat for all other division primops) */
2359 int x = PopTaggedInt();
2360 int y = PopTaggedInt();
2362 return (raiseDiv0("remInt"));
2369 StgInt x = PopTaggedInt();
2370 StgInt y = PopTaggedInt();
2372 return (raiseDiv0("quotRemInt"));
2374 PushTaggedInt(x%y); /* last result */
2375 PushTaggedInt(x/y); /* first result */
2378 case i_negateInt: OP_I_I(-x); break;
2380 case i_andInt: OP_II_I(x&y); break;
2381 case i_orInt: OP_II_I(x|y); break;
2382 case i_xorInt: OP_II_I(x^y); break;
2383 case i_notInt: OP_I_I(~x); break;
2384 case i_shiftLInt: OP_II_I(x<<y); break;
2385 case i_shiftRAInt: OP_II_I(x>>y); break; /* ToDo */
2386 case i_shiftRLInt: OP_II_I(x>>y); break; /* ToDo */
2388 case i_gtWord: OP_WW_B(x>y); break;
2389 case i_geWord: OP_WW_B(x>=y); break;
2390 case i_eqWord: OP_WW_B(x==y); break;
2391 case i_neWord: OP_WW_B(x!=y); break;
2392 case i_ltWord: OP_WW_B(x<y); break;
2393 case i_leWord: OP_WW_B(x<=y); break;
2394 case i_minWord: OP__W(0); break;
2395 case i_maxWord: OP__W(UINT_MAX); break;
2396 case i_plusWord: OP_WW_W(x+y); break;
2397 case i_minusWord: OP_WW_W(x-y); break;
2398 case i_timesWord: OP_WW_W(x*y); break;
2401 StgWord x = PopTaggedWord();
2402 StgWord y = PopTaggedWord();
2404 return (raiseDiv0("quotWord"));
2406 PushTaggedWord(x/y);
2411 StgWord x = PopTaggedWord();
2412 StgWord y = PopTaggedWord();
2414 return (raiseDiv0("remWord"));
2416 PushTaggedWord(x%y);
2421 StgWord x = PopTaggedWord();
2422 StgWord y = PopTaggedWord();
2424 return (raiseDiv0("quotRemWord"));
2426 PushTaggedWord(x%y); /* last result */
2427 PushTaggedWord(x/y); /* first result */
2430 case i_negateWord: OP_W_W(-x); break;
2431 case i_andWord: OP_WW_W(x&y); break;
2432 case i_orWord: OP_WW_W(x|y); break;
2433 case i_xorWord: OP_WW_W(x^y); break;
2434 case i_notWord: OP_W_W(~x); break;
2435 case i_shiftLWord: OP_WW_W(x<<y); break;
2436 case i_shiftRAWord: OP_WW_W(x>>y); break; /* ToDo */
2437 case i_shiftRLWord: OP_WW_W(x>>y); break; /* ToDo */
2438 case i_intToWord: OP_I_W(x); break;
2439 case i_wordToInt: OP_W_I(x); break;
2441 case i_gtAddr: OP_AA_B(x>y); break;
2442 case i_geAddr: OP_AA_B(x>=y); break;
2443 case i_eqAddr: OP_AA_B(x==y); break;
2444 case i_neAddr: OP_AA_B(x!=y); break;
2445 case i_ltAddr: OP_AA_B(x<y); break;
2446 case i_leAddr: OP_AA_B(x<=y); break;
2447 case i_intToAddr: OP_I_A((StgAddr)x); break; /* ToDo */
2448 case i_addrToInt: OP_A_I((StgInt)x); break; /* ToDo */
2450 case i_intToStable: OP_I_s(x); break;
2451 case i_stableToInt: OP_s_I(x); break;
2453 case i_indexCharOffAddr: OP_AI_C(indexCharOffAddrzh(r,x,y)); break;
2454 case i_readCharOffAddr: OP_AI_C(indexCharOffAddrzh(r,x,y)); break;
2455 case i_writeCharOffAddr: OP_AIC_(writeCharOffAddrzh(x,y,z)); break;
2457 case i_indexIntOffAddr: OP_AI_I(indexIntOffAddrzh(r,x,y)); break;
2458 case i_readIntOffAddr: OP_AI_I(indexIntOffAddrzh(r,x,y)); break;
2459 case i_writeIntOffAddr: OP_AII_(writeIntOffAddrzh(x,y,z)); break;
2461 case i_indexAddrOffAddr: OP_AI_A(indexAddrOffAddrzh(r,x,y)); break;
2462 case i_readAddrOffAddr: OP_AI_A(indexAddrOffAddrzh(r,x,y)); break;
2463 case i_writeAddrOffAddr: OP_AIA_(writeAddrOffAddrzh(x,y,z)); break;
2465 case i_indexFloatOffAddr: OP_AI_F(indexFloatOffAddrzh(r,x,y)); break;
2466 case i_readFloatOffAddr: OP_AI_F(indexFloatOffAddrzh(r,x,y)); break;
2467 case i_writeFloatOffAddr: OP_AIF_(writeFloatOffAddrzh(x,y,z)); break;
2469 case i_indexDoubleOffAddr: OP_AI_D(indexDoubleOffAddrzh(r,x,y)); break;
2470 case i_readDoubleOffAddr: OP_AI_D(indexDoubleOffAddrzh(r,x,y)); break;
2471 case i_writeDoubleOffAddr: OP_AID_(writeDoubleOffAddrzh(x,y,z)); break;
2473 case i_indexStableOffAddr: OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break;
2474 case i_readStableOffAddr: OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break;
2475 case i_writeStableOffAddr: OP_AIs_(writeStablePtrOffAddrzh(x,y,z)); break;
2477 case i_compareInteger:
2479 B* x = IntegerInsideByteArray(PopPtr());
2480 B* y = IntegerInsideByteArray(PopPtr());
2481 StgInt r = do_cmp(x,y);
2482 PushTaggedInt(r<0 ? -1 : (r>0 ? 1 : 0));
2485 case i_negateInteger: OP_Z_Z(neg); break;
2486 case i_plusInteger: OP_ZZ_Z(add); break;
2487 case i_minusInteger: OP_ZZ_Z(sub); break;
2488 case i_timesInteger: OP_ZZ_Z(mul); break;
2489 case i_quotRemInteger:
2491 B* x = IntegerInsideByteArray(PopPtr());
2492 B* y = IntegerInsideByteArray(PopPtr());
2493 int n = size_qrm(x,y);
2494 StgPtr q = CreateByteArrayToHoldInteger(n);
2495 StgPtr r = CreateByteArrayToHoldInteger(n);
2496 if (do_getsign(y)==0)
2497 return (raiseDiv0("quotRemInteger"));
2498 do_qrm(x,y,n,IntegerInsideByteArray(q),
2499 IntegerInsideByteArray(r));
2500 SloppifyIntegerEnd(q);
2501 SloppifyIntegerEnd(r);
2506 case i_intToInteger:
2508 int n = size_fromInt();
2509 StgPtr p = CreateByteArrayToHoldInteger(n);
2510 do_fromInt( PopTaggedInt(), n, IntegerInsideByteArray(p));
2514 case i_wordToInteger:
2516 int n = size_fromWord();
2517 StgPtr p = CreateByteArrayToHoldInteger(n);
2518 do_fromWord( PopTaggedWord(), n, IntegerInsideByteArray(p));
2522 case i_integerToInt: PushTaggedInt(do_toInt(
2523 IntegerInsideByteArray(PopPtr())
2527 case i_integerToWord: PushTaggedWord(do_toWord(
2528 IntegerInsideByteArray(PopPtr())
2532 case i_integerToFloat: PushTaggedFloat(do_toFloat(
2533 IntegerInsideByteArray(PopPtr())
2537 case i_integerToDouble: PushTaggedDouble(do_toDouble(
2538 IntegerInsideByteArray(PopPtr())
2542 case i_gtFloat: OP_FF_B(x>y); break;
2543 case i_geFloat: OP_FF_B(x>=y); break;
2544 case i_eqFloat: OP_FF_B(x==y); break;
2545 case i_neFloat: OP_FF_B(x!=y); break;
2546 case i_ltFloat: OP_FF_B(x<y); break;
2547 case i_leFloat: OP_FF_B(x<=y); break;
2548 case i_minFloat: OP__F(FLT_MIN); break;
2549 case i_maxFloat: OP__F(FLT_MAX); break;
2550 case i_radixFloat: OP__I(FLT_RADIX); break;
2551 case i_digitsFloat: OP__I(FLT_MANT_DIG); break;
2552 case i_minExpFloat: OP__I(FLT_MIN_EXP); break;
2553 case i_maxExpFloat: OP__I(FLT_MAX_EXP); break;
2554 case i_plusFloat: OP_FF_F(x+y); break;
2555 case i_minusFloat: OP_FF_F(x-y); break;
2556 case i_timesFloat: OP_FF_F(x*y); break;
2559 StgFloat x = PopTaggedFloat();
2560 StgFloat y = PopTaggedFloat();
2561 PushTaggedFloat(x/y);
2564 case i_negateFloat: OP_F_F(-x); break;
2565 case i_floatToInt: OP_F_I(x); break;
2566 case i_intToFloat: OP_I_F(x); break;
2567 case i_expFloat: OP_F_F(exp(x)); break;
2568 case i_logFloat: OP_F_F(log(x)); break;
2569 case i_sqrtFloat: OP_F_F(sqrt(x)); break;
2570 case i_sinFloat: OP_F_F(sin(x)); break;
2571 case i_cosFloat: OP_F_F(cos(x)); break;
2572 case i_tanFloat: OP_F_F(tan(x)); break;
2573 case i_asinFloat: OP_F_F(asin(x)); break;
2574 case i_acosFloat: OP_F_F(acos(x)); break;
2575 case i_atanFloat: OP_F_F(atan(x)); break;
2576 case i_sinhFloat: OP_F_F(sinh(x)); break;
2577 case i_coshFloat: OP_F_F(cosh(x)); break;
2578 case i_tanhFloat: OP_F_F(tanh(x)); break;
2579 case i_powerFloat: OP_FF_F(pow(x,y)); break;
2581 case i_encodeFloatZ:
2583 StgPtr sig = PopPtr();
2584 StgInt exp = PopTaggedInt();
2586 B__encodeFloat(IntegerInsideByteArray(sig), exp)
2590 case i_decodeFloatZ:
2592 StgFloat f = PopTaggedFloat();
2593 StgPtr sig = CreateByteArrayToHoldInteger(size_fltmantissa());
2595 B__decodeFloat(IntegerInsideByteArray(sig), &exp, f);
2601 case i_isNaNFloat: OP_F_B(isFloatNaN(x)); break;
2602 case i_isInfiniteFloat: OP_F_B(isFloatInfinite(x)); break;
2603 case i_isNegativeZeroFloat: OP_F_B(isFloatNegativeZero(x)); break;
2604 case i_isDenormalizedFloat: OP_F_B(isFloatDenormalized(x)); break;
2605 case i_gtDouble: OP_DD_B(x>y); break;
2606 case i_geDouble: OP_DD_B(x>=y); break;
2607 case i_eqDouble: OP_DD_B(x==y); break;
2608 case i_neDouble: OP_DD_B(x!=y); break;
2609 case i_ltDouble: OP_DD_B(x<y); break;
2610 case i_leDouble: OP_DD_B(x<=y) break;
2611 case i_minDouble: OP__D(DBL_MIN); break;
2612 case i_maxDouble: OP__D(DBL_MAX); break;
2613 case i_radixDouble: OP__I(FLT_RADIX); break;
2614 case i_digitsDouble: OP__I(DBL_MANT_DIG); break;
2615 case i_minExpDouble: OP__I(DBL_MIN_EXP); break;
2616 case i_maxExpDouble: OP__I(DBL_MAX_EXP); break;
2617 case i_plusDouble: OP_DD_D(x+y); break;
2618 case i_minusDouble: OP_DD_D(x-y); break;
2619 case i_timesDouble: OP_DD_D(x*y); break;
2620 case i_divideDouble:
2622 StgDouble x = PopTaggedDouble();
2623 StgDouble y = PopTaggedDouble();
2624 PushTaggedDouble(x/y);
2627 case i_negateDouble: OP_D_D(-x); break;
2628 case i_doubleToInt: OP_D_I(x); break;
2629 case i_intToDouble: OP_I_D(x); break;
2630 case i_doubleToFloat: OP_D_F(x); break;
2631 case i_floatToDouble: OP_F_F(x); break;
2632 case i_expDouble: OP_D_D(exp(x)); break;
2633 case i_logDouble: OP_D_D(log(x)); break;
2634 case i_sqrtDouble: OP_D_D(sqrt(x)); break;
2635 case i_sinDouble: OP_D_D(sin(x)); break;
2636 case i_cosDouble: OP_D_D(cos(x)); break;
2637 case i_tanDouble: OP_D_D(tan(x)); break;
2638 case i_asinDouble: OP_D_D(asin(x)); break;
2639 case i_acosDouble: OP_D_D(acos(x)); break;
2640 case i_atanDouble: OP_D_D(atan(x)); break;
2641 case i_sinhDouble: OP_D_D(sinh(x)); break;
2642 case i_coshDouble: OP_D_D(cosh(x)); break;
2643 case i_tanhDouble: OP_D_D(tanh(x)); break;
2644 case i_powerDouble: OP_DD_D(pow(x,y)); break;
2646 case i_encodeDoubleZ:
2648 StgPtr sig = PopPtr();
2649 StgInt exp = PopTaggedInt();
2651 B__encodeDouble(IntegerInsideByteArray(sig), exp)
2655 case i_decodeDoubleZ:
2657 StgDouble d = PopTaggedDouble();
2658 StgPtr sig = CreateByteArrayToHoldInteger(size_dblmantissa());
2660 B__decodeDouble(IntegerInsideByteArray(sig), &exp, d);
2666 case i_isNaNDouble: OP_D_B(isDoubleNaN(x)); break;
2667 case i_isInfiniteDouble: OP_D_B(isDoubleInfinite(x)); break;
2668 case i_isNegativeZeroDouble: OP_D_B(isDoubleNegativeZero(x)); break;
2669 case i_isDenormalizedDouble: OP_D_B(isDoubleDenormalized(x)); break;
2670 case i_isIEEEDouble:
2672 PushTaggedBool(rtsTrue);
2676 barf("Unrecognised primop1");
2683 /* For normal cases, return NULL and leave *return2 unchanged.
2684 To return the address of the next thing to enter,
2685 return the address of it and leave *return2 unchanged.
2686 To return a StgThreadReturnCode to the scheduler,
2687 set *return2 to it and return a non-NULL value.
2688 To cause a context switch, set context_switch (its a global),
2689 and optionally set hugsBlock to your rational.
2691 static void* enterBCO_primop2 ( int primop2code,
2692 int* /*StgThreadReturnCode* */ return2,
2695 HugsBlock *hugsBlock )
2698 /* A small concession: we need to allow ccalls,
2699 even in combined mode.
2701 if (primop2code != i_ccall_ccall_IO &&
2702 primop2code != i_ccall_stdcall_IO)
2703 barf("enterBCO_primop2 in combined mode");
2706 switch (primop2code) {
2707 case i_raise: /* raise#{err} */
2709 StgClosure* err = PopCPtr();
2710 return (raiseAnError(err));
2715 StgClosure* init = PopCPtr();
2717 = stgCast(StgMutVar*,allocate(sizeofW(StgMutVar)));
2718 SET_HDR(mv,&MUT_VAR_info,CCCS);
2720 PushPtr(stgCast(StgPtr,mv));
2725 StgMutVar* mv = stgCast(StgMutVar*,PopPtr());
2731 StgMutVar* mv = stgCast(StgMutVar*,PopPtr());
2732 StgClosure* value = PopCPtr();
2738 nat n = PopTaggedInt(); /* or Word?? */
2739 StgClosure* init = PopCPtr();
2740 StgWord size = sizeofW(StgMutArrPtrs) + n;
2743 = stgCast(StgMutArrPtrs*,allocate(size));
2744 SET_HDR(arr,&MUT_ARR_PTRS_info,CCCS);
2746 for (i = 0; i < n; ++i) {
2747 arr->payload[i] = init;
2749 PushPtr(stgCast(StgPtr,arr));
2755 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2756 nat i = PopTaggedInt(); /* or Word?? */
2757 StgWord n = arr->ptrs;
2759 return (raiseIndex("{index,read}Array"));
2761 PushCPtr(arr->payload[i]);
2766 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2767 nat i = PopTaggedInt(); /* or Word? */
2768 StgClosure* v = PopCPtr();
2769 StgWord n = arr->ptrs;
2771 return (raiseIndex("{index,read}Array"));
2773 arr->payload[i] = v;
2777 case i_sizeMutableArray:
2779 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2780 PushTaggedInt(arr->ptrs);
2783 case i_unsafeFreezeArray:
2785 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2786 SET_INFO(arr,&MUT_ARR_PTRS_FROZEN_info);
2787 PushPtr(stgCast(StgPtr,arr));
2790 case i_unsafeFreezeByteArray:
2792 /* Delightfully simple :-) */
2796 case i_sameMutableArray:
2797 case i_sameMutableByteArray:
2799 StgPtr x = PopPtr();
2800 StgPtr y = PopPtr();
2801 PushTaggedBool(x==y);
2805 case i_newByteArray:
2807 nat n = PopTaggedInt(); /* or Word?? */
2808 StgInt words = (n+sizeof(W_)-1)/sizeof(W_);
2809 StgWord size = sizeofW(StgArrWords) + words;
2810 StgArrWords* arr = stgCast(StgArrWords*,allocate(size));
2811 SET_HDR(arr,&ARR_WORDS_info,CCCS);
2815 for (i = 0; i < n; ++i) {
2816 arr->payload[i] = 0xdeadbeef;
2819 PushPtr(stgCast(StgPtr,arr));
2823 /* Most of these generate alignment warnings on Sparcs and similar architectures.
2824 * These are harmless and are caused by the cast to C* in BYTE_ARR_CTS.
2826 case i_indexCharArray:
2827 OP_mI_ty(Char,"indexCharArray", indexCharArrayzh(r,x,i)); break;
2828 case i_readCharArray:
2829 OP_mI_ty(Char,"readCharArray", readCharArrayzh(r,x,i)); break;
2830 case i_writeCharArray:
2831 OP_mIty_(Char,"writeCharArray", writeCharArrayzh(x,i,z)); break;
2833 case i_indexIntArray:
2834 OP_mI_ty(Int,"indexIntArray", indexIntArrayzh(r,x,i)); break;
2835 case i_readIntArray:
2836 OP_mI_ty(Int,"readIntArray", readIntArrayzh(r,x,i)); break;
2837 case i_writeIntArray:
2838 OP_mIty_(Int,"writeIntArray", writeIntArrayzh(x,i,z)); break;
2840 case i_indexAddrArray:
2841 OP_mI_ty(Addr,"indexAddrArray", indexAddrArrayzh(r,x,i)); break;
2842 case i_readAddrArray:
2843 OP_mI_ty(Addr,"readAddrArray", readAddrArrayzh(r,x,i)); break;
2844 case i_writeAddrArray:
2845 OP_mIty_(Addr,"writeAddrArray", writeAddrArrayzh(x,i,z)); break;
2847 case i_indexFloatArray:
2848 OP_mI_ty(Float,"indexFloatArray", indexFloatArrayzh(r,x,i)); break;
2849 case i_readFloatArray:
2850 OP_mI_ty(Float,"readFloatArray", readFloatArrayzh(r,x,i)); break;
2851 case i_writeFloatArray:
2852 OP_mIty_(Float,"writeFloatArray", writeFloatArrayzh(x,i,z)); break;
2854 case i_indexDoubleArray:
2855 OP_mI_ty(Double,"indexDoubleArray", indexDoubleArrayzh(r,x,i)); break;
2856 case i_readDoubleArray:
2857 OP_mI_ty(Double,"readDoubleArray", readDoubleArrayzh(r,x,i)); break;
2858 case i_writeDoubleArray:
2859 OP_mIty_(Double,"writeDoubleArray", writeDoubleArrayzh(x,i,z)); break;
2862 #ifdef PROVIDE_STABLE
2863 case i_indexStableArray:
2864 OP_mI_ty(StablePtr,"indexStableArray", indexStablePtrArrayzh(r,x,i)); break;
2865 case i_readStableArray:
2866 OP_mI_ty(StablePtr,"readStableArray", readStablePtrArrayzh(r,x,i)); break;
2867 case i_writeStableArray:
2868 OP_mIty_(StablePtr,"writeStableArray", writeStablePtrArrayzh(x,i,z)); break;
2874 #ifdef PROVIDE_COERCE
2875 case i_unsafeCoerce:
2877 /* Another nullop */
2881 #ifdef PROVIDE_PTREQUALITY
2882 case i_reallyUnsafePtrEquality:
2883 { /* identical to i_sameRef */
2884 StgPtr x = PopPtr();
2885 StgPtr y = PopPtr();
2886 PushTaggedBool(x==y);
2890 #ifdef PROVIDE_FOREIGN
2891 /* ForeignObj# operations */
2892 case i_mkForeignObj:
2894 StgForeignObj *result
2895 = stgCast(StgForeignObj*,allocate(sizeofW(StgForeignObj)));
2896 SET_HDR(result,&FOREIGN_info,CCCS);
2897 result -> data = PopTaggedAddr();
2898 PushPtr(stgCast(StgPtr,result));
2901 #endif /* PROVIDE_FOREIGN */
2906 = stgCast(StgWeak*,allocate(sizeofW(StgWeak)));
2907 SET_HDR(w, &WEAK_info, CCCS);
2909 w->value = PopCPtr();
2910 w->finaliser = PopCPtr();
2911 w->link = weak_ptr_list;
2913 IF_DEBUG(weak, fprintf(stderr,"New weak pointer at %p\n",w));
2914 PushPtr(stgCast(StgPtr,w));
2919 StgWeak *w = stgCast(StgWeak*,PopPtr());
2920 if (w->header.info == &WEAK_info) {
2921 PushCPtr(w->value); /* last result */
2922 PushTaggedInt(1); /* first result */
2924 PushPtr(stgCast(StgPtr,w));
2925 /* ToDo: error thunk would be better */
2930 #endif /* PROVIDE_WEAK */
2932 case i_makeStablePtr:
2934 StgPtr p = PopPtr();
2935 StgStablePtr sp = getStablePtr ( p );
2936 PushTaggedStablePtr(sp);
2939 case i_deRefStablePtr:
2942 StgStablePtr sp = PopTaggedStablePtr();
2943 p = deRefStablePtr(sp);
2947 case i_freeStablePtr:
2949 StgStablePtr sp = PopTaggedStablePtr();
2954 case i_createAdjThunkARCH:
2956 StgStablePtr stableptr = PopTaggedStablePtr();
2957 StgAddr typestr = PopTaggedAddr();
2958 StgChar callconv = PopTaggedChar();
2959 StgAddr adj_thunk = createAdjThunk(stableptr,typestr,callconv);
2960 PushTaggedAddr(adj_thunk);
2966 StgInt n = prog_argc;
2972 StgInt n = PopTaggedInt();
2973 StgAddr a = (StgAddr)prog_argv[n];
2980 StgMVar *mvar = stgCast(StgMVar*,allocate(sizeofW(StgMVar)));
2981 SET_INFO(mvar,&EMPTY_MVAR_info);
2982 mvar->head = mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
2983 mvar->value = stgCast(StgClosure*,&END_TSO_QUEUE_closure);
2984 PushPtr(stgCast(StgPtr,mvar));
2989 StgMVar *mvar = (StgMVar*)PopCPtr();
2990 if (GET_INFO(mvar) == &EMPTY_MVAR_info) {
2992 /* The MVar is empty. Attach ourselves to the TSO's
2995 if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
2996 mvar->head = cap->rCurrentTSO;
2998 mvar->tail->link = cap->rCurrentTSO;
3000 cap->rCurrentTSO->link = (StgTSO *)&END_TSO_QUEUE_closure;
3001 cap->rCurrentTSO->why_blocked = BlockedOnMVar;
3002 cap->rCurrentTSO->block_info.closure = (StgClosure *)mvar;
3003 mvar->tail = cap->rCurrentTSO;
3005 /* At this point, the top-of-stack holds the MVar,
3006 and underneath is the world token (). So the
3007 stack is in the same state as when primTakeMVar
3008 was entered (primTakeMVar is handwritten bytecode).
3009 Push obj, which is this BCO, and return to the
3010 scheduler. When the MVar is filled, the scheduler
3011 will re-enter primTakeMVar, with the args still on
3012 the top of the stack.
3014 PushCPtr((StgClosure*)(*bco));
3015 *return2 = ThreadBlocked;
3016 return (void*)(1+(char*)(NULL));
3019 PushCPtr(mvar->value);
3020 mvar->value = (StgClosure *)&END_TSO_QUEUE_closure;
3021 SET_INFO(mvar,&EMPTY_MVAR_info);
3027 StgMVar* mvar = stgCast(StgMVar*,PopPtr());
3028 StgClosure* value = PopCPtr();
3029 if (GET_INFO(mvar) == &FULL_MVAR_info) {
3030 return (makeErrorCall("putMVar {full MVar}"));
3032 /* wake up the first thread on the
3033 * queue, it will continue with the
3034 * takeMVar operation and mark the
3037 mvar->value = value;
3039 if (mvar->head != (StgTSO *)&END_TSO_QUEUE_closure) {
3040 ASSERT(mvar->head->why_blocked == BlockedOnMVar);
3041 mvar->head = unblockOne(mvar->head);
3042 if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
3043 mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
3047 /* unlocks the MVar in the SMP case */
3048 SET_INFO(mvar,&FULL_MVAR_info);
3050 /* yield for better communication performance */
3056 { /* identical to i_sameRef */
3057 StgMVar* x = (StgMVar*)PopPtr();
3058 StgMVar* y = (StgMVar*)PopPtr();
3059 PushTaggedBool(x==y);
3062 #ifdef PROVIDE_CONCURRENT
3065 StgClosure* closure;
3068 closure = PopCPtr();
3069 tso = createGenThread (RtsFlags.GcFlags.initialStkSize,closure);
3071 scheduleThread(tso);
3073 /* Later: Change to use tso as the ThreadId */
3074 PushTaggedWord(tid);
3080 StgWord n = PopTaggedWord();
3084 // Map from ThreadId to Thread Structure */
3085 for (t = all_threads; t != END_TSO_QUEUE; t = t->global_link) {
3094 while (tso->what_next == ThreadRelocated) {
3099 if (tso == cap->rCurrentTSO) { /* suicide */
3100 *return2 = ThreadFinished;
3101 return (void*)(1+(NULL));
3105 case i_raiseInThread:
3106 ASSERT(0); /* not (yet) supported */
3109 StgInt n = PopTaggedInt();
3111 hugsBlock->reason = BlockedOnDelay;
3112 hugsBlock->delay = n;
3117 StgInt n = PopTaggedInt();
3119 hugsBlock->reason = BlockedOnRead;
3120 hugsBlock->delay = n;
3125 StgInt n = PopTaggedInt();
3127 hugsBlock->reason = BlockedOnWrite;
3128 hugsBlock->delay = n;
3133 /* The definition of yield include an enter right after
3134 * the primYield, at which time context_switch is tested.
3141 StgWord tid = cap->rCurrentTSO->id;
3142 PushTaggedWord(tid);
3145 case i_cmpThreadIds:
3147 StgWord tid1 = PopTaggedWord();
3148 StgWord tid2 = PopTaggedWord();
3149 if (tid1 < tid2) PushTaggedInt(-1);
3150 else if (tid1 > tid2) PushTaggedInt(1);
3151 else PushTaggedInt(0);
3154 #endif /* PROVIDE_CONCURRENT */
3156 case i_ccall_ccall_Id:
3157 case i_ccall_ccall_IO:
3158 case i_ccall_stdcall_Id:
3159 case i_ccall_stdcall_IO:
3162 CFunDescriptor* descriptor;
3163 void (*funPtr)(void);
3165 descriptor = PopTaggedAddr();
3166 funPtr = PopTaggedAddr();
3167 cc = (primop2code == i_ccall_stdcall_Id ||
3168 primop2code == i_ccall_stdcall_IO)
3170 r = ccall(descriptor,funPtr,bco,cc,cap);
3173 return makeErrorCall(
3174 "unhandled type or too many args/results in ccall");
3176 barf("ccall not configured correctly for this platform");
3177 barf("unknown return code from ccall");
3180 barf("Unrecognised primop2");
3186 /* -----------------------------------------------------------------------------
3187 * ccall support code:
3188 * marshall moves args from C stack to Haskell stack
3189 * unmarshall moves args from Haskell stack to C stack
3190 * argSize calculates how much gSpace you need on the C stack
3191 * ---------------------------------------------------------------------------*/
3193 /* Pop arguments off the C stack and Push them onto the Hugs stack.
3194 * Used when preparing for C calling Haskell or in regSponse to
3195 * Haskell calling C.
3197 nat marshall(char arg_ty, void* arg)
3201 PushTaggedInt(*((int*)arg));
3202 return ARG_SIZE(INT_TAG);
3205 PushTaggedInteger(*((mpz_ptr*)arg));
3206 return ARG_SIZE(INTEGER_TAG);
3209 PushTaggedWord(*((unsigned int*)arg));
3210 return ARG_SIZE(WORD_TAG);
3212 PushTaggedChar(*((char*)arg));
3213 return ARG_SIZE(CHAR_TAG);
3215 PushTaggedFloat(*((float*)arg));
3216 return ARG_SIZE(FLOAT_TAG);
3218 PushTaggedDouble(*((double*)arg));
3219 return ARG_SIZE(DOUBLE_TAG);
3221 PushTaggedAddr(*((void**)arg));
3222 return ARG_SIZE(ADDR_TAG);
3224 PushTaggedStablePtr(*((StgStablePtr*)arg));
3225 return ARG_SIZE(STABLE_TAG);
3226 #ifdef PROVIDE_FOREIGN
3228 /* Not allowed in this direction - you have to
3229 * call makeForeignPtr explicitly
3231 barf("marshall: ForeignPtr#\n");
3236 /* Not allowed in this direction */
3237 barf("marshall: [Mutable]ByteArray#\n");
3240 barf("marshall: unrecognised arg type %d\n",arg_ty);
3245 /* Pop arguments off the Hugs stack and Push them onto the C stack.
3246 * Used when preparing for Haskell calling C or in regSponse to
3247 * C calling Haskell.
3249 nat unmarshall(char res_ty, void* res)
3253 *((int*)res) = PopTaggedInt();
3254 return ARG_SIZE(INT_TAG);
3257 *((mpz_ptr*)res) = PopTaggedInteger();
3258 return ARG_SIZE(INTEGER_TAG);
3261 *((unsigned int*)res) = PopTaggedWord();
3262 return ARG_SIZE(WORD_TAG);
3264 *((int*)res) = PopTaggedChar();
3265 return ARG_SIZE(CHAR_TAG);
3267 *((float*)res) = PopTaggedFloat();
3268 return ARG_SIZE(FLOAT_TAG);
3270 *((double*)res) = PopTaggedDouble();
3271 return ARG_SIZE(DOUBLE_TAG);
3273 *((void**)res) = PopTaggedAddr();
3274 return ARG_SIZE(ADDR_TAG);
3276 *((StgStablePtr*)res) = PopTaggedStablePtr();
3277 return ARG_SIZE(STABLE_TAG);
3278 #ifdef PROVIDE_FOREIGN
3281 StgForeignObj *result = stgCast(StgForeignObj*,PopPtr());
3282 *((void**)res) = result->data;
3283 return sizeofW(StgPtr);
3289 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
3290 *((void**)res) = stgCast(void*,&(arr->payload));
3291 return sizeofW(StgPtr);
3294 barf("unmarshall: unrecognised result type %d\n",res_ty);
3298 nat argSize( const char* ks )
3301 for( ; *ks != '\0'; ++ks) {
3304 sz += sizeof(StgWord) * ARG_SIZE(INT_TAG);
3308 sz += sizeof(StgWord) * ARG_SIZE(INTEGER_TAG);
3312 sz += sizeof(StgWord) * ARG_SIZE(WORD_TAG);
3315 sz += sizeof(StgWord) * ARG_SIZE(CHAR_TAG);
3318 sz += sizeof(StgWord) * ARG_SIZE(FLOAT_TAG);
3321 sz += sizeof(StgWord) * ARG_SIZE(DOUBLE_TAG);
3324 sz += sizeof(StgWord) * ARG_SIZE(ADDR_TAG);
3327 sz += sizeof(StgWord) * ARG_SIZE(STABLE_TAG);
3329 #ifdef PROVIDE_FOREIGN
3334 sz += sizeof(StgPtr);
3337 barf("argSize: unrecognised result type %d\n",*ks);
3345 /* -----------------------------------------------------------------------------
3346 * encode/decode Float/Double code for standalone Hugs
3347 * Code based on the HBC code (lib/fltcode.c) and more recently GHC
3348 * (ghc/rts/StgPrimFloat.c)
3349 * ---------------------------------------------------------------------------*/
3351 #if IEEE_FLOATING_POINT
3352 #define MY_DMINEXP ((DBL_MIN_EXP) - (DBL_MANT_DIG) - 1)
3353 /* DMINEXP is defined in values.h on Linux (for example) */
3354 #define DHIGHBIT 0x00100000
3355 #define DMSBIT 0x80000000
3357 #define MY_FMINEXP ((FLT_MIN_EXP) - (FLT_MANT_DIG) - 1)
3358 #define FHIGHBIT 0x00800000
3359 #define FMSBIT 0x80000000
3361 #error The following code doesnt work in a non-IEEE FP environment
3364 #ifdef WORDS_BIGENDIAN
3373 StgDouble B__encodeDouble (B* s, I_ e) /* result = s * 2^e */
3378 /* Convert a B to a double; knows a lot about internal rep! */
3379 for(r = 0.0, i = s->used-1; i >= 0; i--)
3380 r = (r * B_BASE_FLT) + s->stuff[i];
3382 /* Now raise to the exponent */
3383 if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
3386 /* handle the sign */
3387 if (s->sign < 0) r = -r;
3394 #if ! FLOATS_AS_DOUBLES
3395 StgFloat B__encodeFloat (B* s, I_ e) /* result = s * 2^e */
3400 /* Convert a B to a float; knows a lot about internal rep! */
3401 for(r = 0.0, i = s->used-1; i >= 0; i--)
3402 r = (r * B_BASE_FLT) + s->stuff[i];
3404 /* Now raise to the exponent */
3405 if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
3408 /* handle the sign */
3409 if (s->sign < 0) r = -r;
3413 #endif /* FLOATS_AS_DOUBLES */
3417 /* This only supports IEEE floating point */
3418 void B__decodeDouble (B* man, I_* exp, StgDouble dbl)
3420 /* Do some bit fiddling on IEEE */
3421 nat low, high; /* assuming 32 bit ints */
3423 union { double d; int i[2]; } u; /* assuming 32 bit ints, 64 bit double */
3425 u.d = dbl; /* grab chunks of the double */
3429 ASSERT(B_BASE == 256);
3431 /* Assume that the supplied B is the right size */
3434 if (low == 0 && (high & ~DMSBIT) == 0) {
3435 man->sign = man->used = 0;
3440 iexp = ((high >> 20) & 0x7ff) + MY_DMINEXP;
3444 if (iexp != MY_DMINEXP) /* don't add hidden bit to denorms */
3448 /* A denorm, normalize the mantissa */
3449 while (! (high & DHIGHBIT)) {
3459 man->stuff[7] = (((W_)high) >> 24) & 0xff;
3460 man->stuff[6] = (((W_)high) >> 16) & 0xff;
3461 man->stuff[5] = (((W_)high) >> 8) & 0xff;
3462 man->stuff[4] = (((W_)high) ) & 0xff;
3464 man->stuff[3] = (((W_)low) >> 24) & 0xff;
3465 man->stuff[2] = (((W_)low) >> 16) & 0xff;
3466 man->stuff[1] = (((W_)low) >> 8) & 0xff;
3467 man->stuff[0] = (((W_)low) ) & 0xff;
3469 if (sign < 0) man->sign = -1;
3471 do_renormalise(man);
3475 #if ! FLOATS_AS_DOUBLES
3476 void B__decodeFloat (B* man, I_* exp, StgFloat flt)
3478 /* Do some bit fiddling on IEEE */
3479 int high, sign; /* assuming 32 bit ints */
3480 union { float f; int i; } u; /* assuming 32 bit float and int */
3482 u.f = flt; /* grab the float */
3485 ASSERT(B_BASE == 256);
3487 /* Assume that the supplied B is the right size */
3490 if ((high & ~FMSBIT) == 0) {
3491 man->sign = man->used = 0;
3496 *exp = ((high >> 23) & 0xff) + MY_FMINEXP;
3500 if (*exp != MY_FMINEXP) /* don't add hidden bit to denorms */
3504 /* A denorm, normalize the mantissa */
3505 while (! (high & FHIGHBIT)) {
3510 man->stuff[3] = (((W_)high) >> 24) & 0xff;
3511 man->stuff[2] = (((W_)high) >> 16) & 0xff;
3512 man->stuff[1] = (((W_)high) >> 8) & 0xff;
3513 man->stuff[0] = (((W_)high) ) & 0xff;
3515 if (sign < 0) man->sign = -1;
3517 do_renormalise(man);
3520 #endif /* FLOATS_AS_DOUBLES */
3522 #endif /* INTERPRETER */