2 /* -----------------------------------------------------------------------------
5 * Copyright (c) 1994-1998.
7 * $RCSfile: Evaluator.c,v $
9 * $Date: 1999/12/07 11:49:11 $
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 );
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(stgCast(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));
921 SSS; o = (StgClosure*)grabHpNonUpd(Izh_sizeW); LLL;
922 SET_HDR(o,&Izh_con_info,??);
923 payloadWord(o,0) = xPopTaggedInt();
925 fprintf(stderr,"\tBuilt ");
927 printObj(stgCast(StgClosure*,o));
930 xPushPtr(stgCast(StgPtr,o));
935 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
936 /* ASSERT(isIntLike(con)); */
937 xPushTaggedInt(payloadWord(con,0));
942 StgWord offset = BCO_INSTR_16;
943 StgInt x = xPopTaggedInt();
944 StgInt y = xPopTaggedInt();
950 Case(i_CONST_INTEGER):
954 char* s = bcoConstAddr(bco,BCO_INSTR_8);
957 p = CreateByteArrayToHoldInteger(n);
958 do_fromStr ( s, n, IntegerInsideByteArray(p));
959 SloppifyIntegerEnd(p);
966 StgWord w = xTaggedStackWord(BCO_INSTR_8);
972 xPushTaggedWord(bcoConstWord(bco,BCO_INSTR_8));
978 SSS; o = (StgClosure*)grabHpNonUpd(Wzh_sizeW); LLL;
979 SET_HDR(o,&Wzh_con_info,??);
980 payloadWord(o,0) = xPopTaggedWord();
982 fprintf(stderr,"\tBuilt ");
984 printObj(stgCast(StgClosure*,o));
987 xPushPtr(stgCast(StgPtr,o));
992 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
993 /* ASSERT(isWordLike(con)); */
994 xPushTaggedWord(payloadWord(con,0));
999 StgAddr a = xTaggedStackAddr(BCO_INSTR_8);
1005 xPushTaggedAddr(bcoConstAddr(bco,BCO_INSTR_8));
1011 SSS; o = (StgClosure*)grabHpNonUpd(Azh_sizeW); LLL;
1012 SET_HDR(o,&Azh_con_info,??);
1013 payloadPtr(o,0) = xPopTaggedAddr();
1015 fprintf(stderr,"\tBuilt ");
1017 printObj(stgCast(StgClosure*,o));
1020 xPushPtr(stgCast(StgPtr,o));
1023 Case(i_UNPACK_ADDR):
1025 StgClosure* con = (StgClosure*)xStackPtr(0);
1026 /* ASSERT(isAddrLike(con)); */
1027 xPushTaggedAddr(payloadPtr(con,0));
1032 StgChar c = xTaggedStackChar(BCO_INSTR_8);
1038 xPushTaggedChar(bcoConstChar(bco,BCO_INSTR_8));
1044 SSS; o = (StgClosure*)grabHpNonUpd(Czh_sizeW); LLL;
1045 SET_HDR(o,&Czh_con_info,??);
1046 payloadWord(o,0) = xPopTaggedChar();
1047 xPushPtr(stgCast(StgPtr,o));
1049 fprintf(stderr,"\tBuilt ");
1051 printObj(stgCast(StgClosure*,o));
1056 Case(i_UNPACK_CHAR):
1058 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1059 /* ASSERT(isCharLike(con)); */
1060 xPushTaggedChar(payloadWord(con,0));
1065 StgFloat f = xTaggedStackFloat(BCO_INSTR_8);
1066 xPushTaggedFloat(f);
1069 Case(i_CONST_FLOAT):
1071 xPushTaggedFloat(bcoConstFloat(bco,BCO_INSTR_8));
1077 SSS; o = (StgClosure*)grabHpNonUpd(Fzh_sizeW); LLL;
1078 SET_HDR(o,&Fzh_con_info,??);
1079 ASSIGN_FLT(&payloadWord(o,0),xPopTaggedFloat());
1081 fprintf(stderr,"\tBuilt ");
1083 printObj(stgCast(StgClosure*,o));
1086 xPushPtr(stgCast(StgPtr,o));
1089 Case(i_UNPACK_FLOAT):
1091 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1092 /* ASSERT(isFloatLike(con)); */
1093 xPushTaggedFloat(PK_FLT(&payloadWord(con,0)));
1098 StgDouble d = xTaggedStackDouble(BCO_INSTR_8);
1099 xPushTaggedDouble(d);
1102 Case(i_CONST_DOUBLE):
1104 xPushTaggedDouble(bcoConstDouble(bco,BCO_INSTR_8));
1107 Case(i_CONST_DOUBLE_big):
1109 int n = BCO_INSTR_16;
1110 xPushTaggedDouble(bcoConstDouble(bco,n));
1113 Case(i_PACK_DOUBLE):
1116 SSS; o = (StgClosure*)grabHpNonUpd(Dzh_sizeW); LLL;
1117 SET_HDR(o,&Dzh_con_info,??);
1118 ASSIGN_DBL(&payloadWord(o,0),xPopTaggedDouble());
1120 fprintf(stderr,"\tBuilt ");
1121 printObj(stgCast(StgClosure*,o));
1123 xPushPtr(stgCast(StgPtr,o));
1126 Case(i_UNPACK_DOUBLE):
1128 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1129 /* ASSERT(isDoubleLike(con)); */
1130 xPushTaggedDouble(PK_DBL(&payloadWord(con,0)));
1135 StgStablePtr s = xTaggedStackStable(BCO_INSTR_8);
1136 xPushTaggedStable(s);
1139 Case(i_PACK_STABLE):
1142 SSS; o = (StgClosure*)grabHpNonUpd(Stablezh_sizeW); LLL;
1143 SET_HDR(o,&StablePtr_con_info,??);
1144 payloadWord(o,0) = xPopTaggedStable();
1146 fprintf(stderr,"\tBuilt ");
1148 printObj(stgCast(StgClosure*,o));
1151 xPushPtr(stgCast(StgPtr,o));
1154 Case(i_UNPACK_STABLE):
1156 StgClosure* con = (StgClosure*)xStackPtr(0);
1157 /* ASSERT(isStableLike(con)); */
1158 xPushTaggedStable(payloadWord(con,0));
1166 SSS; p = enterBCO_primop1 ( i ); LLL;
1167 if (p) { obj = p; goto enterLoop; };
1172 int i, trc, pc_saved;
1175 trc = 12345678; /* Assume != any StgThreadReturnCode */
1180 p = enterBCO_primop2 ( i, &trc, &bco_tmp, cap );
1183 bciPtr = &(bcoInstr(bco,pc_saved));
1185 if (trc == 12345678) {
1186 /* we want to enter p */
1187 obj = p; goto enterLoop;
1189 /* trc is the the StgThreadReturnCode for this thread */
1190 RETURN((StgThreadReturnCode)trc);
1196 /* combined insns, created by peephole opt */
1199 int x = BCO_INSTR_8;
1200 int y = BCO_INSTR_8;
1201 ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
1202 /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
1209 xSetStackWord(x+y,xStackWord(x));
1219 p = xStackPtr(BCO_INSTR_8);
1221 p = xStackPtr(BCO_INSTR_8);
1228 xPushPtr(bcoConstPtr(bco,BCO_INSTR_8));
1229 xPushPtr(stgCast(StgPtr,&ret_bco_info));
1230 p = xStackPtr(BCO_INSTR_8);
1236 StgPtr retaddr = bcoConstPtr(bco,BCO_INSTR_8);
1237 StgPtr ptr = xStackPtr(BCO_INSTR_8);
1239 /* A shortcut. We're going to push the address of a
1240 return continuation, and then enter a variable, so
1241 that when the var is evaluated, we return to the
1242 continuation. The shortcut is: if the var is a
1243 constructor, don't bother to enter it. Instead,
1244 push the variable on the stack (since this is what
1245 the continuation expects) and jump directly to the
1248 if (get_itbl((StgClosure*)ptr)->type == CONSTR) {
1250 obj = (StgClosure*)retaddr;
1252 fprintf(stderr, "object to enter is a constructor -- "
1253 "jumping directly to return continuation\n" );
1258 /* This is the normal, non-short-cut route */
1260 xPushPtr(stgCast(StgPtr,&ret_bco_info));
1261 obj = (StgClosure*)ptr;
1266 Case(i_VAR_DOUBLE_big):
1267 Case(i_CONST_FLOAT_big):
1268 Case(i_VAR_FLOAT_big):
1269 Case(i_CONST_CHAR_big):
1270 Case(i_VAR_CHAR_big):
1271 Case(i_CONST_ADDR_big):
1272 Case(i_VAR_ADDR_big):
1273 Case(i_VAR_STABLE_big):
1274 Case(i_CONST_INTEGER_big):
1275 Case(i_CONST_INT_big):
1276 Case(i_VAR_INT_big):
1277 Case(i_VAR_WORD_big):
1278 Case(i_RETADDR_big):
1282 disInstr ( bco, PC );
1283 barf("\nUnrecognised instruction");
1287 barf("enterBCO: ran off end of loop");
1291 # undef LoopTopLabel
1297 /* ---------------------------------------------------- */
1298 /* End of the bytecode evaluator */
1299 /* ---------------------------------------------------- */
1303 StgBlockingQueue* bh;
1304 StgCAF* caf = (StgCAF*)obj;
1305 if (xSp - sizeofW(StgUpdateFrame) < xSpLim) {
1306 xPushCPtr(obj); /* code to restart with */
1307 RETURN(StackOverflow);
1309 /* ToDo: look for xSp==xSu && stackInt(0) == UPD_FRAME
1310 and insert an indirection immediately */
1311 SSS; bh = (StgBlockingQueue*)grabHpUpd(BLACKHOLE_sizeW()); LLL;
1312 SET_INFO(bh,&CAF_BLACKHOLE_info);
1313 bh->blocking_queue = EndTSOQueue;
1315 fprintf(stderr,"Created CAF_BLACKHOLE %p for CAF %p in evaluator\n",bh,caf));
1316 SET_INFO(caf,&CAF_ENTERED_info);
1317 caf->value = (StgClosure*)bh;
1318 if (caf->mut_link == NULL) {
1319 SSS; recordOldToNewPtrs((StgMutClosure*)caf); LLL;
1321 xPushUpdateFrame(bh,0);
1322 xSp -= sizeofW(StgUpdateFrame);
1323 caf->link = enteredCAFs;
1330 StgCAF* caf = (StgCAF*)obj;
1331 obj = caf->value; /* it's just a fancy indirection */
1337 case SE_CAF_BLACKHOLE:
1339 /* Let the scheduler figure out what to do :-) */
1340 cap->rCurrentTSO->whatNext = ThreadEnterGHC;
1342 RETURN(ThreadYielding);
1346 StgAP_UPD* ap = stgCast(StgAP_UPD*,obj);
1348 if (xSp - (i + sizeofW(StgUpdateFrame)) < xSpLim) {
1349 xPushCPtr(obj); /* code to restart with */
1350 RETURN(StackOverflow);
1352 /* ToDo: look for xSp==xSu && stackInt(0) == UPD_FRAME
1353 and insert an indirection immediately */
1354 xPushUpdateFrame(ap,0);
1355 xSp -= sizeofW(StgUpdateFrame);
1357 xPushWord(payloadWord(ap,i));
1360 #ifdef EAGER_BLACKHOLING
1361 #warn LAZY_BLACKHOLING is default for StgHugs
1362 #error Dont know if EAGER_BLACKHOLING works in StgHugs
1364 /* superfluous - but makes debugging easier */
1365 StgBlackHole* bh = stgCast(StgBlackHole*,ap);
1366 SET_INFO(bh,&BLACKHOLE_info);
1367 bh->blocking_queue = EndTSOQueue;
1369 fprintf(stderr,"Eagerly blackholed AP_UPD %p in evaluator\n",bh));
1372 #endif /* EAGER_BLACKHOLING */
1377 StgPAP* pap = stgCast(StgPAP*,obj);
1378 int i = pap->n_args; /* ToDo: stack check */
1379 /* ToDo: if PAP is in whnf, we can update any update frames
1383 xPushWord(payloadWord(pap,i));
1390 obj = stgCast(StgInd*,obj)->indirectee;
1395 obj = stgCast(StgIndOldGen*,obj)->indirectee;
1404 case CONSTR_INTLIKE:
1405 case CONSTR_CHARLIKE:
1407 case CONSTR_NOCAF_STATIC:
1410 switch (get_itbl(stgCast(StgClosure*,xSp))->type) {
1412 SSS; PopCatchFrame(); LLL;
1415 xPopUpdateFrame(obj);
1418 SSS; PopSeqFrame(); LLL;
1422 ASSERT(xSp==(P_)xSu);
1425 fprintf(stderr, "hit a STOP_FRAME\n");
1427 fprintf(stderr,"xSp = %p\txSu = %p\n", xSp, xSu);
1428 printStack(xSp,cap->rCurrentTSO->stack
1429 + cap->rCurrentTSO->stack_size,xSu);
1432 SSS; PopStopFrame(obj); LLL;
1433 RETURN(ThreadFinished);
1443 /* was: goto enterLoop;
1444 But we know that obj must be a bco now, so jump directly.
1447 case RET_SMALL: /* return to GHC */
1451 // barf("todo: RET_[VEC_]{BIG,SMALL}");
1453 belch("entered CONSTR with invalid continuation on stack");
1456 printObj(stgCast(StgClosure*,xSp));
1459 barf("bailing out");
1466 //fprintf(stderr, "enterCountI = %d\n", enterCountI);
1467 //fprintf(stderr, "entering unknown closure -- yielding to sched\n");
1470 cap->rCurrentTSO->whatNext = ThreadEnterGHC;
1471 xPushCPtr(obj); /* code to restart with */
1472 RETURN(ThreadYielding);
1475 barf("Ran off the end of enter - yoiks");
1492 #undef xSetStackWord
1495 #undef xPushTaggedInt
1496 #undef xPopTaggedInt
1497 #undef xTaggedStackInt
1498 #undef xPushTaggedWord
1499 #undef xPopTaggedWord
1500 #undef xTaggedStackWord
1501 #undef xPushTaggedAddr
1502 #undef xTaggedStackAddr
1503 #undef xPopTaggedAddr
1504 #undef xPushTaggedStable
1505 #undef xTaggedStackStable
1506 #undef xPopTaggedStable
1507 #undef xPushTaggedChar
1508 #undef xTaggedStackChar
1509 #undef xPopTaggedChar
1510 #undef xPushTaggedFloat
1511 #undef xTaggedStackFloat
1512 #undef xPopTaggedFloat
1513 #undef xPushTaggedDouble
1514 #undef xTaggedStackDouble
1515 #undef xPopTaggedDouble
1516 #undef xPopUpdateFrame
1517 #undef xPushUpdateFrame
1520 /* --------------------------------------------------------------------------
1521 * Supporting routines for primops
1522 * ------------------------------------------------------------------------*/
1524 static inline void PushTag ( StackTag t )
1526 inline void PushPtr ( StgPtr x )
1527 { *(--stgCast(StgPtr*,gSp)) = x; }
1528 static inline void PushCPtr ( StgClosure* x )
1529 { *(--stgCast(StgClosure**,gSp)) = x; }
1530 static inline void PushInt ( StgInt x )
1531 { *(--stgCast(StgInt*,gSp)) = x; }
1532 static inline void PushWord ( StgWord x )
1533 { *(--stgCast(StgWord*,gSp)) = x; }
1536 static inline void checkTag ( StackTag t1, StackTag t2 )
1537 { ASSERT(t1 == t2);}
1538 static inline void PopTag ( StackTag t )
1539 { checkTag(t,*(gSp++)); }
1540 inline StgPtr PopPtr ( void )
1541 { return *stgCast(StgPtr*,gSp)++; }
1542 static inline StgClosure* PopCPtr ( void )
1543 { return *stgCast(StgClosure**,gSp)++; }
1544 static inline StgInt PopInt ( void )
1545 { return *stgCast(StgInt*,gSp)++; }
1546 static inline StgWord PopWord ( void )
1547 { return *stgCast(StgWord*,gSp)++; }
1549 static inline StgPtr stackPtr ( StgStackOffset i )
1550 { return *stgCast(StgPtr*, gSp+i); }
1551 static inline StgInt stackInt ( StgStackOffset i )
1552 { return *stgCast(StgInt*, gSp+i); }
1553 static inline StgWord stackWord ( StgStackOffset i )
1554 { return *stgCast(StgWord*,gSp+i); }
1556 static inline void setStackWord ( StgStackOffset i, StgWord w )
1559 static inline void PushTaggedRealWorld( void )
1560 { PushTag(REALWORLD_TAG); }
1561 inline void PushTaggedInt ( StgInt x )
1562 { gSp -= sizeofW(StgInt); *gSp = x; PushTag(INT_TAG); }
1563 inline void PushTaggedWord ( StgWord x )
1564 { gSp -= sizeofW(StgWord); *gSp = x; PushTag(WORD_TAG); }
1565 inline void PushTaggedAddr ( StgAddr x )
1566 { gSp -= sizeofW(StgAddr); *gSp = (W_)x; PushTag(ADDR_TAG); }
1567 inline void PushTaggedChar ( StgChar x )
1568 { gSp -= sizeofW(StgChar); *gSp = stgCast(StgWord,x); PushTag(CHAR_TAG); }
1569 inline void PushTaggedFloat ( StgFloat x )
1570 { gSp -= sizeofW(StgFloat); ASSIGN_FLT(gSp,x); PushTag(FLOAT_TAG); }
1571 inline void PushTaggedDouble ( StgDouble x )
1572 { gSp -= sizeofW(StgDouble); ASSIGN_DBL(gSp,x); PushTag(DOUBLE_TAG); }
1573 inline void PushTaggedStablePtr ( StgStablePtr x )
1574 { gSp -= sizeofW(StgStablePtr); *gSp = x; PushTag(STABLE_TAG); }
1575 static inline void PushTaggedBool ( int x )
1576 { PushTaggedInt(x); }
1580 static inline void PopTaggedRealWorld ( void )
1581 { PopTag(REALWORLD_TAG); }
1582 inline StgInt PopTaggedInt ( void )
1583 { StgInt r; PopTag(INT_TAG); r = *stgCast(StgInt*, gSp);
1584 gSp += sizeofW(StgInt); return r;}
1585 inline StgWord PopTaggedWord ( void )
1586 { StgWord r; PopTag(WORD_TAG); r = *stgCast(StgWord*, gSp);
1587 gSp += sizeofW(StgWord); return r;}
1588 inline StgAddr PopTaggedAddr ( void )
1589 { StgAddr r; PopTag(ADDR_TAG); r = *stgCast(StgAddr*, gSp);
1590 gSp += sizeofW(StgAddr); return r;}
1591 inline StgChar PopTaggedChar ( void )
1592 { StgChar r; PopTag(CHAR_TAG); r = stgCast(StgChar, *gSp);
1593 gSp += sizeofW(StgChar); return r;}
1594 inline StgFloat PopTaggedFloat ( void )
1595 { StgFloat r; PopTag(FLOAT_TAG); r = PK_FLT(gSp);
1596 gSp += sizeofW(StgFloat); return r;}
1597 inline StgDouble PopTaggedDouble ( void )
1598 { StgDouble r; PopTag(DOUBLE_TAG); r = PK_DBL(gSp);
1599 gSp += sizeofW(StgDouble); return r;}
1600 inline StgStablePtr PopTaggedStablePtr ( void )
1601 { StgInt r; PopTag(STABLE_TAG); r = *stgCast(StgStablePtr*, gSp);
1602 gSp += sizeofW(StgStablePtr); return r;}
1606 static inline StgInt taggedStackInt ( StgStackOffset i )
1607 { checkTag(INT_TAG,gSp[i]); return *stgCast(StgInt*, gSp+1+i); }
1608 static inline StgWord taggedStackWord ( StgStackOffset i )
1609 { checkTag(WORD_TAG,gSp[i]); return *stgCast(StgWord*, gSp+1+i); }
1610 static inline StgAddr taggedStackAddr ( StgStackOffset i )
1611 { checkTag(ADDR_TAG,gSp[i]); return *stgCast(StgAddr*, gSp+1+i); }
1612 static inline StgChar taggedStackChar ( StgStackOffset i )
1613 { checkTag(CHAR_TAG,gSp[i]); return stgCast(StgChar, *(gSp+1+i)) ; }
1614 static inline StgFloat taggedStackFloat ( StgStackOffset i )
1615 { checkTag(FLOAT_TAG,gSp[i]); return PK_FLT(gSp+1+i); }
1616 static inline StgDouble taggedStackDouble ( StgStackOffset i )
1617 { checkTag(DOUBLE_TAG,gSp[i]); return PK_DBL(gSp+1+i); }
1618 static inline StgStablePtr taggedStackStable ( StgStackOffset i )
1619 { checkTag(STABLE_TAG,gSp[i]); return *stgCast(StgStablePtr*, gSp+1+i); }
1622 /* --------------------------------------------------------------------------
1625 * Should we allocate from a nursery or use the
1626 * doYouWantToGC/allocate interface? We'd already implemented a
1627 * nursery-style scheme when the doYouWantToGC/allocate interface
1629 * One reason to prefer the doYouWantToGC/allocate interface is to
1630 * support operations which allocate an unknown amount in the heap
1631 * (array ops, gmp ops, etc)
1632 * ------------------------------------------------------------------------*/
1634 static inline StgPtr grabHpUpd( nat size )
1636 ASSERT( size >= MIN_UPD_SIZE + sizeofW(StgHeader) );
1637 #ifdef CRUDE_PROFILING
1638 cp_bill_words ( size );
1640 return allocate(size);
1643 static inline StgPtr grabHpNonUpd( nat size )
1645 ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
1646 #ifdef CRUDE_PROFILING
1647 cp_bill_words ( size );
1649 return allocate(size);
1652 /* --------------------------------------------------------------------------
1653 * Manipulate "update frame" list:
1654 * o Update frames (based on stg_do_update and friends in Updates.hc)
1655 * o Error handling/catching (based on catchzh_fast and friends in Prims.hc)
1656 * o Seq frames (based on seq_frame_entry in Prims.hc)
1658 * ------------------------------------------------------------------------*/
1660 static inline void PopUpdateFrame ( StgClosure* obj )
1662 /* NB: doesn't assume that gSp == gSu */
1664 fprintf(stderr, "Updating ");
1665 printPtr(stgCast(StgPtr,gSu->updatee));
1666 fprintf(stderr, " with ");
1668 fprintf(stderr,"gSp = %p\tgSu = %p\n\n", gSp, gSu);
1670 #ifdef EAGER_BLACKHOLING
1671 #warn LAZY_BLACKHOLING is default for StgHugs
1672 #error Dont know if EAGER_BLACKHOLING works in StgHugs
1673 ASSERT(get_itbl(gSu->updatee)->type == BLACKHOLE
1674 || get_itbl(gSu->updatee)->type == SE_BLACKHOLE
1675 || get_itbl(gSu->updatee)->type == CAF_BLACKHOLE
1676 || get_itbl(gSu->updatee)->type == SE_CAF_BLACKHOLE
1678 #endif /* EAGER_BLACKHOLING */
1679 UPD_IND(gSu->updatee,obj);
1680 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgUpdateFrame);
1684 static inline void PopStopFrame ( StgClosure* obj )
1686 /* Move gSu just off the end of the stack, we're about to gSpam the
1687 * STOP_FRAME with the return value.
1689 gSu = stgCast(StgUpdateFrame*,gSp+1);
1690 *stgCast(StgClosure**,gSp) = obj;
1693 static inline void PushCatchFrame ( StgClosure* handler )
1696 /* ToDo: stack check! */
1697 gSp -= sizeofW(StgCatchFrame);
1698 fp = stgCast(StgCatchFrame*,gSp);
1699 SET_HDR(fp,(StgInfoTable*)&catch_frame_info,CCCS);
1700 fp->handler = handler;
1702 gSu = stgCast(StgUpdateFrame*,fp);
1705 static inline void PopCatchFrame ( void )
1707 /* NB: doesn't assume that gSp == gSu */
1708 /* fprintf(stderr,"Popping catch frame\n"); */
1709 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgCatchFrame);
1710 gSu = stgCast(StgCatchFrame*,gSu)->link;
1713 static inline void PushSeqFrame ( void )
1716 /* ToDo: stack check! */
1717 gSp -= sizeofW(StgSeqFrame);
1718 fp = stgCast(StgSeqFrame*,gSp);
1719 SET_HDR(fp,(StgInfoTable*)&seq_frame_info,CCCS);
1721 gSu = stgCast(StgUpdateFrame*,fp);
1724 static inline void PopSeqFrame ( void )
1726 /* NB: doesn't assume that gSp == gSu */
1727 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgSeqFrame);
1728 gSu = stgCast(StgSeqFrame*,gSu)->link;
1731 static inline StgClosure* raiseAnError ( StgClosure* exception )
1733 /* This closure represents the expression 'primRaise E' where E
1734 * is the exception raised (:: Exception).
1735 * It is used to overwrite all the
1736 * thunks which are currently under evaluation.
1738 HaskellObj primRaiseClosure
1739 = asmClosureOfObject(getHugs_AsmObject_for("primRaise"));
1740 HaskellObj reraiseClosure
1741 = rts_apply ( primRaiseClosure, exception );
1744 switch (get_itbl(gSu)->type) {
1746 UPD_IND(gSu->updatee,reraiseClosure);
1747 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgUpdateFrame);
1753 case CATCH_FRAME: /* found it! */
1755 StgCatchFrame* fp = stgCast(StgCatchFrame*,gSu);
1756 StgClosure *handler = fp->handler;
1758 gSp += sizeofW(StgCatchFrame); /* Pop */
1759 PushCPtr(exception);
1763 barf("raiseError: uncaught exception: STOP_FRAME");
1765 barf("raiseError: weird activation record");
1771 static StgClosure* makeErrorCall ( const char* msg )
1773 /* Note! the msg string should be allocated in a
1774 place which will not get freed -- preferably
1775 read-only data of the program. That's because
1776 the thunk we build here may linger indefinitely.
1777 (thinks: probably not so, but anyway ...)
1780 = asmClosureOfObject(getHugs_AsmObject_for("error"));
1782 = asmClosureOfObject(getHugs_AsmObject_for("primUnpackString"));
1784 = rts_apply ( unpack, rts_mkAddr ( (void*)msg ) );
1786 = rts_apply ( error, thunk );
1788 (StgClosure*) thunk;
1791 #define raiseIndex(where) makeErrorCall("Array index out of range in " where)
1792 #define raiseDiv0(where) makeErrorCall("Division by zero in " where)
1794 /* --------------------------------------------------------------------------
1796 * ------------------------------------------------------------------------*/
1798 #define OP_CC_B(e) \
1800 unsigned char x = PopTaggedChar(); \
1801 unsigned char y = PopTaggedChar(); \
1802 PushTaggedBool(e); \
1807 unsigned char x = PopTaggedChar(); \
1816 #define OP_IW_I(e) \
1818 StgInt x = PopTaggedInt(); \
1819 StgWord y = PopTaggedWord(); \
1823 #define OP_II_I(e) \
1825 StgInt x = PopTaggedInt(); \
1826 StgInt y = PopTaggedInt(); \
1830 #define OP_II_B(e) \
1832 StgInt x = PopTaggedInt(); \
1833 StgInt y = PopTaggedInt(); \
1834 PushTaggedBool(e); \
1839 PushTaggedAddr(e); \
1844 StgInt x = PopTaggedInt(); \
1845 PushTaggedAddr(e); \
1850 StgInt x = PopTaggedInt(); \
1856 PushTaggedChar(e); \
1861 StgInt x = PopTaggedInt(); \
1862 PushTaggedChar(e); \
1867 PushTaggedWord(e); \
1872 StgInt x = PopTaggedInt(); \
1873 PushTaggedWord(e); \
1878 StgInt x = PopTaggedInt(); \
1879 PushTaggedStablePtr(e); \
1884 PushTaggedFloat(e); \
1889 StgInt x = PopTaggedInt(); \
1890 PushTaggedFloat(e); \
1895 PushTaggedDouble(e); \
1900 StgInt x = PopTaggedInt(); \
1901 PushTaggedDouble(e); \
1904 #define OP_WW_B(e) \
1906 StgWord x = PopTaggedWord(); \
1907 StgWord y = PopTaggedWord(); \
1908 PushTaggedBool(e); \
1911 #define OP_WW_W(e) \
1913 StgWord x = PopTaggedWord(); \
1914 StgWord y = PopTaggedWord(); \
1915 PushTaggedWord(e); \
1920 StgWord x = PopTaggedWord(); \
1926 StgStablePtr x = PopTaggedStablePtr(); \
1932 StgWord x = PopTaggedWord(); \
1933 PushTaggedWord(e); \
1936 #define OP_AA_B(e) \
1938 StgAddr x = PopTaggedAddr(); \
1939 StgAddr y = PopTaggedAddr(); \
1940 PushTaggedBool(e); \
1944 StgAddr x = PopTaggedAddr(); \
1947 #define OP_AI_C(s) \
1949 StgAddr x = PopTaggedAddr(); \
1950 int y = PopTaggedInt(); \
1953 PushTaggedChar(r); \
1955 #define OP_AI_I(s) \
1957 StgAddr x = PopTaggedAddr(); \
1958 int y = PopTaggedInt(); \
1963 #define OP_AI_A(s) \
1965 StgAddr x = PopTaggedAddr(); \
1966 int y = PopTaggedInt(); \
1969 PushTaggedAddr(s); \
1971 #define OP_AI_F(s) \
1973 StgAddr x = PopTaggedAddr(); \
1974 int y = PopTaggedInt(); \
1977 PushTaggedFloat(r); \
1979 #define OP_AI_D(s) \
1981 StgAddr x = PopTaggedAddr(); \
1982 int y = PopTaggedInt(); \
1985 PushTaggedDouble(r); \
1987 #define OP_AI_s(s) \
1989 StgAddr x = PopTaggedAddr(); \
1990 int y = PopTaggedInt(); \
1993 PushTaggedStablePtr(r); \
1995 #define OP_AIC_(s) \
1997 StgAddr x = PopTaggedAddr(); \
1998 int y = PopTaggedInt(); \
1999 StgChar z = PopTaggedChar(); \
2002 #define OP_AII_(s) \
2004 StgAddr x = PopTaggedAddr(); \
2005 int y = PopTaggedInt(); \
2006 StgInt z = PopTaggedInt(); \
2009 #define OP_AIA_(s) \
2011 StgAddr x = PopTaggedAddr(); \
2012 int y = PopTaggedInt(); \
2013 StgAddr z = PopTaggedAddr(); \
2016 #define OP_AIF_(s) \
2018 StgAddr x = PopTaggedAddr(); \
2019 int y = PopTaggedInt(); \
2020 StgFloat z = PopTaggedFloat(); \
2023 #define OP_AID_(s) \
2025 StgAddr x = PopTaggedAddr(); \
2026 int y = PopTaggedInt(); \
2027 StgDouble z = PopTaggedDouble(); \
2030 #define OP_AIs_(s) \
2032 StgAddr x = PopTaggedAddr(); \
2033 int y = PopTaggedInt(); \
2034 StgStablePtr z = PopTaggedStablePtr(); \
2039 #define OP_FF_B(e) \
2041 StgFloat x = PopTaggedFloat(); \
2042 StgFloat y = PopTaggedFloat(); \
2043 PushTaggedBool(e); \
2046 #define OP_FF_F(e) \
2048 StgFloat x = PopTaggedFloat(); \
2049 StgFloat y = PopTaggedFloat(); \
2050 PushTaggedFloat(e); \
2055 StgFloat x = PopTaggedFloat(); \
2056 PushTaggedFloat(e); \
2061 StgFloat x = PopTaggedFloat(); \
2062 PushTaggedBool(e); \
2067 StgFloat x = PopTaggedFloat(); \
2073 StgFloat x = PopTaggedFloat(); \
2074 PushTaggedDouble(e); \
2077 #define OP_DD_B(e) \
2079 StgDouble x = PopTaggedDouble(); \
2080 StgDouble y = PopTaggedDouble(); \
2081 PushTaggedBool(e); \
2084 #define OP_DD_D(e) \
2086 StgDouble x = PopTaggedDouble(); \
2087 StgDouble y = PopTaggedDouble(); \
2088 PushTaggedDouble(e); \
2093 StgDouble x = PopTaggedDouble(); \
2094 PushTaggedBool(e); \
2099 StgDouble x = PopTaggedDouble(); \
2100 PushTaggedDouble(e); \
2105 StgDouble x = PopTaggedDouble(); \
2111 StgDouble x = PopTaggedDouble(); \
2112 PushTaggedFloat(e); \
2116 #ifdef STANDALONE_INTEGER
2117 StgPtr CreateByteArrayToHoldInteger ( int nbytes )
2119 StgInt words = (nbytes+sizeof(W_)-1)/sizeof(W_);
2120 StgWord size = sizeofW(StgArrWords) + words;
2121 StgArrWords* arr = (StgArrWords*)allocate(size);
2122 SET_HDR(arr,&ARR_WORDS_info,CCCS);
2124 ASSERT(nbytes <= arr->words * sizeof(W_));
2127 for (i = 0; i < words; ++i) {
2128 arr->payload[i] = 0xdeadbeef;
2130 { B* b = (B*) &(arr->payload[0]);
2131 b->used = b->sign = 0;
2137 B* IntegerInsideByteArray ( StgPtr arr0 )
2140 StgArrWords* arr = (StgArrWords*)arr0;
2141 ASSERT(GET_INFO(arr) == &ARR_WORDS_info);
2142 b = (B*) &(arr->payload[0]);
2146 void SloppifyIntegerEnd ( StgPtr arr0 )
2148 StgArrWords* arr = (StgArrWords*)arr0;
2149 B* b = (B*) & (arr->payload[0]);
2150 I_ nwunused = arr->words - sizeofW(B) - (b->used+sizeof(W_)-1)/sizeof(W_);
2151 if (nwunused >= ((I_)sizeofW(StgArrWords))) {
2153 b->size -= nwunused * sizeof(W_);
2154 if (b->size < b->used) b->size = b->used;
2157 arr->words -= nwunused;
2158 slop = (StgArrWords*)&(arr->payload[arr->words]);
2159 SET_HDR(slop,&ARR_WORDS_info,CCCS);
2160 slop->words = nwunused - sizeofW(StgArrWords);
2161 ASSERT( &(slop->payload[slop->words]) ==
2162 &(arr->payload[arr->words + nwunused]) );
2166 #define OP_Z_Z(op) \
2168 B* x = IntegerInsideByteArray(PopPtr()); \
2169 int n = mycat2(size_,op)(x); \
2170 StgPtr p = CreateByteArrayToHoldInteger(n); \
2171 mycat2(do_,op)(x,n,IntegerInsideByteArray(p)); \
2172 SloppifyIntegerEnd(p); \
2175 #define OP_ZZ_Z(op) \
2177 B* x = IntegerInsideByteArray(PopPtr()); \
2178 B* y = IntegerInsideByteArray(PopPtr()); \
2179 int n = mycat2(size_,op)(x,y); \
2180 StgPtr p = CreateByteArrayToHoldInteger(n); \
2181 mycat2(do_,op)(x,y,n,IntegerInsideByteArray(p)); \
2182 SloppifyIntegerEnd(p); \
2190 #define HEADER_mI(ty,where) \
2191 StgArrWords* x = stgCast(StgArrWords*,PopPtr()); \
2192 nat i = PopTaggedInt(); \
2193 if (i * sizeof(ty) + (sizeof(ty)) > sizeof(StgWord) * x->words) { \
2194 return (raiseIndex(where)); \
2196 #define OP_mI_ty(ty,where,s) \
2198 HEADER_mI(mycat2(Stg,ty),where) \
2199 { mycat2(Stg,ty) r; \
2201 mycat2(PushTagged,ty)(r); \
2204 #define OP_mIty_(ty,where,s) \
2206 HEADER_mI(mycat2(Stg,ty),where) \
2208 mycat2(Stg,ty) z = mycat2(PopTagged,ty)(); \
2214 void myStackCheck ( Capability* cap )
2216 /* fprintf(stderr, "myStackCheck\n"); */
2217 if (!(gSpLim <= gSp && gSp <= stgCast(StgPtr,gSu))) {
2218 fprintf(stderr, "myStackCheck: invalid initial gSp/gSu \n" );
2222 if (!(gSu >= cap->rCurrentTSO->stack
2223 && gSu <= cap->rCurrentTSO->stack
2224 + cap->rCurrentTSO->stack_size)) {
2225 fprintf ( stderr, "myStackCheck: gSu out of stack\n" );
2228 switch (get_itbl(stgCast(StgClosure*,gSu))->type) {
2230 gSu = (StgPtr) ((StgCatchFrame*)(gSu))->link;
2233 gSu = (StgPtr) ((StgUpdateFrame*)(gSu))->link;
2236 gSu = (StgPtr) ((StgSeqFrame*)(gSu))->link;
2241 fprintf(stderr, "myStackCheck: invalid activation record\n"); assert(0);
2248 /* --------------------------------------------------------------------------
2249 * Primop stuff for bytecode interpreter
2250 * ------------------------------------------------------------------------*/
2252 /* Returns & of the next thing to enter (if throwing an exception),
2253 or NULL in the normal case.
2255 static void* enterBCO_primop1 ( int primop1code )
2257 switch (primop1code) {
2258 case i_pushseqframe:
2260 StgClosure* c = PopCPtr();
2265 case i_pushcatchframe:
2267 StgClosure* e = PopCPtr();
2268 StgClosure* h = PopCPtr();
2274 case i_gtChar: OP_CC_B(x>y); break;
2275 case i_geChar: OP_CC_B(x>=y); break;
2276 case i_eqChar: OP_CC_B(x==y); break;
2277 case i_neChar: OP_CC_B(x!=y); break;
2278 case i_ltChar: OP_CC_B(x<y); break;
2279 case i_leChar: OP_CC_B(x<=y); break;
2280 case i_charToInt: OP_C_I(x); break;
2281 case i_intToChar: OP_I_C(x); break;
2283 case i_gtInt: OP_II_B(x>y); break;
2284 case i_geInt: OP_II_B(x>=y); break;
2285 case i_eqInt: OP_II_B(x==y); break;
2286 case i_neInt: OP_II_B(x!=y); break;
2287 case i_ltInt: OP_II_B(x<y); break;
2288 case i_leInt: OP_II_B(x<=y); break;
2289 case i_minInt: OP__I(INT_MIN); break;
2290 case i_maxInt: OP__I(INT_MAX); break;
2291 case i_plusInt: OP_II_I(x+y); break;
2292 case i_minusInt: OP_II_I(x-y); break;
2293 case i_timesInt: OP_II_I(x*y); break;
2296 int x = PopTaggedInt();
2297 int y = PopTaggedInt();
2299 return (raiseDiv0("quotInt"));
2301 /* ToDo: protect against minInt / -1 errors
2302 * (repeat for all other division primops) */
2308 int x = PopTaggedInt();
2309 int y = PopTaggedInt();
2311 return (raiseDiv0("remInt"));
2318 StgInt x = PopTaggedInt();
2319 StgInt y = PopTaggedInt();
2321 return (raiseDiv0("quotRemInt"));
2323 PushTaggedInt(x%y); /* last result */
2324 PushTaggedInt(x/y); /* first result */
2327 case i_negateInt: OP_I_I(-x); break;
2329 case i_andInt: OP_II_I(x&y); break;
2330 case i_orInt: OP_II_I(x|y); break;
2331 case i_xorInt: OP_II_I(x^y); break;
2332 case i_notInt: OP_I_I(~x); break;
2333 case i_shiftLInt: OP_II_I(x<<y); break;
2334 case i_shiftRAInt: OP_II_I(x>>y); break; /* ToDo */
2335 case i_shiftRLInt: OP_II_I(x>>y); break; /* ToDo */
2337 case i_gtWord: OP_WW_B(x>y); break;
2338 case i_geWord: OP_WW_B(x>=y); break;
2339 case i_eqWord: OP_WW_B(x==y); break;
2340 case i_neWord: OP_WW_B(x!=y); break;
2341 case i_ltWord: OP_WW_B(x<y); break;
2342 case i_leWord: OP_WW_B(x<=y); break;
2343 case i_minWord: OP__W(0); break;
2344 case i_maxWord: OP__W(UINT_MAX); break;
2345 case i_plusWord: OP_WW_W(x+y); break;
2346 case i_minusWord: OP_WW_W(x-y); break;
2347 case i_timesWord: OP_WW_W(x*y); break;
2350 StgWord x = PopTaggedWord();
2351 StgWord y = PopTaggedWord();
2353 return (raiseDiv0("quotWord"));
2355 PushTaggedWord(x/y);
2360 StgWord x = PopTaggedWord();
2361 StgWord y = PopTaggedWord();
2363 return (raiseDiv0("remWord"));
2365 PushTaggedWord(x%y);
2370 StgWord x = PopTaggedWord();
2371 StgWord y = PopTaggedWord();
2373 return (raiseDiv0("quotRemWord"));
2375 PushTaggedWord(x%y); /* last result */
2376 PushTaggedWord(x/y); /* first result */
2379 case i_negateWord: OP_W_W(-x); break;
2380 case i_andWord: OP_WW_W(x&y); break;
2381 case i_orWord: OP_WW_W(x|y); break;
2382 case i_xorWord: OP_WW_W(x^y); break;
2383 case i_notWord: OP_W_W(~x); break;
2384 case i_shiftLWord: OP_WW_W(x<<y); break;
2385 case i_shiftRAWord: OP_WW_W(x>>y); break; /* ToDo */
2386 case i_shiftRLWord: OP_WW_W(x>>y); break; /* ToDo */
2387 case i_intToWord: OP_I_W(x); break;
2388 case i_wordToInt: OP_W_I(x); break;
2390 case i_gtAddr: OP_AA_B(x>y); break;
2391 case i_geAddr: OP_AA_B(x>=y); break;
2392 case i_eqAddr: OP_AA_B(x==y); break;
2393 case i_neAddr: OP_AA_B(x!=y); break;
2394 case i_ltAddr: OP_AA_B(x<y); break;
2395 case i_leAddr: OP_AA_B(x<=y); break;
2396 case i_intToAddr: OP_I_A((StgAddr)x); break; /* ToDo */
2397 case i_addrToInt: OP_A_I((StgInt)x); break; /* ToDo */
2399 case i_intToStable: OP_I_s(x); break;
2400 case i_stableToInt: OP_s_I(x); break;
2402 case i_indexCharOffAddr: OP_AI_C(indexCharOffAddrzh(r,x,y)); break;
2403 case i_readCharOffAddr: OP_AI_C(indexCharOffAddrzh(r,x,y)); break;
2404 case i_writeCharOffAddr: OP_AIC_(writeCharOffAddrzh(x,y,z)); break;
2406 case i_indexIntOffAddr: OP_AI_I(indexIntOffAddrzh(r,x,y)); break;
2407 case i_readIntOffAddr: OP_AI_I(indexIntOffAddrzh(r,x,y)); break;
2408 case i_writeIntOffAddr: OP_AII_(writeIntOffAddrzh(x,y,z)); break;
2410 case i_indexAddrOffAddr: OP_AI_A(indexAddrOffAddrzh(r,x,y)); break;
2411 case i_readAddrOffAddr: OP_AI_A(indexAddrOffAddrzh(r,x,y)); break;
2412 case i_writeAddrOffAddr: OP_AIA_(writeAddrOffAddrzh(x,y,z)); break;
2414 case i_indexFloatOffAddr: OP_AI_F(indexFloatOffAddrzh(r,x,y)); break;
2415 case i_readFloatOffAddr: OP_AI_F(indexFloatOffAddrzh(r,x,y)); break;
2416 case i_writeFloatOffAddr: OP_AIF_(writeFloatOffAddrzh(x,y,z)); break;
2418 case i_indexDoubleOffAddr: OP_AI_D(indexDoubleOffAddrzh(r,x,y)); break;
2419 case i_readDoubleOffAddr: OP_AI_D(indexDoubleOffAddrzh(r,x,y)); break;
2420 case i_writeDoubleOffAddr: OP_AID_(writeDoubleOffAddrzh(x,y,z)); break;
2422 case i_indexStableOffAddr: OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break;
2423 case i_readStableOffAddr: OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break;
2424 case i_writeStableOffAddr: OP_AIs_(writeStablePtrOffAddrzh(x,y,z)); break;
2426 #ifdef STANDALONE_INTEGER
2427 case i_compareInteger:
2429 B* x = IntegerInsideByteArray(PopPtr());
2430 B* y = IntegerInsideByteArray(PopPtr());
2431 StgInt r = do_cmp(x,y);
2432 PushTaggedInt(r<0 ? -1 : (r>0 ? 1 : 0));
2435 case i_negateInteger: OP_Z_Z(neg); break;
2436 case i_plusInteger: OP_ZZ_Z(add); break;
2437 case i_minusInteger: OP_ZZ_Z(sub); break;
2438 case i_timesInteger: OP_ZZ_Z(mul); break;
2439 case i_quotRemInteger:
2441 B* x = IntegerInsideByteArray(PopPtr());
2442 B* y = IntegerInsideByteArray(PopPtr());
2443 int n = size_qrm(x,y);
2444 StgPtr q = CreateByteArrayToHoldInteger(n);
2445 StgPtr r = CreateByteArrayToHoldInteger(n);
2446 if (do_getsign(y)==0)
2447 return (raiseDiv0("quotRemInteger"));
2448 do_qrm(x,y,n,IntegerInsideByteArray(q),
2449 IntegerInsideByteArray(r));
2450 SloppifyIntegerEnd(q);
2451 SloppifyIntegerEnd(r);
2456 case i_intToInteger:
2458 int n = size_fromInt();
2459 StgPtr p = CreateByteArrayToHoldInteger(n);
2460 do_fromInt( PopTaggedInt(), n, IntegerInsideByteArray(p));
2464 case i_wordToInteger:
2466 int n = size_fromWord();
2467 StgPtr p = CreateByteArrayToHoldInteger(n);
2468 do_fromWord( PopTaggedWord(), n, IntegerInsideByteArray(p));
2472 case i_integerToInt: PushTaggedInt(do_toInt(
2473 IntegerInsideByteArray(PopPtr())
2477 case i_integerToWord: PushTaggedWord(do_toWord(
2478 IntegerInsideByteArray(PopPtr())
2482 case i_integerToFloat: PushTaggedFloat(do_toFloat(
2483 IntegerInsideByteArray(PopPtr())
2487 case i_integerToDouble: PushTaggedDouble(do_toDouble(
2488 IntegerInsideByteArray(PopPtr())
2492 #error Non-standalone integer not yet implemented
2493 #endif /* STANDALONE_INTEGER */
2495 case i_gtFloat: OP_FF_B(x>y); break;
2496 case i_geFloat: OP_FF_B(x>=y); break;
2497 case i_eqFloat: OP_FF_B(x==y); break;
2498 case i_neFloat: OP_FF_B(x!=y); break;
2499 case i_ltFloat: OP_FF_B(x<y); break;
2500 case i_leFloat: OP_FF_B(x<=y); break;
2501 case i_minFloat: OP__F(FLT_MIN); break;
2502 case i_maxFloat: OP__F(FLT_MAX); break;
2503 case i_radixFloat: OP__I(FLT_RADIX); break;
2504 case i_digitsFloat: OP__I(FLT_MANT_DIG); break;
2505 case i_minExpFloat: OP__I(FLT_MIN_EXP); break;
2506 case i_maxExpFloat: OP__I(FLT_MAX_EXP); break;
2507 case i_plusFloat: OP_FF_F(x+y); break;
2508 case i_minusFloat: OP_FF_F(x-y); break;
2509 case i_timesFloat: OP_FF_F(x*y); break;
2512 StgFloat x = PopTaggedFloat();
2513 StgFloat y = PopTaggedFloat();
2514 PushTaggedFloat(x/y);
2517 case i_negateFloat: OP_F_F(-x); break;
2518 case i_floatToInt: OP_F_I(x); break;
2519 case i_intToFloat: OP_I_F(x); break;
2520 case i_expFloat: OP_F_F(exp(x)); break;
2521 case i_logFloat: OP_F_F(log(x)); break;
2522 case i_sqrtFloat: OP_F_F(sqrt(x)); break;
2523 case i_sinFloat: OP_F_F(sin(x)); break;
2524 case i_cosFloat: OP_F_F(cos(x)); break;
2525 case i_tanFloat: OP_F_F(tan(x)); break;
2526 case i_asinFloat: OP_F_F(asin(x)); break;
2527 case i_acosFloat: OP_F_F(acos(x)); break;
2528 case i_atanFloat: OP_F_F(atan(x)); break;
2529 case i_sinhFloat: OP_F_F(sinh(x)); break;
2530 case i_coshFloat: OP_F_F(cosh(x)); break;
2531 case i_tanhFloat: OP_F_F(tanh(x)); break;
2532 case i_powerFloat: OP_FF_F(pow(x,y)); break;
2534 #ifdef STANDALONE_INTEGER
2535 case i_encodeFloatZ:
2537 StgPtr sig = PopPtr();
2538 StgInt exp = PopTaggedInt();
2540 B__encodeFloat(IntegerInsideByteArray(sig), exp)
2544 case i_decodeFloatZ:
2546 StgFloat f = PopTaggedFloat();
2547 StgPtr sig = CreateByteArrayToHoldInteger(size_fltmantissa());
2549 B__decodeFloat(IntegerInsideByteArray(sig), &exp, f);
2555 #error encode/decodeFloatZ not yet implemented for GHC ints
2557 case i_isNaNFloat: OP_F_B(isFloatNaN(x)); break;
2558 case i_isInfiniteFloat: OP_F_B(isFloatInfinite(x)); break;
2559 case i_isNegativeZeroFloat: OP_F_B(isFloatNegativeZero(x)); break;
2560 case i_isDenormalizedFloat: OP_F_B(isFloatDenormalized(x)); break;
2561 case i_gtDouble: OP_DD_B(x>y); break;
2562 case i_geDouble: OP_DD_B(x>=y); break;
2563 case i_eqDouble: OP_DD_B(x==y); break;
2564 case i_neDouble: OP_DD_B(x!=y); break;
2565 case i_ltDouble: OP_DD_B(x<y); break;
2566 case i_leDouble: OP_DD_B(x<=y) break;
2567 case i_minDouble: OP__D(DBL_MIN); break;
2568 case i_maxDouble: OP__D(DBL_MAX); break;
2569 case i_radixDouble: OP__I(FLT_RADIX); break;
2570 case i_digitsDouble: OP__I(DBL_MANT_DIG); break;
2571 case i_minExpDouble: OP__I(DBL_MIN_EXP); break;
2572 case i_maxExpDouble: OP__I(DBL_MAX_EXP); break;
2573 case i_plusDouble: OP_DD_D(x+y); break;
2574 case i_minusDouble: OP_DD_D(x-y); break;
2575 case i_timesDouble: OP_DD_D(x*y); break;
2576 case i_divideDouble:
2578 StgDouble x = PopTaggedDouble();
2579 StgDouble y = PopTaggedDouble();
2580 PushTaggedDouble(x/y);
2583 case i_negateDouble: OP_D_D(-x); break;
2584 case i_doubleToInt: OP_D_I(x); break;
2585 case i_intToDouble: OP_I_D(x); break;
2586 case i_doubleToFloat: OP_D_F(x); break;
2587 case i_floatToDouble: OP_F_F(x); break;
2588 case i_expDouble: OP_D_D(exp(x)); break;
2589 case i_logDouble: OP_D_D(log(x)); break;
2590 case i_sqrtDouble: OP_D_D(sqrt(x)); break;
2591 case i_sinDouble: OP_D_D(sin(x)); break;
2592 case i_cosDouble: OP_D_D(cos(x)); break;
2593 case i_tanDouble: OP_D_D(tan(x)); break;
2594 case i_asinDouble: OP_D_D(asin(x)); break;
2595 case i_acosDouble: OP_D_D(acos(x)); break;
2596 case i_atanDouble: OP_D_D(atan(x)); break;
2597 case i_sinhDouble: OP_D_D(sinh(x)); break;
2598 case i_coshDouble: OP_D_D(cosh(x)); break;
2599 case i_tanhDouble: OP_D_D(tanh(x)); break;
2600 case i_powerDouble: OP_DD_D(pow(x,y)); break;
2602 #ifdef STANDALONE_INTEGER
2603 case i_encodeDoubleZ:
2605 StgPtr sig = PopPtr();
2606 StgInt exp = PopTaggedInt();
2608 B__encodeDouble(IntegerInsideByteArray(sig), exp)
2612 case i_decodeDoubleZ:
2614 StgDouble d = PopTaggedDouble();
2615 StgPtr sig = CreateByteArrayToHoldInteger(size_dblmantissa());
2617 B__decodeDouble(IntegerInsideByteArray(sig), &exp, d);
2623 #error encode/decodeDoubleZ not yet implemented for GHC ints
2625 case i_isNaNDouble: OP_D_B(isDoubleNaN(x)); break;
2626 case i_isInfiniteDouble: OP_D_B(isDoubleInfinite(x)); break;
2627 case i_isNegativeZeroDouble: OP_D_B(isDoubleNegativeZero(x)); break;
2628 case i_isDenormalizedDouble: OP_D_B(isDoubleDenormalized(x)); break;
2629 case i_isIEEEDouble:
2631 PushTaggedBool(rtsTrue);
2635 barf("Unrecognised primop1");
2642 /* For normal cases, return NULL and leave *return2 unchanged.
2643 To return the address of the next thing to enter,
2644 return the address of it and leave *return2 unchanged.
2645 To return a StgThreadReturnCode to the scheduler,
2646 set *return2 to it and return a non-NULL value.
2648 static void* enterBCO_primop2 ( int primop2code,
2649 int* /*StgThreadReturnCode* */ return2,
2653 switch (primop2code) {
2654 case i_raise: /* raise#{err} */
2656 StgClosure* err = PopCPtr();
2657 return (raiseAnError(err));
2662 StgClosure* init = PopCPtr();
2664 = stgCast(StgMutVar*,allocate(sizeofW(StgMutVar)));
2665 SET_HDR(mv,&MUT_VAR_info,CCCS);
2667 PushPtr(stgCast(StgPtr,mv));
2672 StgMutVar* mv = stgCast(StgMutVar*,PopPtr());
2678 StgMutVar* mv = stgCast(StgMutVar*,PopPtr());
2679 StgClosure* value = PopCPtr();
2685 nat n = PopTaggedInt(); /* or Word?? */
2686 StgClosure* init = PopCPtr();
2687 StgWord size = sizeofW(StgMutArrPtrs) + n;
2690 = stgCast(StgMutArrPtrs*,allocate(size));
2691 SET_HDR(arr,&MUT_ARR_PTRS_info,CCCS);
2693 for (i = 0; i < n; ++i) {
2694 arr->payload[i] = init;
2696 PushPtr(stgCast(StgPtr,arr));
2702 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2703 nat i = PopTaggedInt(); /* or Word?? */
2704 StgWord n = arr->ptrs;
2706 return (raiseIndex("{index,read}Array"));
2708 PushCPtr(arr->payload[i]);
2713 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2714 nat i = PopTaggedInt(); /* or Word? */
2715 StgClosure* v = PopCPtr();
2716 StgWord n = arr->ptrs;
2718 return (raiseIndex("{index,read}Array"));
2720 arr->payload[i] = v;
2724 case i_sizeMutableArray:
2726 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2727 PushTaggedInt(arr->ptrs);
2730 case i_unsafeFreezeArray:
2732 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2733 SET_INFO(arr,&MUT_ARR_PTRS_FROZEN_info);
2734 PushPtr(stgCast(StgPtr,arr));
2737 case i_unsafeFreezeByteArray:
2739 /* Delightfully simple :-) */
2743 case i_sameMutableArray:
2744 case i_sameMutableByteArray:
2746 StgPtr x = PopPtr();
2747 StgPtr y = PopPtr();
2748 PushTaggedBool(x==y);
2752 case i_newByteArray:
2754 nat n = PopTaggedInt(); /* or Word?? */
2755 StgInt words = (n+sizeof(W_)-1)/sizeof(W_);
2756 StgWord size = sizeofW(StgArrWords) + words;
2757 StgArrWords* arr = stgCast(StgArrWords*,allocate(size));
2758 SET_HDR(arr,&ARR_WORDS_info,CCCS);
2762 for (i = 0; i < n; ++i) {
2763 arr->payload[i] = 0xdeadbeef;
2766 PushPtr(stgCast(StgPtr,arr));
2770 /* Most of these generate alignment warnings on Sparcs and similar architectures.
2771 * These are harmless and are caused by the cast to C* in BYTE_ARR_CTS.
2773 case i_indexCharArray:
2774 OP_mI_ty(Char,"indexCharArray", indexCharArrayzh(r,x,i)); break;
2775 case i_readCharArray:
2776 OP_mI_ty(Char,"readCharArray", readCharArrayzh(r,x,i)); break;
2777 case i_writeCharArray:
2778 OP_mIty_(Char,"writeCharArray", writeCharArrayzh(x,i,z)); break;
2780 case i_indexIntArray:
2781 OP_mI_ty(Int,"indexIntArray", indexIntArrayzh(r,x,i)); break;
2782 case i_readIntArray:
2783 OP_mI_ty(Int,"readIntArray", readIntArrayzh(r,x,i)); break;
2784 case i_writeIntArray:
2785 OP_mIty_(Int,"writeIntArray", writeIntArrayzh(x,i,z)); break;
2787 case i_indexAddrArray:
2788 OP_mI_ty(Addr,"indexAddrArray", indexAddrArrayzh(r,x,i)); break;
2789 case i_readAddrArray:
2790 OP_mI_ty(Addr,"readAddrArray", readAddrArrayzh(r,x,i)); break;
2791 case i_writeAddrArray:
2792 OP_mIty_(Addr,"writeAddrArray", writeAddrArrayzh(x,i,z)); break;
2794 case i_indexFloatArray:
2795 OP_mI_ty(Float,"indexFloatArray", indexFloatArrayzh(r,x,i)); break;
2796 case i_readFloatArray:
2797 OP_mI_ty(Float,"readFloatArray", readFloatArrayzh(r,x,i)); break;
2798 case i_writeFloatArray:
2799 OP_mIty_(Float,"writeFloatArray", writeFloatArrayzh(x,i,z)); break;
2801 case i_indexDoubleArray:
2802 OP_mI_ty(Double,"indexDoubleArray", indexDoubleArrayzh(r,x,i)); break;
2803 case i_readDoubleArray:
2804 OP_mI_ty(Double,"readDoubleArray", readDoubleArrayzh(r,x,i)); break;
2805 case i_writeDoubleArray:
2806 OP_mIty_(Double,"writeDoubleArray", writeDoubleArrayzh(x,i,z)); break;
2809 #ifdef PROVIDE_STABLE
2810 case i_indexStableArray:
2811 OP_mI_ty(StablePtr,"indexStableArray", indexStablePtrArrayzh(r,x,i)); break;
2812 case i_readStableArray:
2813 OP_mI_ty(StablePtr,"readStableArray", readStablePtrArrayzh(r,x,i)); break;
2814 case i_writeStableArray:
2815 OP_mIty_(StablePtr,"writeStableArray", writeStablePtrArrayzh(x,i,z)); break;
2821 #ifdef PROVIDE_COERCE
2822 case i_unsafeCoerce:
2824 /* Another nullop */
2828 #ifdef PROVIDE_PTREQUALITY
2829 case i_reallyUnsafePtrEquality:
2830 { /* identical to i_sameRef */
2831 StgPtr x = PopPtr();
2832 StgPtr y = PopPtr();
2833 PushTaggedBool(x==y);
2837 #ifdef PROVIDE_FOREIGN
2838 /* ForeignObj# operations */
2839 case i_makeForeignObj:
2841 StgForeignObj *result
2842 = stgCast(StgForeignObj*,allocate(sizeofW(StgForeignObj)));
2843 SET_HDR(result,&FOREIGN_info,CCCS);
2844 result -> data = PopTaggedAddr();
2845 PushPtr(stgCast(StgPtr,result));
2848 #endif /* PROVIDE_FOREIGN */
2853 = stgCast(StgWeak*,allocate(sizeofW(StgWeak)));
2854 SET_HDR(w, &WEAK_info, CCCS);
2856 w->value = PopCPtr();
2857 w->finaliser = PopCPtr();
2858 w->link = weak_ptr_list;
2860 IF_DEBUG(weak, fprintf(stderr,"New weak pointer at %p\n",w));
2861 PushPtr(stgCast(StgPtr,w));
2866 StgWeak *w = stgCast(StgWeak*,PopPtr());
2867 if (w->header.info == &WEAK_info) {
2868 PushCPtr(w->value); /* last result */
2869 PushTaggedInt(1); /* first result */
2871 PushPtr(stgCast(StgPtr,w));
2872 /* ToDo: error thunk would be better */
2877 #endif /* PROVIDE_WEAK */
2879 case i_makeStablePtr:
2881 StgPtr p = PopPtr();
2882 StgStablePtr sp = getStablePtr ( p );
2883 PushTaggedStablePtr(sp);
2886 case i_deRefStablePtr:
2889 StgStablePtr sp = PopTaggedStablePtr();
2890 p = deRefStablePtr(sp);
2894 case i_freeStablePtr:
2896 StgStablePtr sp = PopTaggedStablePtr();
2901 case i_createAdjThunkARCH:
2903 StgStablePtr stableptr = PopTaggedStablePtr();
2904 StgAddr typestr = PopTaggedAddr();
2905 StgChar callconv = PopTaggedChar();
2906 StgAddr adj_thunk = createAdjThunk(stableptr,typestr,callconv);
2907 PushTaggedAddr(adj_thunk);
2913 StgInt n = prog_argc;
2919 StgInt n = PopTaggedInt();
2920 StgAddr a = (StgAddr)prog_argv[n];
2927 StgMVar *mvar = stgCast(StgMVar*,allocate(sizeofW(StgMVar)));
2928 SET_INFO(mvar,&EMPTY_MVAR_info);
2929 mvar->head = mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
2930 mvar->value = stgCast(StgClosure*,&END_TSO_QUEUE_closure);
2931 PushPtr(stgCast(StgPtr,mvar));
2936 StgMVar *mvar = (StgMVar*)PopCPtr();
2937 if (GET_INFO(mvar) == &EMPTY_MVAR_info) {
2939 /* The MVar is empty. Attach ourselves to the TSO's
2942 if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
2943 mvar->head = cap->rCurrentTSO;
2945 mvar->tail->link = cap->rCurrentTSO;
2947 cap->rCurrentTSO->link = (StgTSO *)&END_TSO_QUEUE_closure;
2948 cap->rCurrentTSO->why_blocked = BlockedOnMVar;
2949 cap->rCurrentTSO->block_info.closure = (StgClosure *)mvar;
2950 mvar->tail = cap->rCurrentTSO;
2952 /* At this point, the top-of-stack holds the MVar,
2953 and underneath is the world token (). So the
2954 stack is in the same state as when primTakeMVar
2955 was entered (primTakeMVar is handwritten bytecode).
2956 Push obj, which is this BCO, and return to the
2957 scheduler. When the MVar is filled, the scheduler
2958 will re-enter primTakeMVar, with the args still on
2959 the top of the stack.
2961 PushCPtr((StgClosure*)(*bco));
2962 *return2 = ThreadBlocked;
2963 return (void*)(1+(NULL));
2966 PushCPtr(mvar->value);
2967 mvar->value = (StgClosure *)&END_TSO_QUEUE_closure;
2968 SET_INFO(mvar,&EMPTY_MVAR_info);
2974 StgMVar* mvar = stgCast(StgMVar*,PopPtr());
2975 StgClosure* value = PopCPtr();
2976 if (GET_INFO(mvar) == &FULL_MVAR_info) {
2977 return (makeErrorCall("putMVar {full MVar}"));
2979 /* wake up the first thread on the
2980 * queue, it will continue with the
2981 * takeMVar operation and mark the
2984 mvar->value = value;
2986 if (mvar->head != (StgTSO *)&END_TSO_QUEUE_closure) {
2987 ASSERT(mvar->head->why_blocked == BlockedOnMVar);
2988 mvar->head = unblockOne(mvar->head);
2989 if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
2990 mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
2994 /* unlocks the MVar in the SMP case */
2995 SET_INFO(mvar,&FULL_MVAR_info);
2997 /* yield for better communication performance */
3003 { /* identical to i_sameRef */
3004 StgMVar* x = (StgMVar*)PopPtr();
3005 StgMVar* y = (StgMVar*)PopPtr();
3006 PushTaggedBool(x==y);
3011 StgWord tid = cap->rCurrentTSO->id;
3012 PushTaggedWord(tid);
3015 case i_cmpThreadIds:
3017 StgWord tid1 = PopTaggedWord();
3018 StgWord tid2 = PopTaggedWord();
3019 if (tid1 < tid2) PushTaggedInt(-1);
3020 else if (tid1 > tid2) PushTaggedInt(1);
3021 else PushTaggedInt(0);
3026 StgClosure* closure;
3029 closure = PopCPtr();
3030 tso = createGenThread (RtsFlags.GcFlags.initialStkSize,closure);
3032 scheduleThread(tso);
3034 PushTaggedWord(tid);
3038 #ifdef PROVIDE_CONCURRENT
3041 StgTSO* tso = stgCast(StgTSO*,PopPtr());
3043 if (tso == cap->rCurrentTSO) { /* suicide */
3044 *return2 = ThreadFinished;
3045 return (void*)(1+(NULL));
3052 ToDo: another way out of the problem might be to add an explicit
3053 continuation to primTakeMVar: takeMVar v = primTakeMVar v takeMVar.
3054 The problem with this plan is that now I dont know how much to chop
3061 /* As PrimOps.h says: Hmm, I'll think about these later. */
3064 #endif /* PROVIDE_CONCURRENT */
3066 case i_ccall_ccall_Id:
3067 case i_ccall_ccall_IO:
3068 case i_ccall_stdcall_Id:
3069 case i_ccall_stdcall_IO:
3072 CFunDescriptor* descriptor;
3073 void (*funPtr)(void);
3075 descriptor = PopTaggedAddr();
3076 funPtr = PopTaggedAddr();
3077 cc = (primop2code == i_ccall_stdcall_Id ||
3078 primop2code == i_ccall_stdcall_IO)
3080 r = ccall(descriptor,funPtr,bco,cc,cap);
3083 return makeErrorCall(
3084 "unhandled type or too many args/results in ccall");
3086 barf("ccall not configured correctly for this platform");
3087 barf("unknown return code from ccall");
3090 barf("Unrecognised primop2");
3096 /* -----------------------------------------------------------------------------
3097 * ccall support code:
3098 * marshall moves args from C stack to Haskell stack
3099 * unmarshall moves args from Haskell stack to C stack
3100 * argSize calculates how much gSpace you need on the C stack
3101 * ---------------------------------------------------------------------------*/
3103 /* Pop arguments off the C stack and Push them onto the Hugs stack.
3104 * Used when preparing for C calling Haskell or in regSponse to
3105 * Haskell calling C.
3107 nat marshall(char arg_ty, void* arg)
3111 PushTaggedInt(*((int*)arg));
3112 return ARG_SIZE(INT_TAG);
3113 #ifdef TODO_STANDALONE_INTEGER
3115 PushTaggedInteger(*((mpz_ptr*)arg));
3116 return ARG_SIZE(INTEGER_TAG);
3119 PushTaggedWord(*((unsigned int*)arg));
3120 return ARG_SIZE(WORD_TAG);
3122 PushTaggedChar(*((char*)arg));
3123 return ARG_SIZE(CHAR_TAG);
3125 PushTaggedFloat(*((float*)arg));
3126 return ARG_SIZE(FLOAT_TAG);
3128 PushTaggedDouble(*((double*)arg));
3129 return ARG_SIZE(DOUBLE_TAG);
3131 PushTaggedAddr(*((void**)arg));
3132 return ARG_SIZE(ADDR_TAG);
3134 PushTaggedStablePtr(*((StgStablePtr*)arg));
3135 return ARG_SIZE(STABLE_TAG);
3136 #ifdef PROVIDE_FOREIGN
3138 /* Not allowed in this direction - you have to
3139 * call makeForeignPtr explicitly
3141 barf("marshall: ForeignPtr#\n");
3146 /* Not allowed in this direction */
3147 barf("marshall: [Mutable]ByteArray#\n");
3150 barf("marshall: unrecognised arg type %d\n",arg_ty);
3155 /* Pop arguments off the Hugs stack and Push them onto the C stack.
3156 * Used when preparing for Haskell calling C or in regSponse to
3157 * C calling Haskell.
3159 nat unmarshall(char res_ty, void* res)
3163 *((int*)res) = PopTaggedInt();
3164 return ARG_SIZE(INT_TAG);
3165 #ifdef TODO_STANDALONE_INTEGER
3167 *((mpz_ptr*)res) = PopTaggedInteger();
3168 return ARG_SIZE(INTEGER_TAG);
3171 *((unsigned int*)res) = PopTaggedWord();
3172 return ARG_SIZE(WORD_TAG);
3174 *((int*)res) = PopTaggedChar();
3175 return ARG_SIZE(CHAR_TAG);
3177 *((float*)res) = PopTaggedFloat();
3178 return ARG_SIZE(FLOAT_TAG);
3180 *((double*)res) = PopTaggedDouble();
3181 return ARG_SIZE(DOUBLE_TAG);
3183 *((void**)res) = PopTaggedAddr();
3184 return ARG_SIZE(ADDR_TAG);
3186 *((StgStablePtr*)res) = PopTaggedStablePtr();
3187 return ARG_SIZE(STABLE_TAG);
3188 #ifdef PROVIDE_FOREIGN
3191 StgForeignObj *result = stgCast(StgForeignObj*,PopPtr());
3192 *((void**)res) = result->data;
3193 return sizeofW(StgPtr);
3199 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
3200 *((void**)res) = stgCast(void*,&(arr->payload));
3201 return sizeofW(StgPtr);
3204 barf("unmarshall: unrecognised result type %d\n",res_ty);
3208 nat argSize( const char* ks )
3211 for( ; *ks != '\0'; ++ks) {
3214 sz += sizeof(StgWord) * ARG_SIZE(INT_TAG);
3216 #ifdef TODO_STANDALONE_INTEGER
3218 sz += sizeof(StgWord) * ARG_SIZE(INTEGER_TAG);
3222 sz += sizeof(StgWord) * ARG_SIZE(WORD_TAG);
3225 sz += sizeof(StgWord) * ARG_SIZE(CHAR_TAG);
3228 sz += sizeof(StgWord) * ARG_SIZE(FLOAT_TAG);
3231 sz += sizeof(StgWord) * ARG_SIZE(DOUBLE_TAG);
3234 sz += sizeof(StgWord) * ARG_SIZE(ADDR_TAG);
3237 sz += sizeof(StgWord) * ARG_SIZE(STABLE_TAG);
3239 #ifdef PROVIDE_FOREIGN
3244 sz += sizeof(StgPtr);
3247 barf("argSize: unrecognised result type %d\n",*ks);
3255 /* -----------------------------------------------------------------------------
3256 * encode/decode Float/Double code for standalone Hugs
3257 * Code based on the HBC code (lib/fltcode.c) and more recently GHC
3258 * (ghc/rts/StgPrimFloat.c)
3259 * ---------------------------------------------------------------------------*/
3261 #ifdef STANDALONE_INTEGER
3263 #if IEEE_FLOATING_POINT
3264 #define MY_DMINEXP ((DBL_MIN_EXP) - (DBL_MANT_DIG) - 1)
3265 /* DMINEXP is defined in values.h on Linux (for example) */
3266 #define DHIGHBIT 0x00100000
3267 #define DMSBIT 0x80000000
3269 #define MY_FMINEXP ((FLT_MIN_EXP) - (FLT_MANT_DIG) - 1)
3270 #define FHIGHBIT 0x00800000
3271 #define FMSBIT 0x80000000
3273 #error The following code doesnt work in a non-IEEE FP environment
3276 #ifdef WORDS_BIGENDIAN
3285 StgDouble B__encodeDouble (B* s, I_ e) /* result = s * 2^e */
3290 /* Convert a B to a double; knows a lot about internal rep! */
3291 for(r = 0.0, i = s->used-1; i >= 0; i--)
3292 r = (r * B_BASE_FLT) + s->stuff[i];
3294 /* Now raise to the exponent */
3295 if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
3298 /* handle the sign */
3299 if (s->sign < 0) r = -r;
3306 #if ! FLOATS_AS_DOUBLES
3307 StgFloat B__encodeFloat (B* s, I_ e) /* result = s * 2^e */
3312 /* Convert a B to a float; knows a lot about internal rep! */
3313 for(r = 0.0, i = s->used-1; i >= 0; i--)
3314 r = (r * B_BASE_FLT) + s->stuff[i];
3316 /* Now raise to the exponent */
3317 if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
3320 /* handle the sign */
3321 if (s->sign < 0) r = -r;
3325 #endif /* FLOATS_AS_DOUBLES */
3329 /* This only supports IEEE floating point */
3330 void B__decodeDouble (B* man, I_* exp, StgDouble dbl)
3332 /* Do some bit fiddling on IEEE */
3333 nat low, high; /* assuming 32 bit ints */
3335 union { double d; int i[2]; } u; /* assuming 32 bit ints, 64 bit double */
3337 u.d = dbl; /* grab chunks of the double */
3341 ASSERT(B_BASE == 256);
3343 /* Assume that the supplied B is the right size */
3346 if (low == 0 && (high & ~DMSBIT) == 0) {
3347 man->sign = man->used = 0;
3352 iexp = ((high >> 20) & 0x7ff) + MY_DMINEXP;
3356 if (iexp != MY_DMINEXP) /* don't add hidden bit to denorms */
3360 /* A denorm, normalize the mantissa */
3361 while (! (high & DHIGHBIT)) {
3371 man->stuff[7] = (((W_)high) >> 24) & 0xff;
3372 man->stuff[6] = (((W_)high) >> 16) & 0xff;
3373 man->stuff[5] = (((W_)high) >> 8) & 0xff;
3374 man->stuff[4] = (((W_)high) ) & 0xff;
3376 man->stuff[3] = (((W_)low) >> 24) & 0xff;
3377 man->stuff[2] = (((W_)low) >> 16) & 0xff;
3378 man->stuff[1] = (((W_)low) >> 8) & 0xff;
3379 man->stuff[0] = (((W_)low) ) & 0xff;
3381 if (sign < 0) man->sign = -1;
3383 do_renormalise(man);
3387 #if ! FLOATS_AS_DOUBLES
3388 void B__decodeFloat (B* man, I_* exp, StgFloat flt)
3390 /* Do some bit fiddling on IEEE */
3391 int high, sign; /* assuming 32 bit ints */
3392 union { float f; int i; } u; /* assuming 32 bit float and int */
3394 u.f = flt; /* grab the float */
3397 ASSERT(B_BASE == 256);
3399 /* Assume that the supplied B is the right size */
3402 if ((high & ~FMSBIT) == 0) {
3403 man->sign = man->used = 0;
3408 *exp = ((high >> 23) & 0xff) + MY_FMINEXP;
3412 if (*exp != MY_FMINEXP) /* don't add hidden bit to denorms */
3416 /* A denorm, normalize the mantissa */
3417 while (! (high & FHIGHBIT)) {
3422 man->stuff[3] = (((W_)high) >> 24) & 0xff;
3423 man->stuff[2] = (((W_)high) >> 16) & 0xff;
3424 man->stuff[1] = (((W_)high) >> 8) & 0xff;
3425 man->stuff[0] = (((W_)high) ) & 0xff;
3427 if (sign < 0) man->sign = -1;
3429 do_renormalise(man);
3432 #endif /* FLOATS_AS_DOUBLES */
3434 #endif /* STANDALONE_INTEGER */
3436 #endif /* INTERPRETER */