2 /* -----------------------------------------------------------------------------
5 * Copyright (c) 1994-1998.
7 * $RCSfile: Evaluator.c,v $
9 * $Date: 2000/02/29 12:54:51 $
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} */
26 #include "Evaluator.h"
30 #include "Disassembler.h"
35 #include <math.h> /* These are for primops */
36 #include <limits.h> /* These are for primops */
37 #include <float.h> /* These are for primops */
39 #include <ieee754.h> /* These are for primops */
42 #ifdef STANDALONE_INTEGER
43 #include "sainteger.h"
45 #error Non-standalone integer not yet supported
48 /* An incredibly useful abbreviation.
49 * Interestingly, there are some uses of END_TSO_QUEUE_closure that
50 * can't use it because they use the closure at type StgClosure* or
51 * even StgPtr*. I suspect they should be changed. -- ADR
53 #define EndTSOQueue stgCast(StgTSO*,(void*)&END_TSO_QUEUE_closure)
55 /* These macros are rather delicate - read a good ANSI C book carefully
59 #define mycat(x,y) x##y
60 #define mycat2(x,y) mycat(x,y)
61 #define mycat3(x,y,z) mycat2(x,mycat2(y,z))
63 #if defined(__GNUC__) && !defined(DEBUG)
64 #define USE_GCC_LABELS 1
66 #define USE_GCC_LABELS 0
69 /* Make it possible for the evaluator to get hold of bytecode
70 for a given function by name. Useful but a hack. Sigh.
72 extern void* getHugs_AsmObject_for ( char* s );
73 extern int /*Bool*/ combined;
75 /* --------------------------------------------------------------------------
76 * Crude profiling stuff (mainly to assess effect of optimiser)
77 * ------------------------------------------------------------------------*/
79 #ifdef CRUDE_PROFILING
88 struct { int /*StgVar*/ who;
96 CPRecord cpTab[M_CPTAB];
103 for (i = 0; i < M_CPTAB; i++)
104 cpTab[i].who = CP_NIL;
108 void cp_enter ( StgBCO* b )
112 int /*StgVar*/ v = b->stgexpr;
113 if ((void*)v == NULL) return;
122 h = (-v) % M_CPTAB; else
125 assert (h >= 0 && h < M_CPTAB);
126 while (cpTab[h].who != v && cpTab[h].who != CP_NIL) {
127 h++; if (h == M_CPTAB) h = 0;
130 if (cpTab[cpCurr].who == CP_NIL) {
131 cpTab[cpCurr].who = v;
132 if (!is_ret_cont) cpTab[cpCurr].enters = 1;
133 cpTab[cpCurr].bytes = cpTab[cpCurr].insns = 0;
135 if (cpInUse * 2 > M_CPTAB) {
136 fprintf(stderr, "\nCRUDE_PROFILING hash table is too full\n" );
140 if (!is_ret_cont) cpTab[cpCurr].enters++;
146 void cp_bill_words ( int nw )
148 if (cpCurr == CP_NIL) return;
149 cpTab[cpCurr].bytes += sizeof(StgWord)*nw;
153 void cp_bill_insns ( int ni )
155 if (cpCurr == CP_NIL) return;
156 cpTab[cpCurr].insns += ni;
160 static double percent ( double a, double b )
162 return (100.0 * a) / b;
166 void cp_show ( void )
168 int i, j, max, maxN, totE, totB, totI, cumE, cumB, cumI;
171 if (cpInUse == -1) return;
173 fflush(stdout);fflush(stderr);
176 totE = totB = totI = 0;
177 for (i = 0; i < M_CPTAB; i++) {
178 cpTab[i].twho = cpTab[i].who;
179 if (cpTab[i].who != CP_NIL) {
180 totE += cpTab[i].enters;
181 totB += cpTab[i].bytes;
182 totI += cpTab[i].insns;
187 "%6d (%7.3f M) enters, "
188 "%6d (%7.3f M) insns, "
189 "%6d (%7.3f M) bytes\n\n",
190 totE, totE/1000000.0, totI, totI/1000000.0, totB, totB/1000000.0 );
192 cumE = cumB = cumI = 0;
193 for (j = 0; j < 32; j++) {
196 for (i = 0; i < M_CPTAB; i++)
197 if (cpTab[i].who != CP_NIL &&
198 cpTab[i].enters > maxN) {
199 maxN = cpTab[i].enters;
202 if (max == -1) break;
204 cumE += cpTab[max].enters;
205 cumB += cpTab[max].bytes;
206 cumI += cpTab[max].insns;
208 strcpy(nm, maybeName(cpTab[max].who));
209 if (strcmp(nm, "(unknown)")==0)
210 sprintf ( nm, "id%d", -cpTab[max].who);
212 printf ( "%20s %7d es (%4.1f%%, %4.1f%% c) "
213 "%7d bs (%4.1f%%, %4.1f%% c) "
214 "%7d is (%4.1f%%, %4.1f%% c)\n",
216 cpTab[max].enters, percent(cpTab[max].enters,totE), percent(cumE,totE),
217 cpTab[max].bytes, percent(cpTab[max].bytes,totB), percent(cumB,totB),
218 cpTab[max].insns, percent(cpTab[max].insns,totI), percent(cumI,totI)
221 cpTab[max].twho = cpTab[max].who;
222 cpTab[max].who = CP_NIL;
225 for (i = 0; i < M_CPTAB; i++)
226 cpTab[i].who = cpTab[i].twho;
234 /* --------------------------------------------------------------------------
235 * Hugs Hooks - a bit of a hack
236 * ------------------------------------------------------------------------*/
238 void setRtsFlags( int x );
239 void setRtsFlags( int x )
241 unsigned int w = 0x12345678;
242 unsigned char* pw = (unsigned char *)&w;
245 *(int*)(&(RtsFlags.DebugFlags)) = x;
250 w2 |= (w1 && 0xFF); w2 <<= 8; w1 >>= 8;
251 w2 |= (w1 && 0xFF); w2 <<= 8; w1 >>= 8;
252 w2 |= (w1 && 0xFF); w2 <<= 8; w1 >>= 8;
253 w2 |= (w1 && 0xFF); w2 <<= 8; w1 >>= 8;
254 *(int*)(&(RtsFlags.DebugFlags)) = (int)w2;
259 /* --------------------------------------------------------------------------
260 * Entering-objects and bytecode interpreter part of evaluator
261 * ------------------------------------------------------------------------*/
263 /* The primop (and all other) parts of this evaluator operate upon the
264 machine state which lives in MainRegTable. enter is different:
265 to make its closure- and bytecode-interpreting loops go fast, some of that
266 state is pulled out into local vars (viz, registers, if we are lucky).
267 That means that we need to save(load) the local state at every exit(reentry)
268 into enter. That is, around every procedure call it makes. Blargh!
269 If you modify this code, __be warned__ it will fail in mysterious ways if
270 you fail to preserve this property.
272 Currently the pulled-out state is Sp in xSp, Su in xSu and SpLim in xSpLim.
273 The SSS macros saves the state back in MainRegTable, and LLL loads it from
274 MainRegTable. RETURN(v) does SSS and then returns v; all exits should
275 be via RETURN and not plain return.
277 Since xSp, xSu and xSpLim are local vars in enter, they are not visible
278 in procedures called from enter. To fix this, either (1) turn the
279 procedures into macros, so they get copied inline, or (2) bracket
280 the procedure call with SSS and LLL so that the local and global
281 machine states are synchronised for the duration of the call.
285 /* Forward decls ... */
286 static void* enterBCO_primop1 ( int );
287 static void* enterBCO_primop2 ( int , int* /*StgThreadReturnCode* */,
288 StgBCO**, Capability* );
289 static inline void PopUpdateFrame ( StgClosure* obj );
290 static inline void PopCatchFrame ( void );
291 static inline void PopSeqFrame ( void );
292 static inline void PopStopFrame( StgClosure* obj );
293 static inline void PushTaggedRealWorld( void );
294 /* static inline void PushTaggedInteger ( mpz_ptr ); */
295 static inline StgPtr grabHpUpd( nat size );
296 static inline StgPtr grabHpNonUpd( nat size );
297 static StgClosure* raiseAnError ( StgClosure* exception );
299 static int enterCountI = 0;
301 #ifdef STANDALONE_INTEGER
302 StgDouble B__encodeDouble (B* s, I_ e);
303 void B__decodeDouble (B* man, I_* exp, StgDouble dbl);
304 #if ! FLOATS_AS_DOUBLES
305 StgFloat B__encodeFloat (B* s, I_ e);
306 void B__decodeFloat (B* man, I_* exp, StgFloat flt);
307 StgPtr CreateByteArrayToHoldInteger ( int );
308 B* IntegerInsideByteArray ( StgPtr );
309 void SloppifyIntegerEnd ( StgPtr );
316 #define gSp MainRegTable.rSp
317 #define gSu MainRegTable.rSu
318 #define gSpLim MainRegTable.rSpLim
321 /* Macros to save/load local state. */
323 #define SSS { tSp=gSp = xSp; tSu=gSu = xSu; tSpLim=gSpLim = xSpLim; }
324 #define LLL { tSp=xSp = gSp; tSu=xSu = gSu; tSpLim=xSpLim = gSpLim; }
326 #define SSS { gSp = xSp; gSu = xSu; gSpLim = xSpLim; }
327 #define LLL { xSp = gSp; xSu = gSu; xSpLim = gSpLim; }
330 #define RETURN(vvv) { \
331 StgThreadReturnCode retVal=(vvv); \
333 cap->rCurrentTSO->sp = gSp; \
334 cap->rCurrentTSO->su = gSu; \
335 cap->rCurrentTSO->splim = gSpLim; \
340 /* Macros to operate directly on the pulled-out machine state.
341 These mirror some of the small procedures used in the primop code
342 below, except you have to be careful about side effects,
343 ie xPushPtr(xStackPtr(n)) won't work! It certainly isn't the
344 same as PushPtr(StackPtr(n)). Also note that (1) some of
345 the macros, in particular xPopTagged*, do not make the tag
346 sanity checks that their non-x cousins do, and (2) some of
347 the macros depend critically on the semantics of C comma
348 expressions to work properly.
350 #define xPushPtr(ppp) { xSp--; *xSp=(StgWord)(ppp); }
351 #define xPopPtr() ((StgPtr)(*xSp++))
353 #define xPushCPtr(ppp) { xSp--; *xSp=(StgWord)(ppp); }
354 #define xPopCPtr() ((StgClosure*)(*xSp++))
356 #define xPushWord(ppp) { xSp--; *xSp=(StgWord)(ppp); }
357 #define xPopWord() ((StgWord)(*xSp++))
359 #define xStackPtr(nnn) ((StgPtr)(*(xSp+(nnn))))
360 #define xStackWord(nnn) ((StgWord)(*(xSp+(nnn))))
361 #define xSetStackWord(iii,www) xSp[iii]=(StgWord)(www)
363 #define xPushTag(ttt) { xSp--; *xSp=(StgWord)(ttt); }
364 #define xPopTag(ttt) { StackTag t = (StackTag)(*xSp++); \
367 #define xPushTaggedInt(xxx) { xSp -= sizeofW(StgInt); \
368 *xSp = (xxx); xPushTag(INT_TAG); }
369 #define xTaggedStackInt(iii) ((StgInt)(*(xSp+1+(iii))))
370 #define xPopTaggedInt() ((xSp++,xSp+=sizeofW(StgInt), \
371 (StgInt)(*(xSp-sizeofW(StgInt)))))
373 #define xPushTaggedWord(xxx) { xSp -= sizeofW(StgWord); \
374 *xSp = (xxx); xPushTag(WORD_TAG); }
375 #define xTaggedStackWord(iii) ((StgWord)(*(xSp+1+(iii))))
376 #define xPopTaggedWord() ((xSp++,xSp+=sizeofW(StgWord), \
377 (StgWord)(*(xSp-sizeofW(StgWord)))))
379 #define xPushTaggedAddr(xxx) { xSp -= sizeofW(StgAddr); \
380 *xSp = (StgWord)(xxx); xPushTag(ADDR_TAG); }
381 #define xTaggedStackAddr(iii) ((StgAddr)(*(xSp+1+(iii))))
382 #define xPopTaggedAddr() ((xSp++,xSp+=sizeofW(StgAddr), \
383 (StgAddr)(*(xSp-sizeofW(StgAddr)))))
385 #define xPushTaggedStable(xxx) { xSp -= sizeofW(StgStablePtr); \
386 *xSp = (StgWord)(xxx); xPushTag(STABLE_TAG); }
387 #define xTaggedStackStable(iii) ((StgStablePtr)(*(xSp+1+(iii))))
388 #define xPopTaggedStable() ((xSp++,xSp+=sizeofW(StgStablePtr), \
389 (StgStablePtr)(*(xSp-sizeofW(StgStablePtr)))))
391 #define xPushTaggedChar(xxx) { xSp -= sizeofW(StgChar); \
392 *xSp = (StgWord)(xxx); xPushTag(CHAR_TAG); }
393 #define xTaggedStackChar(iii) ((StgChar)(*(xSp+1+(iii))))
394 #define xPopTaggedChar() ((xSp++,xSp+=sizeofW(StgChar), \
395 (StgChar)(*(xSp-sizeofW(StgChar)))))
397 #define xPushTaggedFloat(xxx) { xSp -= sizeofW(StgFloat); \
398 ASSIGN_FLT(xSp,xxx); xPushTag(FLOAT_TAG); }
399 #define xTaggedStackFloat(iii) PK_FLT(xSp+1+(iii))
400 #define xPopTaggedFloat() ((xSp++,xSp+=sizeofW(StgFloat), \
401 PK_FLT(xSp-sizeofW(StgFloat))))
403 #define xPushTaggedDouble(xxx) { xSp -= sizeofW(StgDouble); \
404 ASSIGN_DBL(xSp,xxx); xPushTag(DOUBLE_TAG); }
405 #define xTaggedStackDouble(iii) PK_DBL(xSp+1+(iii))
406 #define xPopTaggedDouble() ((xSp++,xSp+=sizeofW(StgDouble), \
407 PK_DBL(xSp-sizeofW(StgDouble))))
410 #define xPushUpdateFrame(target, xSp_offset) \
412 StgUpdateFrame *__frame; \
413 __frame = (StgUpdateFrame *)(xSp + (xSp_offset)) - 1; \
414 SET_INFO(__frame, (StgInfoTable *)&Upd_frame_info); \
415 __frame->link = xSu; \
416 __frame->updatee = (StgClosure *)(target); \
420 #define xPopUpdateFrame(ooo) \
422 /* NB: doesn't assume that Sp == Su */ \
423 IF_DEBUG(evaluator, \
424 fprintf(stderr, "Updating "); \
425 printPtr(stgCast(StgPtr,xSu->updatee)); \
426 fprintf(stderr, " with "); \
428 fprintf(stderr,"xSp = %p\txSu = %p\n\n", xSp, xSu); \
430 UPD_IND(xSu->updatee,ooo); \
431 xSp = stgCast(StgStackPtr,xSu) + sizeofW(StgUpdateFrame); \
437 /* Instruction stream macros */
438 #define BCO_INSTR_8 *bciPtr++
439 #define BCO_INSTR_16 ((bciPtr += 2, (*(bciPtr-2) << 8) + *(bciPtr-1)))
440 #define PC (bciPtr - &(bcoInstr(bco,0)))
443 /* State on entry to enter():
444 * - current thread is in cap->rCurrentTSO;
445 * - allocation area is in cap->rCurrentNursery & cap->rNursery
448 StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 )
450 /* use of register here is primarily to make it clear to compilers
451 that these entities are non-aliasable.
453 register StgPtr xSp; /* local state -- stack pointer */
454 register StgUpdateFrame* xSu; /* local state -- frame pointer */
455 register StgPtr xSpLim; /* local state -- stack lim pointer */
456 register StgClosure* obj; /* object currently under evaluation */
457 char eCount; /* enter counter, for context switching */
460 StgPtr tSp; StgUpdateFrame* tSu; StgPtr tSpLim;
463 gSp = cap->rCurrentTSO->sp;
464 gSu = cap->rCurrentTSO->su;
465 gSpLim = cap->rCurrentTSO->splim;
468 /* use the t values to check that Su/Sp/SpLim do not change unexpectedly */
469 tSp = gSp; tSu = gSu; tSpLim = gSpLim;
475 /* Load the local state from global state, and Party On, Dudes! */
476 /* From here onwards, we operate with the local state and
477 save/reload it as necessary.
486 assert(gSpLim == tSpLim);
490 ASSERT(xSpLim <= xSp && xSp <= stgCast(StgPtr,xSu));
492 "\n---------------------------------------------------------------\n");
493 fprintf(stderr,"(%d) Entering: ",enterCountI); printObj(obj);
494 fprintf(stderr,"xSp = %p\txSu = %p\n", xSp, xSu);
495 fprintf(stderr, "\n" );
496 printStack(xSp,cap->rCurrentTSO->stack+cap->rCurrentTSO->stack_size,xSu);
497 fprintf(stderr, "\n\n");
504 ((++eCount) & 0x0F) == 0
509 if (context_switch) {
510 xPushCPtr(obj); /* code to restart with */
511 RETURN(ThreadYielding);
515 switch ( get_itbl(obj)->type ) {
517 barf("Invalid object %p",obj);
521 /* ---------------------------------------------------- */
522 /* Start of the bytecode evaluator */
523 /* ---------------------------------------------------- */
526 # define Ins(x) &&l##x
527 static void *labs[] = { INSTRLIST };
529 # define LoopTopLabel
530 # define Case(x) l##x
531 # define Continue goto *labs[BCO_INSTR_8]
532 # define Dispatch Continue;
535 # define LoopTopLabel insnloop:
536 # define Case(x) case x
537 # define Continue goto insnloop
538 # define Dispatch switch (BCO_INSTR_8) {
539 # define EndDispatch }
542 register StgWord8* bciPtr; /* instruction pointer */
543 register StgBCO* bco = (StgBCO*)obj;
546 /* Don't need to SSS ... LLL around doYouWantToGC */
547 wantToGC = doYouWantToGC();
549 xPushCPtr((StgClosure*)bco); /* code to restart with */
550 RETURN(HeapOverflow);
558 bciPtr = &(bcoInstr(bco,0));
562 ASSERT((StgWord)(PC) < bco->n_instrs);
564 fprintf(stderr,"Sp = %p\tSu = %p\tpc = %d\t", xSp, xSu, PC);
568 fprintf(stderr,"\n");
569 for (i = 8; i >= 0; i--)
570 fprintf(stderr, "%d %p\n", i, (StgPtr)(*(gSp+i)));
572 fprintf(stderr,"\n");
577 SSS; cp_bill_insns(1); LLL;
582 Case(i_INTERNAL_ERROR):
583 barf("INTERNAL_ERROR at %p:%d",bco,PC-1);
585 barf("PANIC at %p:%d",bco,PC-1);
589 if (xSp - n < xSpLim) {
590 xPushCPtr((StgClosure*)bco); /* code to restart with */
591 RETURN(StackOverflow);
595 Case(i_STK_CHECK_big):
597 int n = BCO_INSTR_16;
598 if (xSp - n < xSpLim) {
599 xPushCPtr((StgClosure*)bco); /* code to restart with */
600 RETURN(StackOverflow);
607 if ((StgPtr*)(xSp + n) > (StgPtr*)xSu) {
608 StgWord words = (P_)xSu - xSp;
610 /* first build a PAP */
611 ASSERT((P_)xSu >= xSp); /* was (words >= 0) but that's always true */
612 if (words == 0) { /* optimisation */
613 /* Skip building the PAP and update with an indirection. */
616 /* In the evaluator, we avoid the need to do
617 * a heap check here by including the size of
618 * the PAP in the heap check we performed
619 * when we entered the BCO.
623 SSS; pap = (StgPAP*)grabHpNonUpd(PAP_sizeW(words)); LLL;
624 SET_HDR(pap,&PAP_info,CC_pap);
627 for (i = 0; i < (I_)words; ++i) {
628 payloadWord(pap,i) = xSp[i];
631 obj = stgCast(StgClosure*,pap);
634 /* now deal with "update frame" */
635 /* as an optimisation, we process all on top of stack */
636 /* instead of just the top one */
637 ASSERT(xSp==(P_)xSu);
639 switch (get_itbl(xSu)->type) {
641 /* Hit a catch frame during an arg satisfaction check,
642 * so the thing returning (1) has not thrown an
643 * exception, and (2) is of functional type. Just
644 * zap the catch frame and carry on down the stack
645 * (looking for more arguments, basically).
647 SSS; PopCatchFrame(); LLL;
650 xPopUpdateFrame(obj);
653 SSS; PopStopFrame(obj); LLL;
654 RETURN(ThreadFinished);
656 SSS; PopSeqFrame(); LLL;
657 ASSERT(xSp != (P_)xSu);
658 /* Hit a SEQ frame during an arg satisfaction check.
659 * So now return to bco_info which is under the
660 * SEQ frame. The following code is copied from a
661 * case RET_BCO further down. (The reason why we're
662 * here is that something of functional type has
663 * been seq-d on, and we're now returning to the
664 * algebraic-case-continuation which forced the
665 * evaluation in the first place.)
677 barf("Invalid update frame during argcheck");
679 } while (xSp==(P_)xSu);
687 int words = BCO_INSTR_8;
688 SSS; p = grabHpUpd(AP_sizeW(words)); LLL;
692 Case(i_ALLOC_CONSTR):
695 StgInfoTable* info = bcoConstAddr(bco,BCO_INSTR_8);
696 SSS; p = grabHpNonUpd(sizeW_fromITBL(info)); LLL;
697 SET_HDR((StgClosure*)p,info,??);
701 Case(i_ALLOC_CONSTR_big):
704 int x = BCO_INSTR_16;
705 StgInfoTable* info = bcoConstAddr(bco,x);
706 SSS; p = grabHpNonUpd(sizeW_fromITBL(info)); LLL;
707 SET_HDR((StgClosure*)p,info,??);
713 int x = BCO_INSTR_8; /* ToDo: Word not Int! */
715 StgAP_UPD* o = stgCast(StgAP_UPD*,xStackPtr(x));
716 SET_HDR(o,&AP_UPD_info,??);
718 o->fun = stgCast(StgClosure*,xPopPtr());
719 for(x=0; x < y; ++x) {
720 payloadWord(o,x) = xPopWord();
723 fprintf(stderr,"\tBuilt ");
725 printObj(stgCast(StgClosure*,o));
736 o = stgCast(StgAP_UPD*,xStackPtr(x));
737 SET_HDR(o,&AP_UPD_info,??);
739 o->fun = stgCast(StgClosure*,xPopPtr());
740 for(x=0; x < y; ++x) {
741 payloadWord(o,x) = xPopWord();
744 fprintf(stderr,"\tBuilt ");
746 printObj(stgCast(StgClosure*,o));
755 StgPAP* o = stgCast(StgPAP*,xStackPtr(x));
756 SET_HDR(o,&PAP_info,??);
758 o->fun = stgCast(StgClosure*,xPopPtr());
759 for(x=0; x < y; ++x) {
760 payloadWord(o,x) = xPopWord();
763 fprintf(stderr,"\tBuilt ");
765 printObj(stgCast(StgClosure*,o));
772 int offset = BCO_INSTR_8;
773 StgClosure* o = stgCast(StgClosure*,xStackPtr(offset));
774 const StgInfoTable* info = get_itbl(o);
775 nat p = info->layout.payload.ptrs;
776 nat np = info->layout.payload.nptrs;
778 for(i=0; i < p; ++i) {
779 payloadCPtr(o,i) = xPopCPtr();
781 for(i=0; i < np; ++i) {
782 payloadWord(o,p+i) = 0xdeadbeef;
785 fprintf(stderr,"\tBuilt ");
787 printObj(stgCast(StgClosure*,o));
794 int offset = BCO_INSTR_16;
795 StgClosure* o = stgCast(StgClosure*,xStackPtr(offset));
796 const StgInfoTable* info = get_itbl(o);
797 nat p = info->layout.payload.ptrs;
798 nat np = info->layout.payload.nptrs;
800 for(i=0; i < p; ++i) {
801 payloadCPtr(o,i) = xPopCPtr();
803 for(i=0; i < np; ++i) {
804 payloadWord(o,p+i) = 0xdeadbeef;
807 fprintf(stderr,"\tBuilt ");
809 printObj(stgCast(StgClosure*,o));
818 ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
819 /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
821 xSetStackWord(x+y,xStackWord(x));
831 ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
832 /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
834 xSetStackWord(x+y,xStackWord(x));
846 xPushPtr(bcoConstPtr(bco,BCO_INSTR_8));
847 xPushPtr(stgCast(StgPtr,&ret_bco_info));
852 int tag = BCO_INSTR_8;
853 StgWord offset = BCO_INSTR_16;
854 if (constrTag( (StgClosure*)xStackPtr(0) ) != tag) {
861 StgClosure* o = stgCast(StgClosure*,xStackPtr(0));
862 const StgInfoTable* itbl = get_itbl(o);
863 int i = itbl->layout.payload.ptrs;
864 ASSERT( itbl->type == CONSTR
865 || itbl->type == CONSTR_STATIC
866 || itbl->type == CONSTR_NOCAF_STATIC
867 || itbl->type == CONSTR_1_0
868 || itbl->type == CONSTR_0_1
869 || itbl->type == CONSTR_2_0
870 || itbl->type == CONSTR_1_1
871 || itbl->type == CONSTR_0_2
874 xPushCPtr(payloadCPtr(o,i));
880 int n = BCO_INSTR_16;
881 StgPtr p = xStackPtr(n);
887 StgPtr p = xStackPtr(BCO_INSTR_8);
893 xPushPtr(stgCast(StgPtr,bcoConstPtr(bco,BCO_INSTR_8)));
898 int n = BCO_INSTR_16;
899 xPushPtr(stgCast(StgPtr,bcoConstPtr(bco,n)));
904 SSS; PushTaggedRealWorld(); LLL;
909 StgInt i = xTaggedStackInt(BCO_INSTR_8);
915 xPushTaggedInt(bcoConstInt(bco,BCO_INSTR_8));
918 Case(i_CONST_INT_big):
920 int n = BCO_INSTR_16;
921 xPushTaggedInt(bcoConstInt(bco,n));
927 SSS; o = (StgClosure*)grabHpNonUpd(Izh_sizeW); LLL;
928 SET_HDR(o,&Izh_con_info,??);
929 payloadWord(o,0) = xPopTaggedInt();
931 fprintf(stderr,"\tBuilt ");
933 printObj(stgCast(StgClosure*,o));
936 xPushPtr(stgCast(StgPtr,o));
941 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
942 /* ASSERT(isIntLike(con)); */
943 xPushTaggedInt(payloadWord(con,0));
948 StgWord offset = BCO_INSTR_16;
949 StgInt x = xPopTaggedInt();
950 StgInt y = xPopTaggedInt();
956 Case(i_CONST_INTEGER):
960 char* s = bcoConstAddr(bco,BCO_INSTR_8);
963 p = CreateByteArrayToHoldInteger(n);
964 do_fromStr ( s, n, IntegerInsideByteArray(p));
965 SloppifyIntegerEnd(p);
972 StgWord w = xTaggedStackWord(BCO_INSTR_8);
978 xPushTaggedWord(bcoConstWord(bco,BCO_INSTR_8));
984 SSS; o = (StgClosure*)grabHpNonUpd(Wzh_sizeW); LLL;
985 SET_HDR(o,&Wzh_con_info,??);
986 payloadWord(o,0) = xPopTaggedWord();
988 fprintf(stderr,"\tBuilt ");
990 printObj(stgCast(StgClosure*,o));
993 xPushPtr(stgCast(StgPtr,o));
998 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
999 /* ASSERT(isWordLike(con)); */
1000 xPushTaggedWord(payloadWord(con,0));
1005 StgAddr a = xTaggedStackAddr(BCO_INSTR_8);
1011 xPushTaggedAddr(bcoConstAddr(bco,BCO_INSTR_8));
1014 Case(i_CONST_ADDR_big):
1016 int n = BCO_INSTR_16;
1017 xPushTaggedAddr(bcoConstAddr(bco,n));
1023 SSS; o = (StgClosure*)grabHpNonUpd(Azh_sizeW); LLL;
1024 SET_HDR(o,&Azh_con_info,??);
1025 payloadPtr(o,0) = xPopTaggedAddr();
1027 fprintf(stderr,"\tBuilt ");
1029 printObj(stgCast(StgClosure*,o));
1032 xPushPtr(stgCast(StgPtr,o));
1035 Case(i_UNPACK_ADDR):
1037 StgClosure* con = (StgClosure*)xStackPtr(0);
1038 /* ASSERT(isAddrLike(con)); */
1039 xPushTaggedAddr(payloadPtr(con,0));
1044 StgChar c = xTaggedStackChar(BCO_INSTR_8);
1050 xPushTaggedChar(bcoConstChar(bco,BCO_INSTR_8));
1056 SSS; o = (StgClosure*)grabHpNonUpd(Czh_sizeW); LLL;
1057 SET_HDR(o,&Czh_con_info,??);
1058 payloadWord(o,0) = xPopTaggedChar();
1059 xPushPtr(stgCast(StgPtr,o));
1061 fprintf(stderr,"\tBuilt ");
1063 printObj(stgCast(StgClosure*,o));
1068 Case(i_UNPACK_CHAR):
1070 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1071 /* ASSERT(isCharLike(con)); */
1072 xPushTaggedChar(payloadWord(con,0));
1077 StgFloat f = xTaggedStackFloat(BCO_INSTR_8);
1078 xPushTaggedFloat(f);
1081 Case(i_CONST_FLOAT):
1083 xPushTaggedFloat(bcoConstFloat(bco,BCO_INSTR_8));
1089 SSS; o = (StgClosure*)grabHpNonUpd(Fzh_sizeW); LLL;
1090 SET_HDR(o,&Fzh_con_info,??);
1091 ASSIGN_FLT(&payloadWord(o,0),xPopTaggedFloat());
1093 fprintf(stderr,"\tBuilt ");
1095 printObj(stgCast(StgClosure*,o));
1098 xPushPtr(stgCast(StgPtr,o));
1101 Case(i_UNPACK_FLOAT):
1103 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1104 /* ASSERT(isFloatLike(con)); */
1105 xPushTaggedFloat(PK_FLT(&payloadWord(con,0)));
1110 StgDouble d = xTaggedStackDouble(BCO_INSTR_8);
1111 xPushTaggedDouble(d);
1114 Case(i_CONST_DOUBLE):
1116 xPushTaggedDouble(bcoConstDouble(bco,BCO_INSTR_8));
1119 Case(i_CONST_DOUBLE_big):
1121 int n = BCO_INSTR_16;
1122 xPushTaggedDouble(bcoConstDouble(bco,n));
1125 Case(i_PACK_DOUBLE):
1128 SSS; o = (StgClosure*)grabHpNonUpd(Dzh_sizeW); LLL;
1129 SET_HDR(o,&Dzh_con_info,??);
1130 ASSIGN_DBL(&payloadWord(o,0),xPopTaggedDouble());
1132 fprintf(stderr,"\tBuilt ");
1133 printObj(stgCast(StgClosure*,o));
1135 xPushPtr(stgCast(StgPtr,o));
1138 Case(i_UNPACK_DOUBLE):
1140 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1141 /* ASSERT(isDoubleLike(con)); */
1142 xPushTaggedDouble(PK_DBL(&payloadWord(con,0)));
1147 StgStablePtr s = xTaggedStackStable(BCO_INSTR_8);
1148 xPushTaggedStable(s);
1151 Case(i_PACK_STABLE):
1154 SSS; o = (StgClosure*)grabHpNonUpd(Stablezh_sizeW); LLL;
1155 SET_HDR(o,&StablePtr_con_info,??);
1156 payloadWord(o,0) = xPopTaggedStable();
1158 fprintf(stderr,"\tBuilt ");
1160 printObj(stgCast(StgClosure*,o));
1163 xPushPtr(stgCast(StgPtr,o));
1166 Case(i_UNPACK_STABLE):
1168 StgClosure* con = (StgClosure*)xStackPtr(0);
1169 /* ASSERT(isStableLike(con)); */
1170 xPushTaggedStable(payloadWord(con,0));
1178 SSS; p = enterBCO_primop1 ( i ); LLL;
1179 if (p) { obj = p; goto enterLoop; };
1184 int i, trc, pc_saved;
1187 trc = 12345678; /* Assume != any StgThreadReturnCode */
1192 p = enterBCO_primop2 ( i, &trc, &bco_tmp, cap );
1195 bciPtr = &(bcoInstr(bco,pc_saved));
1197 if (trc == 12345678) {
1198 /* we want to enter p */
1199 obj = p; goto enterLoop;
1201 /* trc is the the StgThreadReturnCode for this thread */
1202 RETURN((StgThreadReturnCode)trc);
1208 /* combined insns, created by peephole opt */
1211 int x = BCO_INSTR_8;
1212 int y = BCO_INSTR_8;
1213 ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
1214 /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
1221 xSetStackWord(x+y,xStackWord(x));
1231 p = xStackPtr(BCO_INSTR_8);
1233 p = xStackPtr(BCO_INSTR_8);
1240 xPushPtr(bcoConstPtr(bco,BCO_INSTR_8));
1241 xPushPtr(stgCast(StgPtr,&ret_bco_info));
1242 p = xStackPtr(BCO_INSTR_8);
1248 StgPtr retaddr = bcoConstPtr(bco,BCO_INSTR_8);
1249 StgPtr ptr = xStackPtr(BCO_INSTR_8);
1251 /* A shortcut. We're going to push the address of a
1252 return continuation, and then enter a variable, so
1253 that when the var is evaluated, we return to the
1254 continuation. The shortcut is: if the var is a
1255 constructor, don't bother to enter it. Instead,
1256 push the variable on the stack (since this is what
1257 the continuation expects) and jump directly to the
1260 if (get_itbl((StgClosure*)ptr)->type == CONSTR) {
1262 obj = (StgClosure*)retaddr;
1264 fprintf(stderr, "object to enter is a constructor -- "
1265 "jumping directly to return continuation\n" );
1270 /* This is the normal, non-short-cut route */
1272 xPushPtr(stgCast(StgPtr,&ret_bco_info));
1273 obj = (StgClosure*)ptr;
1278 Case(i_VAR_DOUBLE_big):
1279 Case(i_CONST_FLOAT_big):
1280 Case(i_VAR_FLOAT_big):
1281 Case(i_CONST_CHAR_big):
1282 Case(i_VAR_CHAR_big):
1283 Case(i_VAR_ADDR_big):
1284 Case(i_VAR_STABLE_big):
1285 Case(i_CONST_INTEGER_big):
1286 Case(i_VAR_INT_big):
1287 Case(i_VAR_WORD_big):
1288 Case(i_RETADDR_big):
1292 disInstr ( bco, PC );
1293 barf("\nUnrecognised instruction");
1297 barf("enterBCO: ran off end of loop");
1301 # undef LoopTopLabel
1307 /* ---------------------------------------------------- */
1308 /* End of the bytecode evaluator */
1309 /* ---------------------------------------------------- */
1313 StgBlockingQueue* bh;
1314 StgCAF* caf = (StgCAF*)obj;
1315 if (xSp - sizeofW(StgUpdateFrame) < xSpLim) {
1316 xPushCPtr(obj); /* code to restart with */
1317 RETURN(StackOverflow);
1319 /* ToDo: look for xSp==xSu && stackInt(0) == UPD_FRAME
1320 and insert an indirection immediately */
1321 SSS; bh = (StgBlockingQueue*)grabHpUpd(BLACKHOLE_sizeW()); LLL;
1322 SET_INFO(bh,&CAF_BLACKHOLE_info);
1323 bh->blocking_queue = EndTSOQueue;
1325 fprintf(stderr,"Created CAF_BLACKHOLE %p for CAF %p in evaluator\n",bh,caf));
1326 SET_INFO(caf,&CAF_ENTERED_info);
1327 caf->value = (StgClosure*)bh;
1328 if (caf->mut_link == NULL) {
1329 SSS; recordOldToNewPtrs((StgMutClosure*)caf); LLL;
1331 xPushUpdateFrame(bh,0);
1332 xSp -= sizeofW(StgUpdateFrame);
1333 caf->link = enteredCAFs;
1340 StgCAF* caf = (StgCAF*)obj;
1341 obj = caf->value; /* it's just a fancy indirection */
1347 case SE_CAF_BLACKHOLE:
1349 /* Let the scheduler figure out what to do :-) */
1350 cap->rCurrentTSO->whatNext = ThreadEnterGHC;
1352 RETURN(ThreadYielding);
1356 StgAP_UPD* ap = stgCast(StgAP_UPD*,obj);
1358 if (xSp - (i + sizeofW(StgUpdateFrame)) < xSpLim) {
1359 xPushCPtr(obj); /* code to restart with */
1360 RETURN(StackOverflow);
1362 /* ToDo: look for xSp==xSu && stackInt(0) == UPD_FRAME
1363 and insert an indirection immediately */
1364 xPushUpdateFrame(ap,0);
1365 xSp -= sizeofW(StgUpdateFrame);
1367 xPushWord(payloadWord(ap,i));
1370 #ifdef EAGER_BLACKHOLING
1371 #warn LAZY_BLACKHOLING is default for StgHugs
1372 #error Dont know if EAGER_BLACKHOLING works in StgHugs
1374 /* superfluous - but makes debugging easier */
1375 StgBlackHole* bh = stgCast(StgBlackHole*,ap);
1376 SET_INFO(bh,&BLACKHOLE_info);
1377 bh->blocking_queue = EndTSOQueue;
1379 fprintf(stderr,"Eagerly blackholed AP_UPD %p in evaluator\n",bh));
1382 #endif /* EAGER_BLACKHOLING */
1387 StgPAP* pap = stgCast(StgPAP*,obj);
1388 int i = pap->n_args; /* ToDo: stack check */
1389 /* ToDo: if PAP is in whnf, we can update any update frames
1393 xPushWord(payloadWord(pap,i));
1400 obj = stgCast(StgInd*,obj)->indirectee;
1405 obj = stgCast(StgIndOldGen*,obj)->indirectee;
1414 case CONSTR_INTLIKE:
1415 case CONSTR_CHARLIKE:
1417 case CONSTR_NOCAF_STATIC:
1420 switch (get_itbl(stgCast(StgClosure*,xSp))->type) {
1422 SSS; PopCatchFrame(); LLL;
1425 xPopUpdateFrame(obj);
1428 SSS; PopSeqFrame(); LLL;
1432 ASSERT(xSp==(P_)xSu);
1435 fprintf(stderr, "hit a STOP_FRAME\n");
1437 fprintf(stderr,"xSp = %p\txSu = %p\n", xSp, xSu);
1438 printStack(xSp,cap->rCurrentTSO->stack
1439 + cap->rCurrentTSO->stack_size,xSu);
1442 SSS; PopStopFrame(obj); LLL;
1443 RETURN(ThreadFinished);
1453 /* was: goto enterLoop;
1454 But we know that obj must be a bco now, so jump directly.
1457 case RET_SMALL: /* return to GHC */
1461 cap->rCurrentTSO->whatNext = ThreadEnterGHC;
1463 RETURN(ThreadYielding);
1465 belch("entered CONSTR with invalid continuation on stack");
1468 printObj(stgCast(StgClosure*,xSp));
1471 barf("bailing out");
1478 //fprintf(stderr, "enterCountI = %d\n", enterCountI);
1479 //fprintf(stderr, "entering unknown closure -- yielding to sched\n");
1482 cap->rCurrentTSO->whatNext = ThreadEnterGHC;
1483 xPushCPtr(obj); /* code to restart with */
1484 RETURN(ThreadYielding);
1487 barf("Ran off the end of enter - yoiks");
1504 #undef xSetStackWord
1507 #undef xPushTaggedInt
1508 #undef xPopTaggedInt
1509 #undef xTaggedStackInt
1510 #undef xPushTaggedWord
1511 #undef xPopTaggedWord
1512 #undef xTaggedStackWord
1513 #undef xPushTaggedAddr
1514 #undef xTaggedStackAddr
1515 #undef xPopTaggedAddr
1516 #undef xPushTaggedStable
1517 #undef xTaggedStackStable
1518 #undef xPopTaggedStable
1519 #undef xPushTaggedChar
1520 #undef xTaggedStackChar
1521 #undef xPopTaggedChar
1522 #undef xPushTaggedFloat
1523 #undef xTaggedStackFloat
1524 #undef xPopTaggedFloat
1525 #undef xPushTaggedDouble
1526 #undef xTaggedStackDouble
1527 #undef xPopTaggedDouble
1528 #undef xPopUpdateFrame
1529 #undef xPushUpdateFrame
1532 /* --------------------------------------------------------------------------
1533 * Supporting routines for primops
1534 * ------------------------------------------------------------------------*/
1536 static inline void PushTag ( StackTag t )
1538 inline void PushPtr ( StgPtr x )
1539 { *(--stgCast(StgPtr*,gSp)) = x; }
1540 static inline void PushCPtr ( StgClosure* x )
1541 { *(--stgCast(StgClosure**,gSp)) = x; }
1542 static inline void PushInt ( StgInt x )
1543 { *(--stgCast(StgInt*,gSp)) = x; }
1544 static inline void PushWord ( StgWord x )
1545 { *(--stgCast(StgWord*,gSp)) = x; }
1548 static inline void checkTag ( StackTag t1, StackTag t2 )
1549 { ASSERT(t1 == t2);}
1550 static inline void PopTag ( StackTag t )
1551 { checkTag(t,*(gSp++)); }
1552 inline StgPtr PopPtr ( void )
1553 { return *stgCast(StgPtr*,gSp)++; }
1554 static inline StgClosure* PopCPtr ( void )
1555 { return *stgCast(StgClosure**,gSp)++; }
1556 static inline StgInt PopInt ( void )
1557 { return *stgCast(StgInt*,gSp)++; }
1558 static inline StgWord PopWord ( void )
1559 { return *stgCast(StgWord*,gSp)++; }
1561 static inline StgPtr stackPtr ( StgStackOffset i )
1562 { return *stgCast(StgPtr*, gSp+i); }
1563 static inline StgInt stackInt ( StgStackOffset i )
1564 { return *stgCast(StgInt*, gSp+i); }
1565 static inline StgWord stackWord ( StgStackOffset i )
1566 { return *stgCast(StgWord*,gSp+i); }
1568 static inline void setStackWord ( StgStackOffset i, StgWord w )
1571 static inline void PushTaggedRealWorld( void )
1572 { PushTag(REALWORLD_TAG); }
1573 inline void PushTaggedInt ( StgInt x )
1574 { gSp -= sizeofW(StgInt); *gSp = x; PushTag(INT_TAG); }
1575 inline void PushTaggedWord ( StgWord x )
1576 { gSp -= sizeofW(StgWord); *gSp = x; PushTag(WORD_TAG); }
1577 inline void PushTaggedAddr ( StgAddr x )
1578 { gSp -= sizeofW(StgAddr); *gSp = (W_)x; PushTag(ADDR_TAG); }
1579 inline void PushTaggedChar ( StgChar x )
1580 { gSp -= sizeofW(StgChar); *gSp = stgCast(StgWord,x); PushTag(CHAR_TAG); }
1581 inline void PushTaggedFloat ( StgFloat x )
1582 { gSp -= sizeofW(StgFloat); ASSIGN_FLT(gSp,x); PushTag(FLOAT_TAG); }
1583 inline void PushTaggedDouble ( StgDouble x )
1584 { gSp -= sizeofW(StgDouble); ASSIGN_DBL(gSp,x); PushTag(DOUBLE_TAG); }
1585 inline void PushTaggedStablePtr ( StgStablePtr x )
1586 { gSp -= sizeofW(StgStablePtr); *gSp = x; PushTag(STABLE_TAG); }
1587 static inline void PushTaggedBool ( int x )
1588 { PushTaggedInt(x); }
1592 static inline void PopTaggedRealWorld ( void )
1593 { PopTag(REALWORLD_TAG); }
1594 inline StgInt PopTaggedInt ( void )
1595 { StgInt r; PopTag(INT_TAG); r = *stgCast(StgInt*, gSp);
1596 gSp += sizeofW(StgInt); return r;}
1597 inline StgWord PopTaggedWord ( void )
1598 { StgWord r; PopTag(WORD_TAG); r = *stgCast(StgWord*, gSp);
1599 gSp += sizeofW(StgWord); return r;}
1600 inline StgAddr PopTaggedAddr ( void )
1601 { StgAddr r; PopTag(ADDR_TAG); r = *stgCast(StgAddr*, gSp);
1602 gSp += sizeofW(StgAddr); return r;}
1603 inline StgChar PopTaggedChar ( void )
1604 { StgChar r; PopTag(CHAR_TAG); r = stgCast(StgChar, *gSp);
1605 gSp += sizeofW(StgChar); return r;}
1606 inline StgFloat PopTaggedFloat ( void )
1607 { StgFloat r; PopTag(FLOAT_TAG); r = PK_FLT(gSp);
1608 gSp += sizeofW(StgFloat); return r;}
1609 inline StgDouble PopTaggedDouble ( void )
1610 { StgDouble r; PopTag(DOUBLE_TAG); r = PK_DBL(gSp);
1611 gSp += sizeofW(StgDouble); return r;}
1612 inline StgStablePtr PopTaggedStablePtr ( void )
1613 { StgInt r; PopTag(STABLE_TAG); r = *stgCast(StgStablePtr*, gSp);
1614 gSp += sizeofW(StgStablePtr); return r;}
1618 static inline StgInt taggedStackInt ( StgStackOffset i )
1619 { checkTag(INT_TAG,gSp[i]); return *stgCast(StgInt*, gSp+1+i); }
1620 static inline StgWord taggedStackWord ( StgStackOffset i )
1621 { checkTag(WORD_TAG,gSp[i]); return *stgCast(StgWord*, gSp+1+i); }
1622 static inline StgAddr taggedStackAddr ( StgStackOffset i )
1623 { checkTag(ADDR_TAG,gSp[i]); return *stgCast(StgAddr*, gSp+1+i); }
1624 static inline StgChar taggedStackChar ( StgStackOffset i )
1625 { checkTag(CHAR_TAG,gSp[i]); return stgCast(StgChar, *(gSp+1+i)) ; }
1626 static inline StgFloat taggedStackFloat ( StgStackOffset i )
1627 { checkTag(FLOAT_TAG,gSp[i]); return PK_FLT(gSp+1+i); }
1628 static inline StgDouble taggedStackDouble ( StgStackOffset i )
1629 { checkTag(DOUBLE_TAG,gSp[i]); return PK_DBL(gSp+1+i); }
1630 static inline StgStablePtr taggedStackStable ( StgStackOffset i )
1631 { checkTag(STABLE_TAG,gSp[i]); return *stgCast(StgStablePtr*, gSp+1+i); }
1634 /* --------------------------------------------------------------------------
1637 * Should we allocate from a nursery or use the
1638 * doYouWantToGC/allocate interface? We'd already implemented a
1639 * nursery-style scheme when the doYouWantToGC/allocate interface
1641 * One reason to prefer the doYouWantToGC/allocate interface is to
1642 * support operations which allocate an unknown amount in the heap
1643 * (array ops, gmp ops, etc)
1644 * ------------------------------------------------------------------------*/
1646 static inline StgPtr grabHpUpd( nat size )
1648 ASSERT( size >= MIN_UPD_SIZE + sizeofW(StgHeader) );
1649 #ifdef CRUDE_PROFILING
1650 cp_bill_words ( size );
1652 return allocate(size);
1655 static inline StgPtr grabHpNonUpd( nat size )
1657 ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
1658 #ifdef CRUDE_PROFILING
1659 cp_bill_words ( size );
1661 return allocate(size);
1664 /* --------------------------------------------------------------------------
1665 * Manipulate "update frame" list:
1666 * o Update frames (based on stg_do_update and friends in Updates.hc)
1667 * o Error handling/catching (based on catchzh_fast and friends in Prims.hc)
1668 * o Seq frames (based on seq_frame_entry in Prims.hc)
1670 * ------------------------------------------------------------------------*/
1672 static inline void PopUpdateFrame ( StgClosure* obj )
1674 /* NB: doesn't assume that gSp == gSu */
1676 fprintf(stderr, "Updating ");
1677 printPtr(stgCast(StgPtr,gSu->updatee));
1678 fprintf(stderr, " with ");
1680 fprintf(stderr,"gSp = %p\tgSu = %p\n\n", gSp, gSu);
1682 #ifdef EAGER_BLACKHOLING
1683 #warn LAZY_BLACKHOLING is default for StgHugs
1684 #error Dont know if EAGER_BLACKHOLING works in StgHugs
1685 ASSERT(get_itbl(gSu->updatee)->type == BLACKHOLE
1686 || get_itbl(gSu->updatee)->type == SE_BLACKHOLE
1687 || get_itbl(gSu->updatee)->type == CAF_BLACKHOLE
1688 || get_itbl(gSu->updatee)->type == SE_CAF_BLACKHOLE
1690 #endif /* EAGER_BLACKHOLING */
1691 UPD_IND(gSu->updatee,obj);
1692 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgUpdateFrame);
1696 static inline void PopStopFrame ( StgClosure* obj )
1698 /* Move gSu just off the end of the stack, we're about to gSpam the
1699 * STOP_FRAME with the return value.
1701 gSu = stgCast(StgUpdateFrame*,gSp+1);
1702 *stgCast(StgClosure**,gSp) = obj;
1705 static inline void PushCatchFrame ( StgClosure* handler )
1708 /* ToDo: stack check! */
1709 gSp -= sizeofW(StgCatchFrame);
1710 fp = stgCast(StgCatchFrame*,gSp);
1711 SET_HDR(fp,(StgInfoTable*)&catch_frame_info,CCCS);
1712 fp->handler = handler;
1714 gSu = stgCast(StgUpdateFrame*,fp);
1717 static inline void PopCatchFrame ( void )
1719 /* NB: doesn't assume that gSp == gSu */
1720 /* fprintf(stderr,"Popping catch frame\n"); */
1721 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgCatchFrame);
1722 gSu = stgCast(StgCatchFrame*,gSu)->link;
1725 static inline void PushSeqFrame ( void )
1728 /* ToDo: stack check! */
1729 gSp -= sizeofW(StgSeqFrame);
1730 fp = stgCast(StgSeqFrame*,gSp);
1731 SET_HDR(fp,(StgInfoTable*)&seq_frame_info,CCCS);
1733 gSu = stgCast(StgUpdateFrame*,fp);
1736 static inline void PopSeqFrame ( void )
1738 /* NB: doesn't assume that gSp == gSu */
1739 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgSeqFrame);
1740 gSu = stgCast(StgSeqFrame*,gSu)->link;
1743 static inline StgClosure* raiseAnError ( StgClosure* exception )
1745 /* This closure represents the expression 'primRaise E' where E
1746 * is the exception raised (:: Exception).
1747 * It is used to overwrite all the
1748 * thunks which are currently under evaluation.
1750 HaskellObj primRaiseClosure
1751 = asmClosureOfObject(getHugs_AsmObject_for("primRaise"));
1752 HaskellObj reraiseClosure
1753 = rts_apply ( primRaiseClosure, exception );
1756 switch (get_itbl(gSu)->type) {
1758 UPD_IND(gSu->updatee,reraiseClosure);
1759 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgUpdateFrame);
1765 case CATCH_FRAME: /* found it! */
1767 StgCatchFrame* fp = stgCast(StgCatchFrame*,gSu);
1768 StgClosure *handler = fp->handler;
1770 gSp += sizeofW(StgCatchFrame); /* Pop */
1771 PushCPtr(exception);
1775 barf("raiseError: uncaught exception: STOP_FRAME");
1777 barf("raiseError: weird activation record");
1783 static StgClosure* makeErrorCall ( const char* msg )
1785 /* Note! the msg string should be allocated in a
1786 place which will not get freed -- preferably
1787 read-only data of the program. That's because
1788 the thunk we build here may linger indefinitely.
1789 (thinks: probably not so, but anyway ...)
1792 = asmClosureOfObject(getHugs_AsmObject_for("error"));
1794 = asmClosureOfObject(getHugs_AsmObject_for("hugsprimUnpackString"));
1796 = rts_apply ( unpack, rts_mkAddr ( (void*)msg ) );
1798 = rts_apply ( error, thunk );
1800 (StgClosure*) thunk;
1803 #define raiseIndex(where) makeErrorCall("Array index out of range in " where)
1804 #define raiseDiv0(where) makeErrorCall("Division by zero in " where)
1806 /* --------------------------------------------------------------------------
1808 * ------------------------------------------------------------------------*/
1810 #define OP_CC_B(e) \
1812 unsigned char x = PopTaggedChar(); \
1813 unsigned char y = PopTaggedChar(); \
1814 PushTaggedBool(e); \
1819 unsigned char x = PopTaggedChar(); \
1828 #define OP_IW_I(e) \
1830 StgInt x = PopTaggedInt(); \
1831 StgWord y = PopTaggedWord(); \
1835 #define OP_II_I(e) \
1837 StgInt x = PopTaggedInt(); \
1838 StgInt y = PopTaggedInt(); \
1842 #define OP_II_B(e) \
1844 StgInt x = PopTaggedInt(); \
1845 StgInt y = PopTaggedInt(); \
1846 PushTaggedBool(e); \
1851 PushTaggedAddr(e); \
1856 StgInt x = PopTaggedInt(); \
1857 PushTaggedAddr(e); \
1862 StgInt x = PopTaggedInt(); \
1868 PushTaggedChar(e); \
1873 StgInt x = PopTaggedInt(); \
1874 PushTaggedChar(e); \
1879 PushTaggedWord(e); \
1884 StgInt x = PopTaggedInt(); \
1885 PushTaggedWord(e); \
1890 StgInt x = PopTaggedInt(); \
1891 PushTaggedStablePtr(e); \
1896 PushTaggedFloat(e); \
1901 StgInt x = PopTaggedInt(); \
1902 PushTaggedFloat(e); \
1907 PushTaggedDouble(e); \
1912 StgInt x = PopTaggedInt(); \
1913 PushTaggedDouble(e); \
1916 #define OP_WW_B(e) \
1918 StgWord x = PopTaggedWord(); \
1919 StgWord y = PopTaggedWord(); \
1920 PushTaggedBool(e); \
1923 #define OP_WW_W(e) \
1925 StgWord x = PopTaggedWord(); \
1926 StgWord y = PopTaggedWord(); \
1927 PushTaggedWord(e); \
1932 StgWord x = PopTaggedWord(); \
1938 StgStablePtr x = PopTaggedStablePtr(); \
1944 StgWord x = PopTaggedWord(); \
1945 PushTaggedWord(e); \
1948 #define OP_AA_B(e) \
1950 StgAddr x = PopTaggedAddr(); \
1951 StgAddr y = PopTaggedAddr(); \
1952 PushTaggedBool(e); \
1956 StgAddr x = PopTaggedAddr(); \
1959 #define OP_AI_C(s) \
1961 StgAddr x = PopTaggedAddr(); \
1962 int y = PopTaggedInt(); \
1965 PushTaggedChar(r); \
1967 #define OP_AI_I(s) \
1969 StgAddr x = PopTaggedAddr(); \
1970 int y = PopTaggedInt(); \
1975 #define OP_AI_A(s) \
1977 StgAddr x = PopTaggedAddr(); \
1978 int y = PopTaggedInt(); \
1981 PushTaggedAddr(s); \
1983 #define OP_AI_F(s) \
1985 StgAddr x = PopTaggedAddr(); \
1986 int y = PopTaggedInt(); \
1989 PushTaggedFloat(r); \
1991 #define OP_AI_D(s) \
1993 StgAddr x = PopTaggedAddr(); \
1994 int y = PopTaggedInt(); \
1997 PushTaggedDouble(r); \
1999 #define OP_AI_s(s) \
2001 StgAddr x = PopTaggedAddr(); \
2002 int y = PopTaggedInt(); \
2005 PushTaggedStablePtr(r); \
2007 #define OP_AIC_(s) \
2009 StgAddr x = PopTaggedAddr(); \
2010 int y = PopTaggedInt(); \
2011 StgChar z = PopTaggedChar(); \
2014 #define OP_AII_(s) \
2016 StgAddr x = PopTaggedAddr(); \
2017 int y = PopTaggedInt(); \
2018 StgInt z = PopTaggedInt(); \
2021 #define OP_AIA_(s) \
2023 StgAddr x = PopTaggedAddr(); \
2024 int y = PopTaggedInt(); \
2025 StgAddr z = PopTaggedAddr(); \
2028 #define OP_AIF_(s) \
2030 StgAddr x = PopTaggedAddr(); \
2031 int y = PopTaggedInt(); \
2032 StgFloat z = PopTaggedFloat(); \
2035 #define OP_AID_(s) \
2037 StgAddr x = PopTaggedAddr(); \
2038 int y = PopTaggedInt(); \
2039 StgDouble z = PopTaggedDouble(); \
2042 #define OP_AIs_(s) \
2044 StgAddr x = PopTaggedAddr(); \
2045 int y = PopTaggedInt(); \
2046 StgStablePtr z = PopTaggedStablePtr(); \
2051 #define OP_FF_B(e) \
2053 StgFloat x = PopTaggedFloat(); \
2054 StgFloat y = PopTaggedFloat(); \
2055 PushTaggedBool(e); \
2058 #define OP_FF_F(e) \
2060 StgFloat x = PopTaggedFloat(); \
2061 StgFloat y = PopTaggedFloat(); \
2062 PushTaggedFloat(e); \
2067 StgFloat x = PopTaggedFloat(); \
2068 PushTaggedFloat(e); \
2073 StgFloat x = PopTaggedFloat(); \
2074 PushTaggedBool(e); \
2079 StgFloat x = PopTaggedFloat(); \
2085 StgFloat x = PopTaggedFloat(); \
2086 PushTaggedDouble(e); \
2089 #define OP_DD_B(e) \
2091 StgDouble x = PopTaggedDouble(); \
2092 StgDouble y = PopTaggedDouble(); \
2093 PushTaggedBool(e); \
2096 #define OP_DD_D(e) \
2098 StgDouble x = PopTaggedDouble(); \
2099 StgDouble y = PopTaggedDouble(); \
2100 PushTaggedDouble(e); \
2105 StgDouble x = PopTaggedDouble(); \
2106 PushTaggedBool(e); \
2111 StgDouble x = PopTaggedDouble(); \
2112 PushTaggedDouble(e); \
2117 StgDouble x = PopTaggedDouble(); \
2123 StgDouble x = PopTaggedDouble(); \
2124 PushTaggedFloat(e); \
2128 #ifdef STANDALONE_INTEGER
2129 StgPtr CreateByteArrayToHoldInteger ( int nbytes )
2131 StgInt words = (nbytes+sizeof(W_)-1)/sizeof(W_);
2132 StgWord size = sizeofW(StgArrWords) + words;
2133 StgArrWords* arr = (StgArrWords*)allocate(size);
2134 SET_HDR(arr,&ARR_WORDS_info,CCCS);
2136 ASSERT(nbytes <= arr->words * sizeof(W_));
2139 for (i = 0; i < words; ++i) {
2140 arr->payload[i] = 0xdeadbeef;
2142 { B* b = (B*) &(arr->payload[0]);
2143 b->used = b->sign = 0;
2149 B* IntegerInsideByteArray ( StgPtr arr0 )
2152 StgArrWords* arr = (StgArrWords*)arr0;
2153 ASSERT(GET_INFO(arr) == &ARR_WORDS_info);
2154 b = (B*) &(arr->payload[0]);
2158 void SloppifyIntegerEnd ( StgPtr arr0 )
2160 StgArrWords* arr = (StgArrWords*)arr0;
2161 B* b = (B*) & (arr->payload[0]);
2162 I_ nwunused = arr->words - sizeofW(B) - (b->used+sizeof(W_)-1)/sizeof(W_);
2163 if (nwunused >= ((I_)sizeofW(StgArrWords))) {
2165 b->size -= nwunused * sizeof(W_);
2166 if (b->size < b->used) b->size = b->used;
2169 arr->words -= nwunused;
2170 slop = (StgArrWords*)&(arr->payload[arr->words]);
2171 SET_HDR(slop,&ARR_WORDS_info,CCCS);
2172 slop->words = nwunused - sizeofW(StgArrWords);
2173 ASSERT( &(slop->payload[slop->words]) ==
2174 &(arr->payload[arr->words + nwunused]) );
2178 #define OP_Z_Z(op) \
2180 B* x = IntegerInsideByteArray(PopPtr()); \
2181 int n = mycat2(size_,op)(x); \
2182 StgPtr p = CreateByteArrayToHoldInteger(n); \
2183 mycat2(do_,op)(x,n,IntegerInsideByteArray(p)); \
2184 SloppifyIntegerEnd(p); \
2187 #define OP_ZZ_Z(op) \
2189 B* x = IntegerInsideByteArray(PopPtr()); \
2190 B* y = IntegerInsideByteArray(PopPtr()); \
2191 int n = mycat2(size_,op)(x,y); \
2192 StgPtr p = CreateByteArrayToHoldInteger(n); \
2193 mycat2(do_,op)(x,y,n,IntegerInsideByteArray(p)); \
2194 SloppifyIntegerEnd(p); \
2202 #define HEADER_mI(ty,where) \
2203 StgArrWords* x = stgCast(StgArrWords*,PopPtr()); \
2204 nat i = PopTaggedInt(); \
2205 if (i * sizeof(ty) + (sizeof(ty)) > sizeof(StgWord) * x->words) { \
2206 return (raiseIndex(where)); \
2208 #define OP_mI_ty(ty,where,s) \
2210 HEADER_mI(mycat2(Stg,ty),where) \
2211 { mycat2(Stg,ty) r; \
2213 mycat2(PushTagged,ty)(r); \
2216 #define OP_mIty_(ty,where,s) \
2218 HEADER_mI(mycat2(Stg,ty),where) \
2220 mycat2(Stg,ty) z = mycat2(PopTagged,ty)(); \
2226 void myStackCheck ( Capability* cap )
2228 /* fprintf(stderr, "myStackCheck\n"); */
2229 if (!(gSpLim <= gSp && gSp <= stgCast(StgPtr,gSu))) {
2230 fprintf(stderr, "myStackCheck: invalid initial gSp/gSu \n" );
2234 if (!(gSu >= cap->rCurrentTSO->stack
2235 && gSu <= cap->rCurrentTSO->stack
2236 + cap->rCurrentTSO->stack_size)) {
2237 fprintf ( stderr, "myStackCheck: gSu out of stack\n" );
2240 switch (get_itbl(stgCast(StgClosure*,gSu))->type) {
2242 gSu = (StgPtr) ((StgCatchFrame*)(gSu))->link;
2245 gSu = (StgPtr) ((StgUpdateFrame*)(gSu))->link;
2248 gSu = (StgPtr) ((StgSeqFrame*)(gSu))->link;
2253 fprintf(stderr, "myStackCheck: invalid activation record\n"); assert(0);
2260 /* --------------------------------------------------------------------------
2261 * Primop stuff for bytecode interpreter
2262 * ------------------------------------------------------------------------*/
2264 /* Returns & of the next thing to enter (if throwing an exception),
2265 or NULL in the normal case.
2267 static void* enterBCO_primop1 ( int primop1code )
2270 barf("enterBCO_primop1 in combined mode");
2272 switch (primop1code) {
2273 case i_pushseqframe:
2275 StgClosure* c = PopCPtr();
2280 case i_pushcatchframe:
2282 StgClosure* e = PopCPtr();
2283 StgClosure* h = PopCPtr();
2289 case i_gtChar: OP_CC_B(x>y); break;
2290 case i_geChar: OP_CC_B(x>=y); break;
2291 case i_eqChar: OP_CC_B(x==y); break;
2292 case i_neChar: OP_CC_B(x!=y); break;
2293 case i_ltChar: OP_CC_B(x<y); break;
2294 case i_leChar: OP_CC_B(x<=y); break;
2295 case i_charToInt: OP_C_I(x); break;
2296 case i_intToChar: OP_I_C(x); break;
2298 case i_gtInt: OP_II_B(x>y); break;
2299 case i_geInt: OP_II_B(x>=y); break;
2300 case i_eqInt: OP_II_B(x==y); break;
2301 case i_neInt: OP_II_B(x!=y); break;
2302 case i_ltInt: OP_II_B(x<y); break;
2303 case i_leInt: OP_II_B(x<=y); break;
2304 case i_minInt: OP__I(INT_MIN); break;
2305 case i_maxInt: OP__I(INT_MAX); break;
2306 case i_plusInt: OP_II_I(x+y); break;
2307 case i_minusInt: OP_II_I(x-y); break;
2308 case i_timesInt: OP_II_I(x*y); break;
2311 int x = PopTaggedInt();
2312 int y = PopTaggedInt();
2314 return (raiseDiv0("quotInt"));
2316 /* ToDo: protect against minInt / -1 errors
2317 * (repeat for all other division primops) */
2323 int x = PopTaggedInt();
2324 int y = PopTaggedInt();
2326 return (raiseDiv0("remInt"));
2333 StgInt x = PopTaggedInt();
2334 StgInt y = PopTaggedInt();
2336 return (raiseDiv0("quotRemInt"));
2338 PushTaggedInt(x%y); /* last result */
2339 PushTaggedInt(x/y); /* first result */
2342 case i_negateInt: OP_I_I(-x); break;
2344 case i_andInt: OP_II_I(x&y); break;
2345 case i_orInt: OP_II_I(x|y); break;
2346 case i_xorInt: OP_II_I(x^y); break;
2347 case i_notInt: OP_I_I(~x); break;
2348 case i_shiftLInt: OP_II_I(x<<y); break;
2349 case i_shiftRAInt: OP_II_I(x>>y); break; /* ToDo */
2350 case i_shiftRLInt: OP_II_I(x>>y); break; /* ToDo */
2352 case i_gtWord: OP_WW_B(x>y); break;
2353 case i_geWord: OP_WW_B(x>=y); break;
2354 case i_eqWord: OP_WW_B(x==y); break;
2355 case i_neWord: OP_WW_B(x!=y); break;
2356 case i_ltWord: OP_WW_B(x<y); break;
2357 case i_leWord: OP_WW_B(x<=y); break;
2358 case i_minWord: OP__W(0); break;
2359 case i_maxWord: OP__W(UINT_MAX); break;
2360 case i_plusWord: OP_WW_W(x+y); break;
2361 case i_minusWord: OP_WW_W(x-y); break;
2362 case i_timesWord: OP_WW_W(x*y); break;
2365 StgWord x = PopTaggedWord();
2366 StgWord y = PopTaggedWord();
2368 return (raiseDiv0("quotWord"));
2370 PushTaggedWord(x/y);
2375 StgWord x = PopTaggedWord();
2376 StgWord y = PopTaggedWord();
2378 return (raiseDiv0("remWord"));
2380 PushTaggedWord(x%y);
2385 StgWord x = PopTaggedWord();
2386 StgWord y = PopTaggedWord();
2388 return (raiseDiv0("quotRemWord"));
2390 PushTaggedWord(x%y); /* last result */
2391 PushTaggedWord(x/y); /* first result */
2394 case i_negateWord: OP_W_W(-x); break;
2395 case i_andWord: OP_WW_W(x&y); break;
2396 case i_orWord: OP_WW_W(x|y); break;
2397 case i_xorWord: OP_WW_W(x^y); break;
2398 case i_notWord: OP_W_W(~x); break;
2399 case i_shiftLWord: OP_WW_W(x<<y); break;
2400 case i_shiftRAWord: OP_WW_W(x>>y); break; /* ToDo */
2401 case i_shiftRLWord: OP_WW_W(x>>y); break; /* ToDo */
2402 case i_intToWord: OP_I_W(x); break;
2403 case i_wordToInt: OP_W_I(x); break;
2405 case i_gtAddr: OP_AA_B(x>y); break;
2406 case i_geAddr: OP_AA_B(x>=y); break;
2407 case i_eqAddr: OP_AA_B(x==y); break;
2408 case i_neAddr: OP_AA_B(x!=y); break;
2409 case i_ltAddr: OP_AA_B(x<y); break;
2410 case i_leAddr: OP_AA_B(x<=y); break;
2411 case i_intToAddr: OP_I_A((StgAddr)x); break; /* ToDo */
2412 case i_addrToInt: OP_A_I((StgInt)x); break; /* ToDo */
2414 case i_intToStable: OP_I_s(x); break;
2415 case i_stableToInt: OP_s_I(x); break;
2417 case i_indexCharOffAddr: OP_AI_C(indexCharOffAddrzh(r,x,y)); break;
2418 case i_readCharOffAddr: OP_AI_C(indexCharOffAddrzh(r,x,y)); break;
2419 case i_writeCharOffAddr: OP_AIC_(writeCharOffAddrzh(x,y,z)); break;
2421 case i_indexIntOffAddr: OP_AI_I(indexIntOffAddrzh(r,x,y)); break;
2422 case i_readIntOffAddr: OP_AI_I(indexIntOffAddrzh(r,x,y)); break;
2423 case i_writeIntOffAddr: OP_AII_(writeIntOffAddrzh(x,y,z)); break;
2425 case i_indexAddrOffAddr: OP_AI_A(indexAddrOffAddrzh(r,x,y)); break;
2426 case i_readAddrOffAddr: OP_AI_A(indexAddrOffAddrzh(r,x,y)); break;
2427 case i_writeAddrOffAddr: OP_AIA_(writeAddrOffAddrzh(x,y,z)); break;
2429 case i_indexFloatOffAddr: OP_AI_F(indexFloatOffAddrzh(r,x,y)); break;
2430 case i_readFloatOffAddr: OP_AI_F(indexFloatOffAddrzh(r,x,y)); break;
2431 case i_writeFloatOffAddr: OP_AIF_(writeFloatOffAddrzh(x,y,z)); break;
2433 case i_indexDoubleOffAddr: OP_AI_D(indexDoubleOffAddrzh(r,x,y)); break;
2434 case i_readDoubleOffAddr: OP_AI_D(indexDoubleOffAddrzh(r,x,y)); break;
2435 case i_writeDoubleOffAddr: OP_AID_(writeDoubleOffAddrzh(x,y,z)); break;
2437 case i_indexStableOffAddr: OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break;
2438 case i_readStableOffAddr: OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break;
2439 case i_writeStableOffAddr: OP_AIs_(writeStablePtrOffAddrzh(x,y,z)); break;
2441 #ifdef STANDALONE_INTEGER
2442 case i_compareInteger:
2444 B* x = IntegerInsideByteArray(PopPtr());
2445 B* y = IntegerInsideByteArray(PopPtr());
2446 StgInt r = do_cmp(x,y);
2447 PushTaggedInt(r<0 ? -1 : (r>0 ? 1 : 0));
2450 case i_negateInteger: OP_Z_Z(neg); break;
2451 case i_plusInteger: OP_ZZ_Z(add); break;
2452 case i_minusInteger: OP_ZZ_Z(sub); break;
2453 case i_timesInteger: OP_ZZ_Z(mul); break;
2454 case i_quotRemInteger:
2456 B* x = IntegerInsideByteArray(PopPtr());
2457 B* y = IntegerInsideByteArray(PopPtr());
2458 int n = size_qrm(x,y);
2459 StgPtr q = CreateByteArrayToHoldInteger(n);
2460 StgPtr r = CreateByteArrayToHoldInteger(n);
2461 if (do_getsign(y)==0)
2462 return (raiseDiv0("quotRemInteger"));
2463 do_qrm(x,y,n,IntegerInsideByteArray(q),
2464 IntegerInsideByteArray(r));
2465 SloppifyIntegerEnd(q);
2466 SloppifyIntegerEnd(r);
2471 case i_intToInteger:
2473 int n = size_fromInt();
2474 StgPtr p = CreateByteArrayToHoldInteger(n);
2475 do_fromInt( PopTaggedInt(), n, IntegerInsideByteArray(p));
2479 case i_wordToInteger:
2481 int n = size_fromWord();
2482 StgPtr p = CreateByteArrayToHoldInteger(n);
2483 do_fromWord( PopTaggedWord(), n, IntegerInsideByteArray(p));
2487 case i_integerToInt: PushTaggedInt(do_toInt(
2488 IntegerInsideByteArray(PopPtr())
2492 case i_integerToWord: PushTaggedWord(do_toWord(
2493 IntegerInsideByteArray(PopPtr())
2497 case i_integerToFloat: PushTaggedFloat(do_toFloat(
2498 IntegerInsideByteArray(PopPtr())
2502 case i_integerToDouble: PushTaggedDouble(do_toDouble(
2503 IntegerInsideByteArray(PopPtr())
2507 #error Non-standalone integer not yet implemented
2508 #endif /* STANDALONE_INTEGER */
2510 case i_gtFloat: OP_FF_B(x>y); break;
2511 case i_geFloat: OP_FF_B(x>=y); break;
2512 case i_eqFloat: OP_FF_B(x==y); break;
2513 case i_neFloat: OP_FF_B(x!=y); break;
2514 case i_ltFloat: OP_FF_B(x<y); break;
2515 case i_leFloat: OP_FF_B(x<=y); break;
2516 case i_minFloat: OP__F(FLT_MIN); break;
2517 case i_maxFloat: OP__F(FLT_MAX); break;
2518 case i_radixFloat: OP__I(FLT_RADIX); break;
2519 case i_digitsFloat: OP__I(FLT_MANT_DIG); break;
2520 case i_minExpFloat: OP__I(FLT_MIN_EXP); break;
2521 case i_maxExpFloat: OP__I(FLT_MAX_EXP); break;
2522 case i_plusFloat: OP_FF_F(x+y); break;
2523 case i_minusFloat: OP_FF_F(x-y); break;
2524 case i_timesFloat: OP_FF_F(x*y); break;
2527 StgFloat x = PopTaggedFloat();
2528 StgFloat y = PopTaggedFloat();
2529 PushTaggedFloat(x/y);
2532 case i_negateFloat: OP_F_F(-x); break;
2533 case i_floatToInt: OP_F_I(x); break;
2534 case i_intToFloat: OP_I_F(x); break;
2535 case i_expFloat: OP_F_F(exp(x)); break;
2536 case i_logFloat: OP_F_F(log(x)); break;
2537 case i_sqrtFloat: OP_F_F(sqrt(x)); break;
2538 case i_sinFloat: OP_F_F(sin(x)); break;
2539 case i_cosFloat: OP_F_F(cos(x)); break;
2540 case i_tanFloat: OP_F_F(tan(x)); break;
2541 case i_asinFloat: OP_F_F(asin(x)); break;
2542 case i_acosFloat: OP_F_F(acos(x)); break;
2543 case i_atanFloat: OP_F_F(atan(x)); break;
2544 case i_sinhFloat: OP_F_F(sinh(x)); break;
2545 case i_coshFloat: OP_F_F(cosh(x)); break;
2546 case i_tanhFloat: OP_F_F(tanh(x)); break;
2547 case i_powerFloat: OP_FF_F(pow(x,y)); break;
2549 #ifdef STANDALONE_INTEGER
2550 case i_encodeFloatZ:
2552 StgPtr sig = PopPtr();
2553 StgInt exp = PopTaggedInt();
2555 B__encodeFloat(IntegerInsideByteArray(sig), exp)
2559 case i_decodeFloatZ:
2561 StgFloat f = PopTaggedFloat();
2562 StgPtr sig = CreateByteArrayToHoldInteger(size_fltmantissa());
2564 B__decodeFloat(IntegerInsideByteArray(sig), &exp, f);
2570 #error encode/decodeFloatZ not yet implemented for GHC ints
2572 case i_isNaNFloat: OP_F_B(isFloatNaN(x)); break;
2573 case i_isInfiniteFloat: OP_F_B(isFloatInfinite(x)); break;
2574 case i_isNegativeZeroFloat: OP_F_B(isFloatNegativeZero(x)); break;
2575 case i_isDenormalizedFloat: OP_F_B(isFloatDenormalized(x)); break;
2576 case i_gtDouble: OP_DD_B(x>y); break;
2577 case i_geDouble: OP_DD_B(x>=y); break;
2578 case i_eqDouble: OP_DD_B(x==y); break;
2579 case i_neDouble: OP_DD_B(x!=y); break;
2580 case i_ltDouble: OP_DD_B(x<y); break;
2581 case i_leDouble: OP_DD_B(x<=y) break;
2582 case i_minDouble: OP__D(DBL_MIN); break;
2583 case i_maxDouble: OP__D(DBL_MAX); break;
2584 case i_radixDouble: OP__I(FLT_RADIX); break;
2585 case i_digitsDouble: OP__I(DBL_MANT_DIG); break;
2586 case i_minExpDouble: OP__I(DBL_MIN_EXP); break;
2587 case i_maxExpDouble: OP__I(DBL_MAX_EXP); break;
2588 case i_plusDouble: OP_DD_D(x+y); break;
2589 case i_minusDouble: OP_DD_D(x-y); break;
2590 case i_timesDouble: OP_DD_D(x*y); break;
2591 case i_divideDouble:
2593 StgDouble x = PopTaggedDouble();
2594 StgDouble y = PopTaggedDouble();
2595 PushTaggedDouble(x/y);
2598 case i_negateDouble: OP_D_D(-x); break;
2599 case i_doubleToInt: OP_D_I(x); break;
2600 case i_intToDouble: OP_I_D(x); break;
2601 case i_doubleToFloat: OP_D_F(x); break;
2602 case i_floatToDouble: OP_F_F(x); break;
2603 case i_expDouble: OP_D_D(exp(x)); break;
2604 case i_logDouble: OP_D_D(log(x)); break;
2605 case i_sqrtDouble: OP_D_D(sqrt(x)); break;
2606 case i_sinDouble: OP_D_D(sin(x)); break;
2607 case i_cosDouble: OP_D_D(cos(x)); break;
2608 case i_tanDouble: OP_D_D(tan(x)); break;
2609 case i_asinDouble: OP_D_D(asin(x)); break;
2610 case i_acosDouble: OP_D_D(acos(x)); break;
2611 case i_atanDouble: OP_D_D(atan(x)); break;
2612 case i_sinhDouble: OP_D_D(sinh(x)); break;
2613 case i_coshDouble: OP_D_D(cosh(x)); break;
2614 case i_tanhDouble: OP_D_D(tanh(x)); break;
2615 case i_powerDouble: OP_DD_D(pow(x,y)); break;
2617 #ifdef STANDALONE_INTEGER
2618 case i_encodeDoubleZ:
2620 StgPtr sig = PopPtr();
2621 StgInt exp = PopTaggedInt();
2623 B__encodeDouble(IntegerInsideByteArray(sig), exp)
2627 case i_decodeDoubleZ:
2629 StgDouble d = PopTaggedDouble();
2630 StgPtr sig = CreateByteArrayToHoldInteger(size_dblmantissa());
2632 B__decodeDouble(IntegerInsideByteArray(sig), &exp, d);
2638 #error encode/decodeDoubleZ not yet implemented for GHC ints
2640 case i_isNaNDouble: OP_D_B(isDoubleNaN(x)); break;
2641 case i_isInfiniteDouble: OP_D_B(isDoubleInfinite(x)); break;
2642 case i_isNegativeZeroDouble: OP_D_B(isDoubleNegativeZero(x)); break;
2643 case i_isDenormalizedDouble: OP_D_B(isDoubleDenormalized(x)); break;
2644 case i_isIEEEDouble:
2646 PushTaggedBool(rtsTrue);
2650 barf("Unrecognised primop1");
2657 /* For normal cases, return NULL and leave *return2 unchanged.
2658 To return the address of the next thing to enter,
2659 return the address of it and leave *return2 unchanged.
2660 To return a StgThreadReturnCode to the scheduler,
2661 set *return2 to it and return a non-NULL value.
2663 static void* enterBCO_primop2 ( int primop2code,
2664 int* /*StgThreadReturnCode* */ return2,
2669 /* A small concession: we need to allow ccalls,
2670 even in combined mode.
2672 if (primop2code != i_ccall_ccall_IO &&
2673 primop2code != i_ccall_stdcall_IO)
2674 barf("enterBCO_primop2 in combined mode");
2677 switch (primop2code) {
2678 case i_raise: /* raise#{err} */
2680 StgClosure* err = PopCPtr();
2681 return (raiseAnError(err));
2686 StgClosure* init = PopCPtr();
2688 = stgCast(StgMutVar*,allocate(sizeofW(StgMutVar)));
2689 SET_HDR(mv,&MUT_VAR_info,CCCS);
2691 PushPtr(stgCast(StgPtr,mv));
2696 StgMutVar* mv = stgCast(StgMutVar*,PopPtr());
2702 StgMutVar* mv = stgCast(StgMutVar*,PopPtr());
2703 StgClosure* value = PopCPtr();
2709 nat n = PopTaggedInt(); /* or Word?? */
2710 StgClosure* init = PopCPtr();
2711 StgWord size = sizeofW(StgMutArrPtrs) + n;
2714 = stgCast(StgMutArrPtrs*,allocate(size));
2715 SET_HDR(arr,&MUT_ARR_PTRS_info,CCCS);
2717 for (i = 0; i < n; ++i) {
2718 arr->payload[i] = init;
2720 PushPtr(stgCast(StgPtr,arr));
2726 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2727 nat i = PopTaggedInt(); /* or Word?? */
2728 StgWord n = arr->ptrs;
2730 return (raiseIndex("{index,read}Array"));
2732 PushCPtr(arr->payload[i]);
2737 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2738 nat i = PopTaggedInt(); /* or Word? */
2739 StgClosure* v = PopCPtr();
2740 StgWord n = arr->ptrs;
2742 return (raiseIndex("{index,read}Array"));
2744 arr->payload[i] = v;
2748 case i_sizeMutableArray:
2750 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2751 PushTaggedInt(arr->ptrs);
2754 case i_unsafeFreezeArray:
2756 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2757 SET_INFO(arr,&MUT_ARR_PTRS_FROZEN_info);
2758 PushPtr(stgCast(StgPtr,arr));
2761 case i_unsafeFreezeByteArray:
2763 /* Delightfully simple :-) */
2767 case i_sameMutableArray:
2768 case i_sameMutableByteArray:
2770 StgPtr x = PopPtr();
2771 StgPtr y = PopPtr();
2772 PushTaggedBool(x==y);
2776 case i_newByteArray:
2778 nat n = PopTaggedInt(); /* or Word?? */
2779 StgInt words = (n+sizeof(W_)-1)/sizeof(W_);
2780 StgWord size = sizeofW(StgArrWords) + words;
2781 StgArrWords* arr = stgCast(StgArrWords*,allocate(size));
2782 SET_HDR(arr,&ARR_WORDS_info,CCCS);
2786 for (i = 0; i < n; ++i) {
2787 arr->payload[i] = 0xdeadbeef;
2790 PushPtr(stgCast(StgPtr,arr));
2794 /* Most of these generate alignment warnings on Sparcs and similar architectures.
2795 * These are harmless and are caused by the cast to C* in BYTE_ARR_CTS.
2797 case i_indexCharArray:
2798 OP_mI_ty(Char,"indexCharArray", indexCharArrayzh(r,x,i)); break;
2799 case i_readCharArray:
2800 OP_mI_ty(Char,"readCharArray", readCharArrayzh(r,x,i)); break;
2801 case i_writeCharArray:
2802 OP_mIty_(Char,"writeCharArray", writeCharArrayzh(x,i,z)); break;
2804 case i_indexIntArray:
2805 OP_mI_ty(Int,"indexIntArray", indexIntArrayzh(r,x,i)); break;
2806 case i_readIntArray:
2807 OP_mI_ty(Int,"readIntArray", readIntArrayzh(r,x,i)); break;
2808 case i_writeIntArray:
2809 OP_mIty_(Int,"writeIntArray", writeIntArrayzh(x,i,z)); break;
2811 case i_indexAddrArray:
2812 OP_mI_ty(Addr,"indexAddrArray", indexAddrArrayzh(r,x,i)); break;
2813 case i_readAddrArray:
2814 OP_mI_ty(Addr,"readAddrArray", readAddrArrayzh(r,x,i)); break;
2815 case i_writeAddrArray:
2816 OP_mIty_(Addr,"writeAddrArray", writeAddrArrayzh(x,i,z)); break;
2818 case i_indexFloatArray:
2819 OP_mI_ty(Float,"indexFloatArray", indexFloatArrayzh(r,x,i)); break;
2820 case i_readFloatArray:
2821 OP_mI_ty(Float,"readFloatArray", readFloatArrayzh(r,x,i)); break;
2822 case i_writeFloatArray:
2823 OP_mIty_(Float,"writeFloatArray", writeFloatArrayzh(x,i,z)); break;
2825 case i_indexDoubleArray:
2826 OP_mI_ty(Double,"indexDoubleArray", indexDoubleArrayzh(r,x,i)); break;
2827 case i_readDoubleArray:
2828 OP_mI_ty(Double,"readDoubleArray", readDoubleArrayzh(r,x,i)); break;
2829 case i_writeDoubleArray:
2830 OP_mIty_(Double,"writeDoubleArray", writeDoubleArrayzh(x,i,z)); break;
2833 #ifdef PROVIDE_STABLE
2834 case i_indexStableArray:
2835 OP_mI_ty(StablePtr,"indexStableArray", indexStablePtrArrayzh(r,x,i)); break;
2836 case i_readStableArray:
2837 OP_mI_ty(StablePtr,"readStableArray", readStablePtrArrayzh(r,x,i)); break;
2838 case i_writeStableArray:
2839 OP_mIty_(StablePtr,"writeStableArray", writeStablePtrArrayzh(x,i,z)); break;
2845 #ifdef PROVIDE_COERCE
2846 case i_unsafeCoerce:
2848 /* Another nullop */
2852 #ifdef PROVIDE_PTREQUALITY
2853 case i_reallyUnsafePtrEquality:
2854 { /* identical to i_sameRef */
2855 StgPtr x = PopPtr();
2856 StgPtr y = PopPtr();
2857 PushTaggedBool(x==y);
2861 #ifdef PROVIDE_FOREIGN
2862 /* ForeignObj# operations */
2863 case i_makeForeignObj:
2865 StgForeignObj *result
2866 = stgCast(StgForeignObj*,allocate(sizeofW(StgForeignObj)));
2867 SET_HDR(result,&FOREIGN_info,CCCS);
2868 result -> data = PopTaggedAddr();
2869 PushPtr(stgCast(StgPtr,result));
2872 #endif /* PROVIDE_FOREIGN */
2877 = stgCast(StgWeak*,allocate(sizeofW(StgWeak)));
2878 SET_HDR(w, &WEAK_info, CCCS);
2880 w->value = PopCPtr();
2881 w->finaliser = PopCPtr();
2882 w->link = weak_ptr_list;
2884 IF_DEBUG(weak, fprintf(stderr,"New weak pointer at %p\n",w));
2885 PushPtr(stgCast(StgPtr,w));
2890 StgWeak *w = stgCast(StgWeak*,PopPtr());
2891 if (w->header.info == &WEAK_info) {
2892 PushCPtr(w->value); /* last result */
2893 PushTaggedInt(1); /* first result */
2895 PushPtr(stgCast(StgPtr,w));
2896 /* ToDo: error thunk would be better */
2901 #endif /* PROVIDE_WEAK */
2903 case i_makeStablePtr:
2905 StgPtr p = PopPtr();
2906 StgStablePtr sp = getStablePtr ( p );
2907 PushTaggedStablePtr(sp);
2910 case i_deRefStablePtr:
2913 StgStablePtr sp = PopTaggedStablePtr();
2914 p = deRefStablePtr(sp);
2918 case i_freeStablePtr:
2920 StgStablePtr sp = PopTaggedStablePtr();
2925 case i_createAdjThunkARCH:
2927 StgStablePtr stableptr = PopTaggedStablePtr();
2928 StgAddr typestr = PopTaggedAddr();
2929 StgChar callconv = PopTaggedChar();
2930 StgAddr adj_thunk = createAdjThunk(stableptr,typestr,callconv);
2931 PushTaggedAddr(adj_thunk);
2937 StgInt n = prog_argc;
2943 StgInt n = PopTaggedInt();
2944 StgAddr a = (StgAddr)prog_argv[n];
2951 StgMVar *mvar = stgCast(StgMVar*,allocate(sizeofW(StgMVar)));
2952 SET_INFO(mvar,&EMPTY_MVAR_info);
2953 mvar->head = mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
2954 mvar->value = stgCast(StgClosure*,&END_TSO_QUEUE_closure);
2955 PushPtr(stgCast(StgPtr,mvar));
2960 StgMVar *mvar = (StgMVar*)PopCPtr();
2961 if (GET_INFO(mvar) == &EMPTY_MVAR_info) {
2963 /* The MVar is empty. Attach ourselves to the TSO's
2966 if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
2967 mvar->head = cap->rCurrentTSO;
2969 mvar->tail->link = cap->rCurrentTSO;
2971 cap->rCurrentTSO->link = (StgTSO *)&END_TSO_QUEUE_closure;
2972 cap->rCurrentTSO->why_blocked = BlockedOnMVar;
2973 cap->rCurrentTSO->block_info.closure = (StgClosure *)mvar;
2974 mvar->tail = cap->rCurrentTSO;
2976 /* At this point, the top-of-stack holds the MVar,
2977 and underneath is the world token (). So the
2978 stack is in the same state as when primTakeMVar
2979 was entered (primTakeMVar is handwritten bytecode).
2980 Push obj, which is this BCO, and return to the
2981 scheduler. When the MVar is filled, the scheduler
2982 will re-enter primTakeMVar, with the args still on
2983 the top of the stack.
2985 PushCPtr((StgClosure*)(*bco));
2986 *return2 = ThreadBlocked;
2987 return (void*)(1+(NULL));
2990 PushCPtr(mvar->value);
2991 mvar->value = (StgClosure *)&END_TSO_QUEUE_closure;
2992 SET_INFO(mvar,&EMPTY_MVAR_info);
2998 StgMVar* mvar = stgCast(StgMVar*,PopPtr());
2999 StgClosure* value = PopCPtr();
3000 if (GET_INFO(mvar) == &FULL_MVAR_info) {
3001 return (makeErrorCall("putMVar {full MVar}"));
3003 /* wake up the first thread on the
3004 * queue, it will continue with the
3005 * takeMVar operation and mark the
3008 mvar->value = value;
3010 if (mvar->head != (StgTSO *)&END_TSO_QUEUE_closure) {
3011 ASSERT(mvar->head->why_blocked == BlockedOnMVar);
3012 mvar->head = unblockOne(mvar->head);
3013 if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
3014 mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
3018 /* unlocks the MVar in the SMP case */
3019 SET_INFO(mvar,&FULL_MVAR_info);
3021 /* yield for better communication performance */
3027 { /* identical to i_sameRef */
3028 StgMVar* x = (StgMVar*)PopPtr();
3029 StgMVar* y = (StgMVar*)PopPtr();
3030 PushTaggedBool(x==y);
3035 StgWord tid = cap->rCurrentTSO->id;
3036 PushTaggedWord(tid);
3039 case i_cmpThreadIds:
3041 StgWord tid1 = PopTaggedWord();
3042 StgWord tid2 = PopTaggedWord();
3043 if (tid1 < tid2) PushTaggedInt(-1);
3044 else if (tid1 > tid2) PushTaggedInt(1);
3045 else PushTaggedInt(0);
3050 StgClosure* closure;
3053 closure = PopCPtr();
3054 tso = createGenThread (RtsFlags.GcFlags.initialStkSize,closure);
3056 scheduleThread(tso);
3058 PushTaggedWord(tid);
3062 #ifdef PROVIDE_CONCURRENT
3065 StgTSO* tso = stgCast(StgTSO*,PopPtr());
3067 if (tso == cap->rCurrentTSO) { /* suicide */
3068 *return2 = ThreadFinished;
3069 return (void*)(1+(NULL));
3076 ToDo: another way out of the problem might be to add an explicit
3077 continuation to primTakeMVar: takeMVar v = primTakeMVar v takeMVar.
3078 The problem with this plan is that now I dont know how much to chop
3085 /* As PrimOps.h says: Hmm, I'll think about these later. */
3088 #endif /* PROVIDE_CONCURRENT */
3090 case i_ccall_ccall_Id:
3091 case i_ccall_ccall_IO:
3092 case i_ccall_stdcall_Id:
3093 case i_ccall_stdcall_IO:
3096 CFunDescriptor* descriptor;
3097 void (*funPtr)(void);
3099 descriptor = PopTaggedAddr();
3100 funPtr = PopTaggedAddr();
3101 cc = (primop2code == i_ccall_stdcall_Id ||
3102 primop2code == i_ccall_stdcall_IO)
3104 r = ccall(descriptor,funPtr,bco,cc,cap);
3107 return makeErrorCall(
3108 "unhandled type or too many args/results in ccall");
3110 barf("ccall not configured correctly for this platform");
3111 barf("unknown return code from ccall");
3114 barf("Unrecognised primop2");
3120 /* -----------------------------------------------------------------------------
3121 * ccall support code:
3122 * marshall moves args from C stack to Haskell stack
3123 * unmarshall moves args from Haskell stack to C stack
3124 * argSize calculates how much gSpace you need on the C stack
3125 * ---------------------------------------------------------------------------*/
3127 /* Pop arguments off the C stack and Push them onto the Hugs stack.
3128 * Used when preparing for C calling Haskell or in regSponse to
3129 * Haskell calling C.
3131 nat marshall(char arg_ty, void* arg)
3135 PushTaggedInt(*((int*)arg));
3136 return ARG_SIZE(INT_TAG);
3137 #ifdef TODO_STANDALONE_INTEGER
3139 PushTaggedInteger(*((mpz_ptr*)arg));
3140 return ARG_SIZE(INTEGER_TAG);
3143 PushTaggedWord(*((unsigned int*)arg));
3144 return ARG_SIZE(WORD_TAG);
3146 PushTaggedChar(*((char*)arg));
3147 return ARG_SIZE(CHAR_TAG);
3149 PushTaggedFloat(*((float*)arg));
3150 return ARG_SIZE(FLOAT_TAG);
3152 PushTaggedDouble(*((double*)arg));
3153 return ARG_SIZE(DOUBLE_TAG);
3155 PushTaggedAddr(*((void**)arg));
3156 return ARG_SIZE(ADDR_TAG);
3158 PushTaggedStablePtr(*((StgStablePtr*)arg));
3159 return ARG_SIZE(STABLE_TAG);
3160 #ifdef PROVIDE_FOREIGN
3162 /* Not allowed in this direction - you have to
3163 * call makeForeignPtr explicitly
3165 barf("marshall: ForeignPtr#\n");
3170 /* Not allowed in this direction */
3171 barf("marshall: [Mutable]ByteArray#\n");
3174 barf("marshall: unrecognised arg type %d\n",arg_ty);
3179 /* Pop arguments off the Hugs stack and Push them onto the C stack.
3180 * Used when preparing for Haskell calling C or in regSponse to
3181 * C calling Haskell.
3183 nat unmarshall(char res_ty, void* res)
3187 *((int*)res) = PopTaggedInt();
3188 return ARG_SIZE(INT_TAG);
3189 #ifdef TODO_STANDALONE_INTEGER
3191 *((mpz_ptr*)res) = PopTaggedInteger();
3192 return ARG_SIZE(INTEGER_TAG);
3195 *((unsigned int*)res) = PopTaggedWord();
3196 return ARG_SIZE(WORD_TAG);
3198 *((int*)res) = PopTaggedChar();
3199 return ARG_SIZE(CHAR_TAG);
3201 *((float*)res) = PopTaggedFloat();
3202 return ARG_SIZE(FLOAT_TAG);
3204 *((double*)res) = PopTaggedDouble();
3205 return ARG_SIZE(DOUBLE_TAG);
3207 *((void**)res) = PopTaggedAddr();
3208 return ARG_SIZE(ADDR_TAG);
3210 *((StgStablePtr*)res) = PopTaggedStablePtr();
3211 return ARG_SIZE(STABLE_TAG);
3212 #ifdef PROVIDE_FOREIGN
3215 StgForeignObj *result = stgCast(StgForeignObj*,PopPtr());
3216 *((void**)res) = result->data;
3217 return sizeofW(StgPtr);
3223 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
3224 *((void**)res) = stgCast(void*,&(arr->payload));
3225 return sizeofW(StgPtr);
3228 barf("unmarshall: unrecognised result type %d\n",res_ty);
3232 nat argSize( const char* ks )
3235 for( ; *ks != '\0'; ++ks) {
3238 sz += sizeof(StgWord) * ARG_SIZE(INT_TAG);
3240 #ifdef TODO_STANDALONE_INTEGER
3242 sz += sizeof(StgWord) * ARG_SIZE(INTEGER_TAG);
3246 sz += sizeof(StgWord) * ARG_SIZE(WORD_TAG);
3249 sz += sizeof(StgWord) * ARG_SIZE(CHAR_TAG);
3252 sz += sizeof(StgWord) * ARG_SIZE(FLOAT_TAG);
3255 sz += sizeof(StgWord) * ARG_SIZE(DOUBLE_TAG);
3258 sz += sizeof(StgWord) * ARG_SIZE(ADDR_TAG);
3261 sz += sizeof(StgWord) * ARG_SIZE(STABLE_TAG);
3263 #ifdef PROVIDE_FOREIGN
3268 sz += sizeof(StgPtr);
3271 barf("argSize: unrecognised result type %d\n",*ks);
3279 /* -----------------------------------------------------------------------------
3280 * encode/decode Float/Double code for standalone Hugs
3281 * Code based on the HBC code (lib/fltcode.c) and more recently GHC
3282 * (ghc/rts/StgPrimFloat.c)
3283 * ---------------------------------------------------------------------------*/
3285 #ifdef STANDALONE_INTEGER
3287 #if IEEE_FLOATING_POINT
3288 #define MY_DMINEXP ((DBL_MIN_EXP) - (DBL_MANT_DIG) - 1)
3289 /* DMINEXP is defined in values.h on Linux (for example) */
3290 #define DHIGHBIT 0x00100000
3291 #define DMSBIT 0x80000000
3293 #define MY_FMINEXP ((FLT_MIN_EXP) - (FLT_MANT_DIG) - 1)
3294 #define FHIGHBIT 0x00800000
3295 #define FMSBIT 0x80000000
3297 #error The following code doesnt work in a non-IEEE FP environment
3300 #ifdef WORDS_BIGENDIAN
3309 StgDouble B__encodeDouble (B* s, I_ e) /* result = s * 2^e */
3314 /* Convert a B to a double; knows a lot about internal rep! */
3315 for(r = 0.0, i = s->used-1; i >= 0; i--)
3316 r = (r * B_BASE_FLT) + s->stuff[i];
3318 /* Now raise to the exponent */
3319 if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
3322 /* handle the sign */
3323 if (s->sign < 0) r = -r;
3330 #if ! FLOATS_AS_DOUBLES
3331 StgFloat B__encodeFloat (B* s, I_ e) /* result = s * 2^e */
3336 /* Convert a B to a float; knows a lot about internal rep! */
3337 for(r = 0.0, i = s->used-1; i >= 0; i--)
3338 r = (r * B_BASE_FLT) + s->stuff[i];
3340 /* Now raise to the exponent */
3341 if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
3344 /* handle the sign */
3345 if (s->sign < 0) r = -r;
3349 #endif /* FLOATS_AS_DOUBLES */
3353 /* This only supports IEEE floating point */
3354 void B__decodeDouble (B* man, I_* exp, StgDouble dbl)
3356 /* Do some bit fiddling on IEEE */
3357 nat low, high; /* assuming 32 bit ints */
3359 union { double d; int i[2]; } u; /* assuming 32 bit ints, 64 bit double */
3361 u.d = dbl; /* grab chunks of the double */
3365 ASSERT(B_BASE == 256);
3367 /* Assume that the supplied B is the right size */
3370 if (low == 0 && (high & ~DMSBIT) == 0) {
3371 man->sign = man->used = 0;
3376 iexp = ((high >> 20) & 0x7ff) + MY_DMINEXP;
3380 if (iexp != MY_DMINEXP) /* don't add hidden bit to denorms */
3384 /* A denorm, normalize the mantissa */
3385 while (! (high & DHIGHBIT)) {
3395 man->stuff[7] = (((W_)high) >> 24) & 0xff;
3396 man->stuff[6] = (((W_)high) >> 16) & 0xff;
3397 man->stuff[5] = (((W_)high) >> 8) & 0xff;
3398 man->stuff[4] = (((W_)high) ) & 0xff;
3400 man->stuff[3] = (((W_)low) >> 24) & 0xff;
3401 man->stuff[2] = (((W_)low) >> 16) & 0xff;
3402 man->stuff[1] = (((W_)low) >> 8) & 0xff;
3403 man->stuff[0] = (((W_)low) ) & 0xff;
3405 if (sign < 0) man->sign = -1;
3407 do_renormalise(man);
3411 #if ! FLOATS_AS_DOUBLES
3412 void B__decodeFloat (B* man, I_* exp, StgFloat flt)
3414 /* Do some bit fiddling on IEEE */
3415 int high, sign; /* assuming 32 bit ints */
3416 union { float f; int i; } u; /* assuming 32 bit float and int */
3418 u.f = flt; /* grab the float */
3421 ASSERT(B_BASE == 256);
3423 /* Assume that the supplied B is the right size */
3426 if ((high & ~FMSBIT) == 0) {
3427 man->sign = man->used = 0;
3432 *exp = ((high >> 23) & 0xff) + MY_FMINEXP;
3436 if (*exp != MY_FMINEXP) /* don't add hidden bit to denorms */
3440 /* A denorm, normalize the mantissa */
3441 while (! (high & FHIGHBIT)) {
3446 man->stuff[3] = (((W_)high) >> 24) & 0xff;
3447 man->stuff[2] = (((W_)high) >> 16) & 0xff;
3448 man->stuff[1] = (((W_)high) >> 8) & 0xff;
3449 man->stuff[0] = (((W_)high) ) & 0xff;
3451 if (sign < 0) man->sign = -1;
3453 do_renormalise(man);
3456 #endif /* FLOATS_AS_DOUBLES */
3458 #endif /* STANDALONE_INTEGER */
3460 #endif /* INTERPRETER */