2 /* -----------------------------------------------------------------------------
5 * Copyright (c) 1994-1998.
7 * $RCSfile: Evaluator.c,v $
9 * $Date: 1999/11/18 12:10:26 $
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,??);
703 int x = BCO_INSTR_8; /* ToDo: Word not Int! */
705 StgAP_UPD* o = stgCast(StgAP_UPD*,xStackPtr(x));
706 SET_HDR(o,&AP_UPD_info,??);
708 o->fun = stgCast(StgClosure*,xPopPtr());
709 for(x=0; x < y; ++x) {
710 payloadWord(o,x) = xPopWord();
713 fprintf(stderr,"\tBuilt ");
715 printObj(stgCast(StgClosure*,o));
726 o = stgCast(StgAP_UPD*,xStackPtr(x));
727 SET_HDR(o,&AP_UPD_info,??);
729 o->fun = stgCast(StgClosure*,xPopPtr());
730 for(x=0; x < y; ++x) {
731 payloadWord(o,x) = xPopWord();
734 fprintf(stderr,"\tBuilt ");
736 printObj(stgCast(StgClosure*,o));
745 StgPAP* o = stgCast(StgPAP*,xStackPtr(x));
746 SET_HDR(o,&PAP_info,??);
748 o->fun = stgCast(StgClosure*,xPopPtr());
749 for(x=0; x < y; ++x) {
750 payloadWord(o,x) = xPopWord();
753 fprintf(stderr,"\tBuilt ");
755 printObj(stgCast(StgClosure*,o));
762 int offset = BCO_INSTR_8;
763 StgClosure* o = stgCast(StgClosure*,xStackPtr(offset));
764 const StgInfoTable* info = get_itbl(o);
765 nat p = info->layout.payload.ptrs;
766 nat np = info->layout.payload.nptrs;
768 for(i=0; i < p; ++i) {
769 payloadCPtr(o,i) = xPopCPtr();
771 for(i=0; i < np; ++i) {
772 payloadWord(o,p+i) = 0xdeadbeef;
775 fprintf(stderr,"\tBuilt ");
777 printObj(stgCast(StgClosure*,o));
784 int offset = BCO_INSTR_16;
785 StgClosure* o = stgCast(StgClosure*,xStackPtr(offset));
786 const StgInfoTable* info = get_itbl(o);
787 nat p = info->layout.payload.ptrs;
788 nat np = info->layout.payload.nptrs;
790 for(i=0; i < p; ++i) {
791 payloadCPtr(o,i) = xPopCPtr();
793 for(i=0; i < np; ++i) {
794 payloadWord(o,p+i) = 0xdeadbeef;
797 fprintf(stderr,"\tBuilt ");
799 printObj(stgCast(StgClosure*,o));
808 ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
809 /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
811 xSetStackWord(x+y,xStackWord(x));
821 ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
822 /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
824 xSetStackWord(x+y,xStackWord(x));
836 xPushPtr(bcoConstPtr(bco,BCO_INSTR_8));
837 xPushPtr(stgCast(StgPtr,&ret_bco_info));
842 int tag = BCO_INSTR_8;
843 StgWord offset = BCO_INSTR_16;
844 if (constrTag(stgCast(StgClosure*,xStackPtr(0))) != tag) {
851 StgClosure* o = stgCast(StgClosure*,xStackPtr(0));
852 const StgInfoTable* itbl = get_itbl(o);
853 int i = itbl->layout.payload.ptrs;
854 ASSERT( itbl->type == CONSTR
855 || itbl->type == CONSTR_STATIC
856 || itbl->type == CONSTR_NOCAF_STATIC
857 || itbl->type == CONSTR_1_0
858 || itbl->type == CONSTR_0_1
859 || itbl->type == CONSTR_2_0
860 || itbl->type == CONSTR_1_1
861 || itbl->type == CONSTR_0_2
864 xPushCPtr(payloadCPtr(o,i));
870 int n = BCO_INSTR_16;
871 StgPtr p = xStackPtr(n);
877 StgPtr p = xStackPtr(BCO_INSTR_8);
883 xPushPtr(stgCast(StgPtr,bcoConstPtr(bco,BCO_INSTR_8)));
888 int n = BCO_INSTR_16;
889 xPushPtr(stgCast(StgPtr,bcoConstPtr(bco,n)));
894 SSS; PushTaggedRealWorld(); LLL;
899 StgInt i = xTaggedStackInt(BCO_INSTR_8);
905 xPushTaggedInt(bcoConstInt(bco,BCO_INSTR_8));
911 SSS; o = (StgClosure*)grabHpNonUpd(Izh_sizeW); LLL;
912 SET_HDR(o,&Izh_con_info,??);
913 payloadWord(o,0) = xPopTaggedInt();
915 fprintf(stderr,"\tBuilt ");
917 printObj(stgCast(StgClosure*,o));
920 xPushPtr(stgCast(StgPtr,o));
925 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
926 /* ASSERT(isIntLike(con)); */
927 xPushTaggedInt(payloadWord(con,0));
932 StgWord offset = BCO_INSTR_16;
933 StgInt x = xPopTaggedInt();
934 StgInt y = xPopTaggedInt();
940 Case(i_CONST_INTEGER):
944 char* s = bcoConstAddr(bco,BCO_INSTR_8);
947 p = CreateByteArrayToHoldInteger(n);
948 do_fromStr ( s, n, IntegerInsideByteArray(p));
949 SloppifyIntegerEnd(p);
956 StgWord w = xTaggedStackWord(BCO_INSTR_8);
962 xPushTaggedWord(bcoConstWord(bco,BCO_INSTR_8));
968 SSS; o = (StgClosure*)grabHpNonUpd(Wzh_sizeW); LLL;
969 SET_HDR(o,&Wzh_con_info,??);
970 payloadWord(o,0) = xPopTaggedWord();
972 fprintf(stderr,"\tBuilt ");
974 printObj(stgCast(StgClosure*,o));
977 xPushPtr(stgCast(StgPtr,o));
982 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
983 /* ASSERT(isWordLike(con)); */
984 xPushTaggedWord(payloadWord(con,0));
989 StgAddr a = xTaggedStackAddr(BCO_INSTR_8);
995 xPushTaggedAddr(bcoConstAddr(bco,BCO_INSTR_8));
1001 SSS; o = (StgClosure*)grabHpNonUpd(Azh_sizeW); LLL;
1002 SET_HDR(o,&Azh_con_info,??);
1003 payloadPtr(o,0) = xPopTaggedAddr();
1005 fprintf(stderr,"\tBuilt ");
1007 printObj(stgCast(StgClosure*,o));
1010 xPushPtr(stgCast(StgPtr,o));
1013 Case(i_UNPACK_ADDR):
1015 StgClosure* con = (StgClosure*)xStackPtr(0);
1016 /* ASSERT(isAddrLike(con)); */
1017 xPushTaggedAddr(payloadPtr(con,0));
1022 StgChar c = xTaggedStackChar(BCO_INSTR_8);
1028 xPushTaggedChar(bcoConstChar(bco,BCO_INSTR_8));
1034 SSS; o = (StgClosure*)grabHpNonUpd(Czh_sizeW); LLL;
1035 SET_HDR(o,&Czh_con_info,??);
1036 payloadWord(o,0) = xPopTaggedChar();
1037 xPushPtr(stgCast(StgPtr,o));
1039 fprintf(stderr,"\tBuilt ");
1041 printObj(stgCast(StgClosure*,o));
1046 Case(i_UNPACK_CHAR):
1048 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1049 /* ASSERT(isCharLike(con)); */
1050 xPushTaggedChar(payloadWord(con,0));
1055 StgFloat f = xTaggedStackFloat(BCO_INSTR_8);
1056 xPushTaggedFloat(f);
1059 Case(i_CONST_FLOAT):
1061 xPushTaggedFloat(bcoConstFloat(bco,BCO_INSTR_8));
1067 SSS; o = (StgClosure*)grabHpNonUpd(Fzh_sizeW); LLL;
1068 SET_HDR(o,&Fzh_con_info,??);
1069 ASSIGN_FLT(&payloadWord(o,0),xPopTaggedFloat());
1071 fprintf(stderr,"\tBuilt ");
1073 printObj(stgCast(StgClosure*,o));
1076 xPushPtr(stgCast(StgPtr,o));
1079 Case(i_UNPACK_FLOAT):
1081 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1082 /* ASSERT(isFloatLike(con)); */
1083 xPushTaggedFloat(PK_FLT(&payloadWord(con,0)));
1088 StgDouble d = xTaggedStackDouble(BCO_INSTR_8);
1089 xPushTaggedDouble(d);
1092 Case(i_CONST_DOUBLE):
1094 xPushTaggedDouble(bcoConstDouble(bco,BCO_INSTR_8));
1097 Case(i_CONST_DOUBLE_big):
1099 int n = BCO_INSTR_16;
1100 xPushTaggedDouble(bcoConstDouble(bco,n));
1103 Case(i_PACK_DOUBLE):
1106 SSS; o = (StgClosure*)grabHpNonUpd(Dzh_sizeW); LLL;
1107 SET_HDR(o,&Dzh_con_info,??);
1108 ASSIGN_DBL(&payloadWord(o,0),xPopTaggedDouble());
1110 fprintf(stderr,"\tBuilt ");
1111 printObj(stgCast(StgClosure*,o));
1113 xPushPtr(stgCast(StgPtr,o));
1116 Case(i_UNPACK_DOUBLE):
1118 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1119 /* ASSERT(isDoubleLike(con)); */
1120 xPushTaggedDouble(PK_DBL(&payloadWord(con,0)));
1125 StgStablePtr s = xTaggedStackStable(BCO_INSTR_8);
1126 xPushTaggedStable(s);
1129 Case(i_PACK_STABLE):
1132 SSS; o = (StgClosure*)grabHpNonUpd(Stablezh_sizeW); LLL;
1133 SET_HDR(o,&StablePtr_con_info,??);
1134 payloadWord(o,0) = xPopTaggedStable();
1136 fprintf(stderr,"\tBuilt ");
1138 printObj(stgCast(StgClosure*,o));
1141 xPushPtr(stgCast(StgPtr,o));
1144 Case(i_UNPACK_STABLE):
1146 StgClosure* con = (StgClosure*)xStackPtr(0);
1147 /* ASSERT(isStableLike(con)); */
1148 xPushTaggedStable(payloadWord(con,0));
1156 SSS; p = enterBCO_primop1 ( i ); LLL;
1157 if (p) { obj = p; goto enterLoop; };
1162 int i, trc, pc_saved;
1165 trc = 12345678; /* Assume != any StgThreadReturnCode */
1170 p = enterBCO_primop2 ( i, &trc, &bco_tmp, cap );
1173 bciPtr = &(bcoInstr(bco,pc_saved));
1175 if (trc == 12345678) {
1176 /* we want to enter p */
1177 obj = p; goto enterLoop;
1179 /* trc is the the StgThreadReturnCode for this thread */
1180 RETURN((StgThreadReturnCode)trc);
1186 /* combined insns, created by peephole opt */
1189 int x = BCO_INSTR_8;
1190 int y = BCO_INSTR_8;
1191 ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
1192 /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
1199 xSetStackWord(x+y,xStackWord(x));
1209 p = xStackPtr(BCO_INSTR_8);
1211 p = xStackPtr(BCO_INSTR_8);
1218 xPushPtr(bcoConstPtr(bco,BCO_INSTR_8));
1219 xPushPtr(stgCast(StgPtr,&ret_bco_info));
1220 p = xStackPtr(BCO_INSTR_8);
1226 StgPtr retaddr = bcoConstPtr(bco,BCO_INSTR_8);
1227 StgPtr ptr = xStackPtr(BCO_INSTR_8);
1229 /* A shortcut. We're going to push the address of a
1230 return continuation, and then enter a variable, so
1231 that when the var is evaluated, we return to the
1232 continuation. The shortcut is: if the var is a
1233 constructor, don't bother to enter it. Instead,
1234 push the variable on the stack (since this is what
1235 the continuation expects) and jump directly to the
1238 if (get_itbl((StgClosure*)ptr)->type == CONSTR) {
1240 obj = (StgClosure*)retaddr;
1242 fprintf(stderr, "object to enter is a constructor -- "
1243 "jumping directly to return continuation\n" );
1248 /* This is the normal, non-short-cut route */
1250 xPushPtr(stgCast(StgPtr,&ret_bco_info));
1251 obj = (StgClosure*)ptr;
1256 Case(i_VAR_DOUBLE_big):
1257 Case(i_CONST_FLOAT_big):
1258 Case(i_VAR_FLOAT_big):
1259 Case(i_CONST_CHAR_big):
1260 Case(i_VAR_CHAR_big):
1261 Case(i_CONST_ADDR_big):
1262 Case(i_VAR_ADDR_big):
1263 Case(i_VAR_STABLE_big):
1264 Case(i_CONST_INTEGER_big):
1265 Case(i_CONST_INT_big):
1266 Case(i_VAR_INT_big):
1267 Case(i_VAR_WORD_big):
1268 Case(i_RETADDR_big):
1272 disInstr ( bco, PC );
1273 barf("\nUnrecognised instruction");
1277 barf("enterBCO: ran off end of loop");
1281 # undef LoopTopLabel
1287 /* ---------------------------------------------------- */
1288 /* End of the bytecode evaluator */
1289 /* ---------------------------------------------------- */
1293 StgBlockingQueue* bh;
1294 StgCAF* caf = (StgCAF*)obj;
1295 if (xSp - sizeofW(StgUpdateFrame) < xSpLim) {
1296 xPushCPtr(obj); /* code to restart with */
1297 RETURN(StackOverflow);
1299 /* ToDo: look for xSp==xSu && stackInt(0) == UPD_FRAME
1300 and insert an indirection immediately */
1301 SSS; bh = (StgBlockingQueue*)grabHpUpd(BLACKHOLE_sizeW()); LLL;
1302 SET_INFO(bh,&CAF_BLACKHOLE_info);
1303 bh->blocking_queue = EndTSOQueue;
1305 fprintf(stderr,"Created CAF_BLACKHOLE %p for CAF %p in evaluator\n",bh,caf));
1306 SET_INFO(caf,&CAF_ENTERED_info);
1307 caf->value = (StgClosure*)bh;
1308 if (caf->mut_link == NULL) {
1309 SSS; recordOldToNewPtrs((StgMutClosure*)caf); LLL;
1311 xPushUpdateFrame(bh,0);
1312 xSp -= sizeofW(StgUpdateFrame);
1313 caf->link = enteredCAFs;
1320 StgCAF* caf = (StgCAF*)obj;
1321 obj = caf->value; /* it's just a fancy indirection */
1327 case SE_CAF_BLACKHOLE:
1329 /*was StgBlackHole* */
1330 StgBlockingQueue* bh = (StgBlockingQueue*)obj;
1331 /* Put ourselves on the blocking queue for this black hole and block */
1332 cap->rCurrentTSO->link = bh->blocking_queue;
1333 bh->blocking_queue = cap->rCurrentTSO;
1334 xPushCPtr(obj); /* code to restart with */
1335 barf("enter: CAF_BLACKHOLE unexpected!");
1336 RETURN(ThreadBlocked);
1340 StgAP_UPD* ap = stgCast(StgAP_UPD*,obj);
1342 if (xSp - (i + sizeofW(StgUpdateFrame)) < xSpLim) {
1343 xPushCPtr(obj); /* code to restart with */
1344 RETURN(StackOverflow);
1346 /* ToDo: look for xSp==xSu && stackInt(0) == UPD_FRAME
1347 and insert an indirection immediately */
1348 xPushUpdateFrame(ap,0);
1349 xSp -= sizeofW(StgUpdateFrame);
1351 xPushWord(payloadWord(ap,i));
1354 #ifdef EAGER_BLACKHOLING
1355 #warn LAZY_BLACKHOLING is default for StgHugs
1356 #error Dont know if EAGER_BLACKHOLING works in StgHugs
1358 /* superfluous - but makes debugging easier */
1359 StgBlackHole* bh = stgCast(StgBlackHole*,ap);
1360 SET_INFO(bh,&BLACKHOLE_info);
1361 bh->blocking_queue = EndTSOQueue;
1363 fprintf(stderr,"Eagerly blackholed AP_UPD %p in evaluator\n",bh));
1366 #endif /* EAGER_BLACKHOLING */
1371 StgPAP* pap = stgCast(StgPAP*,obj);
1372 int i = pap->n_args; /* ToDo: stack check */
1373 /* ToDo: if PAP is in whnf, we can update any update frames
1377 xPushWord(payloadWord(pap,i));
1384 obj = stgCast(StgInd*,obj)->indirectee;
1389 obj = stgCast(StgIndOldGen*,obj)->indirectee;
1398 case CONSTR_INTLIKE:
1399 case CONSTR_CHARLIKE:
1401 case CONSTR_NOCAF_STATIC:
1404 switch (get_itbl(stgCast(StgClosure*,xSp))->type) {
1406 SSS; PopCatchFrame(); LLL;
1409 xPopUpdateFrame(obj);
1412 SSS; PopSeqFrame(); LLL;
1416 ASSERT(xSp==(P_)xSu);
1419 fprintf(stderr, "hit a STOP_FRAME\n");
1421 fprintf(stderr,"xSp = %p\txSu = %p\n", xSp, xSu);
1422 printStack(xSp,cap->rCurrentTSO->stack
1423 + cap->rCurrentTSO->stack_size,xSu);
1426 SSS; PopStopFrame(obj); LLL;
1427 RETURN(ThreadFinished);
1437 /* was: goto enterLoop;
1438 But we know that obj must be a bco now, so jump directly.
1441 case RET_SMALL: /* return to GHC */
1445 // barf("todo: RET_[VEC_]{BIG,SMALL}");
1447 belch("entered CONSTR with invalid continuation on stack");
1450 printObj(stgCast(StgClosure*,xSp));
1453 barf("bailing out");
1460 //fprintf(stderr, "enterCountI = %d\n", enterCountI);
1461 //fprintf(stderr, "entering unknown closure -- yielding to sched\n");
1464 cap->rCurrentTSO->whatNext = ThreadEnterGHC;
1465 xPushCPtr(obj); /* code to restart with */
1466 RETURN(ThreadYielding);
1469 barf("Ran off the end of enter - yoiks");
1486 #undef xSetStackWord
1489 #undef xPushTaggedInt
1490 #undef xPopTaggedInt
1491 #undef xTaggedStackInt
1492 #undef xPushTaggedWord
1493 #undef xPopTaggedWord
1494 #undef xTaggedStackWord
1495 #undef xPushTaggedAddr
1496 #undef xTaggedStackAddr
1497 #undef xPopTaggedAddr
1498 #undef xPushTaggedStable
1499 #undef xTaggedStackStable
1500 #undef xPopTaggedStable
1501 #undef xPushTaggedChar
1502 #undef xTaggedStackChar
1503 #undef xPopTaggedChar
1504 #undef xPushTaggedFloat
1505 #undef xTaggedStackFloat
1506 #undef xPopTaggedFloat
1507 #undef xPushTaggedDouble
1508 #undef xTaggedStackDouble
1509 #undef xPopTaggedDouble
1510 #undef xPopUpdateFrame
1511 #undef xPushUpdateFrame
1514 /* --------------------------------------------------------------------------
1515 * Supporting routines for primops
1516 * ------------------------------------------------------------------------*/
1518 static inline void PushTag ( StackTag t )
1520 inline void PushPtr ( StgPtr x )
1521 { *(--stgCast(StgPtr*,gSp)) = x; }
1522 static inline void PushCPtr ( StgClosure* x )
1523 { *(--stgCast(StgClosure**,gSp)) = x; }
1524 static inline void PushInt ( StgInt x )
1525 { *(--stgCast(StgInt*,gSp)) = x; }
1526 static inline void PushWord ( StgWord x )
1527 { *(--stgCast(StgWord*,gSp)) = x; }
1530 static inline void checkTag ( StackTag t1, StackTag t2 )
1531 { ASSERT(t1 == t2);}
1532 static inline void PopTag ( StackTag t )
1533 { checkTag(t,*(gSp++)); }
1534 inline StgPtr PopPtr ( void )
1535 { return *stgCast(StgPtr*,gSp)++; }
1536 static inline StgClosure* PopCPtr ( void )
1537 { return *stgCast(StgClosure**,gSp)++; }
1538 static inline StgInt PopInt ( void )
1539 { return *stgCast(StgInt*,gSp)++; }
1540 static inline StgWord PopWord ( void )
1541 { return *stgCast(StgWord*,gSp)++; }
1543 static inline StgPtr stackPtr ( StgStackOffset i )
1544 { return *stgCast(StgPtr*, gSp+i); }
1545 static inline StgInt stackInt ( StgStackOffset i )
1546 { return *stgCast(StgInt*, gSp+i); }
1547 static inline StgWord stackWord ( StgStackOffset i )
1548 { return *stgCast(StgWord*,gSp+i); }
1550 static inline void setStackWord ( StgStackOffset i, StgWord w )
1553 static inline void PushTaggedRealWorld( void )
1554 { PushTag(REALWORLD_TAG); }
1555 inline void PushTaggedInt ( StgInt x )
1556 { gSp -= sizeofW(StgInt); *gSp = x; PushTag(INT_TAG); }
1557 inline void PushTaggedWord ( StgWord x )
1558 { gSp -= sizeofW(StgWord); *gSp = x; PushTag(WORD_TAG); }
1559 inline void PushTaggedAddr ( StgAddr x )
1560 { gSp -= sizeofW(StgAddr); *gSp = (W_)x; PushTag(ADDR_TAG); }
1561 inline void PushTaggedChar ( StgChar x )
1562 { gSp -= sizeofW(StgChar); *gSp = stgCast(StgWord,x); PushTag(CHAR_TAG); }
1563 inline void PushTaggedFloat ( StgFloat x )
1564 { gSp -= sizeofW(StgFloat); ASSIGN_FLT(gSp,x); PushTag(FLOAT_TAG); }
1565 inline void PushTaggedDouble ( StgDouble x )
1566 { gSp -= sizeofW(StgDouble); ASSIGN_DBL(gSp,x); PushTag(DOUBLE_TAG); }
1567 inline void PushTaggedStablePtr ( StgStablePtr x )
1568 { gSp -= sizeofW(StgStablePtr); *gSp = x; PushTag(STABLE_TAG); }
1569 static inline void PushTaggedBool ( int x )
1570 { PushTaggedInt(x); }
1574 static inline void PopTaggedRealWorld ( void )
1575 { PopTag(REALWORLD_TAG); }
1576 inline StgInt PopTaggedInt ( void )
1577 { StgInt r; PopTag(INT_TAG); r = *stgCast(StgInt*, gSp);
1578 gSp += sizeofW(StgInt); return r;}
1579 inline StgWord PopTaggedWord ( void )
1580 { StgWord r; PopTag(WORD_TAG); r = *stgCast(StgWord*, gSp);
1581 gSp += sizeofW(StgWord); return r;}
1582 inline StgAddr PopTaggedAddr ( void )
1583 { StgAddr r; PopTag(ADDR_TAG); r = *stgCast(StgAddr*, gSp);
1584 gSp += sizeofW(StgAddr); return r;}
1585 inline StgChar PopTaggedChar ( void )
1586 { StgChar r; PopTag(CHAR_TAG); r = stgCast(StgChar, *gSp);
1587 gSp += sizeofW(StgChar); return r;}
1588 inline StgFloat PopTaggedFloat ( void )
1589 { StgFloat r; PopTag(FLOAT_TAG); r = PK_FLT(gSp);
1590 gSp += sizeofW(StgFloat); return r;}
1591 inline StgDouble PopTaggedDouble ( void )
1592 { StgDouble r; PopTag(DOUBLE_TAG); r = PK_DBL(gSp);
1593 gSp += sizeofW(StgDouble); return r;}
1594 inline StgStablePtr PopTaggedStablePtr ( void )
1595 { StgInt r; PopTag(STABLE_TAG); r = *stgCast(StgStablePtr*, gSp);
1596 gSp += sizeofW(StgStablePtr); return r;}
1600 static inline StgInt taggedStackInt ( StgStackOffset i )
1601 { checkTag(INT_TAG,gSp[i]); return *stgCast(StgInt*, gSp+1+i); }
1602 static inline StgWord taggedStackWord ( StgStackOffset i )
1603 { checkTag(WORD_TAG,gSp[i]); return *stgCast(StgWord*, gSp+1+i); }
1604 static inline StgAddr taggedStackAddr ( StgStackOffset i )
1605 { checkTag(ADDR_TAG,gSp[i]); return *stgCast(StgAddr*, gSp+1+i); }
1606 static inline StgChar taggedStackChar ( StgStackOffset i )
1607 { checkTag(CHAR_TAG,gSp[i]); return stgCast(StgChar, *(gSp+1+i)) ; }
1608 static inline StgFloat taggedStackFloat ( StgStackOffset i )
1609 { checkTag(FLOAT_TAG,gSp[i]); return PK_FLT(gSp+1+i); }
1610 static inline StgDouble taggedStackDouble ( StgStackOffset i )
1611 { checkTag(DOUBLE_TAG,gSp[i]); return PK_DBL(gSp+1+i); }
1612 static inline StgStablePtr taggedStackStable ( StgStackOffset i )
1613 { checkTag(STABLE_TAG,gSp[i]); return *stgCast(StgStablePtr*, gSp+1+i); }
1616 /* --------------------------------------------------------------------------
1619 * Should we allocate from a nursery or use the
1620 * doYouWantToGC/allocate interface? We'd already implemented a
1621 * nursery-style scheme when the doYouWantToGC/allocate interface
1623 * One reason to prefer the doYouWantToGC/allocate interface is to
1624 * support operations which allocate an unknown amount in the heap
1625 * (array ops, gmp ops, etc)
1626 * ------------------------------------------------------------------------*/
1628 static inline StgPtr grabHpUpd( nat size )
1630 ASSERT( size >= MIN_UPD_SIZE + sizeofW(StgHeader) );
1631 #ifdef CRUDE_PROFILING
1632 cp_bill_words ( size );
1634 return allocate(size);
1637 static inline StgPtr grabHpNonUpd( nat size )
1639 ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
1640 #ifdef CRUDE_PROFILING
1641 cp_bill_words ( size );
1643 return allocate(size);
1646 /* --------------------------------------------------------------------------
1647 * Manipulate "update frame" list:
1648 * o Update frames (based on stg_do_update and friends in Updates.hc)
1649 * o Error handling/catching (based on catchzh_fast and friends in Prims.hc)
1650 * o Seq frames (based on seq_frame_entry in Prims.hc)
1652 * ------------------------------------------------------------------------*/
1654 static inline void PopUpdateFrame ( StgClosure* obj )
1656 /* NB: doesn't assume that gSp == gSu */
1658 fprintf(stderr, "Updating ");
1659 printPtr(stgCast(StgPtr,gSu->updatee));
1660 fprintf(stderr, " with ");
1662 fprintf(stderr,"gSp = %p\tgSu = %p\n\n", gSp, gSu);
1664 #ifdef EAGER_BLACKHOLING
1665 #warn LAZY_BLACKHOLING is default for StgHugs
1666 #error Dont know if EAGER_BLACKHOLING works in StgHugs
1667 ASSERT(get_itbl(gSu->updatee)->type == BLACKHOLE
1668 || get_itbl(gSu->updatee)->type == SE_BLACKHOLE
1669 || get_itbl(gSu->updatee)->type == CAF_BLACKHOLE
1670 || get_itbl(gSu->updatee)->type == SE_CAF_BLACKHOLE
1672 #endif /* EAGER_BLACKHOLING */
1673 UPD_IND(gSu->updatee,obj);
1674 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgUpdateFrame);
1678 static inline void PopStopFrame ( StgClosure* obj )
1680 /* Move gSu just off the end of the stack, we're about to gSpam the
1681 * STOP_FRAME with the return value.
1683 gSu = stgCast(StgUpdateFrame*,gSp+1);
1684 *stgCast(StgClosure**,gSp) = obj;
1687 static inline void PushCatchFrame ( StgClosure* handler )
1690 /* ToDo: stack check! */
1691 gSp -= sizeofW(StgCatchFrame);
1692 fp = stgCast(StgCatchFrame*,gSp);
1693 SET_HDR(fp,(StgInfoTable*)&catch_frame_info,CCCS);
1694 fp->handler = handler;
1696 gSu = stgCast(StgUpdateFrame*,fp);
1699 static inline void PopCatchFrame ( void )
1701 /* NB: doesn't assume that gSp == gSu */
1702 /* fprintf(stderr,"Popping catch frame\n"); */
1703 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgCatchFrame);
1704 gSu = stgCast(StgCatchFrame*,gSu)->link;
1707 static inline void PushSeqFrame ( void )
1710 /* ToDo: stack check! */
1711 gSp -= sizeofW(StgSeqFrame);
1712 fp = stgCast(StgSeqFrame*,gSp);
1713 SET_HDR(fp,(StgInfoTable*)&seq_frame_info,CCCS);
1715 gSu = stgCast(StgUpdateFrame*,fp);
1718 static inline void PopSeqFrame ( void )
1720 /* NB: doesn't assume that gSp == gSu */
1721 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgSeqFrame);
1722 gSu = stgCast(StgSeqFrame*,gSu)->link;
1725 static inline StgClosure* raiseAnError ( StgClosure* exception )
1727 /* This closure represents the expression 'primRaise E' where E
1728 * is the exception raised (:: Exception).
1729 * It is used to overwrite all the
1730 * thunks which are currently under evaluation.
1732 HaskellObj primRaiseClosure
1733 = asmClosureOfObject(getHugs_AsmObject_for("primRaise"));
1734 HaskellObj reraiseClosure
1735 = rts_apply ( primRaiseClosure, exception );
1738 switch (get_itbl(gSu)->type) {
1740 UPD_IND(gSu->updatee,reraiseClosure);
1741 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgUpdateFrame);
1747 case CATCH_FRAME: /* found it! */
1749 StgCatchFrame* fp = stgCast(StgCatchFrame*,gSu);
1750 StgClosure *handler = fp->handler;
1752 gSp += sizeofW(StgCatchFrame); /* Pop */
1753 PushCPtr(exception);
1757 barf("raiseError: uncaught exception: STOP_FRAME");
1759 barf("raiseError: weird activation record");
1765 static StgClosure* makeErrorCall ( const char* msg )
1767 /* Note! the msg string should be allocated in a
1768 place which will not get freed -- preferably
1769 read-only data of the program. That's because
1770 the thunk we build here may linger indefinitely.
1771 (thinks: probably not so, but anyway ...)
1774 = asmClosureOfObject(getHugs_AsmObject_for("error"));
1776 = asmClosureOfObject(getHugs_AsmObject_for("primUnpackString"));
1778 = rts_apply ( unpack, rts_mkAddr ( (void*)msg ) );
1780 = rts_apply ( error, thunk );
1782 (StgClosure*) thunk;
1785 #define raiseIndex(where) makeErrorCall("Array index out of range in " where)
1786 #define raiseDiv0(where) makeErrorCall("Division by zero in " where)
1788 /* --------------------------------------------------------------------------
1790 * ------------------------------------------------------------------------*/
1792 #define OP_CC_B(e) \
1794 unsigned char x = PopTaggedChar(); \
1795 unsigned char y = PopTaggedChar(); \
1796 PushTaggedBool(e); \
1801 unsigned char x = PopTaggedChar(); \
1810 #define OP_IW_I(e) \
1812 StgInt x = PopTaggedInt(); \
1813 StgWord y = PopTaggedWord(); \
1817 #define OP_II_I(e) \
1819 StgInt x = PopTaggedInt(); \
1820 StgInt y = PopTaggedInt(); \
1824 #define OP_II_B(e) \
1826 StgInt x = PopTaggedInt(); \
1827 StgInt y = PopTaggedInt(); \
1828 PushTaggedBool(e); \
1833 PushTaggedAddr(e); \
1838 StgInt x = PopTaggedInt(); \
1839 PushTaggedAddr(e); \
1844 StgInt x = PopTaggedInt(); \
1850 PushTaggedChar(e); \
1855 StgInt x = PopTaggedInt(); \
1856 PushTaggedChar(e); \
1861 PushTaggedWord(e); \
1866 StgInt x = PopTaggedInt(); \
1867 PushTaggedWord(e); \
1872 StgInt x = PopTaggedInt(); \
1873 PushTaggedStablePtr(e); \
1878 PushTaggedFloat(e); \
1883 StgInt x = PopTaggedInt(); \
1884 PushTaggedFloat(e); \
1889 PushTaggedDouble(e); \
1894 StgInt x = PopTaggedInt(); \
1895 PushTaggedDouble(e); \
1898 #define OP_WW_B(e) \
1900 StgWord x = PopTaggedWord(); \
1901 StgWord y = PopTaggedWord(); \
1902 PushTaggedBool(e); \
1905 #define OP_WW_W(e) \
1907 StgWord x = PopTaggedWord(); \
1908 StgWord y = PopTaggedWord(); \
1909 PushTaggedWord(e); \
1914 StgWord x = PopTaggedWord(); \
1920 StgStablePtr x = PopTaggedStablePtr(); \
1926 StgWord x = PopTaggedWord(); \
1927 PushTaggedWord(e); \
1930 #define OP_AA_B(e) \
1932 StgAddr x = PopTaggedAddr(); \
1933 StgAddr y = PopTaggedAddr(); \
1934 PushTaggedBool(e); \
1938 StgAddr x = PopTaggedAddr(); \
1941 #define OP_AI_C(s) \
1943 StgAddr x = PopTaggedAddr(); \
1944 int y = PopTaggedInt(); \
1947 PushTaggedChar(r); \
1949 #define OP_AI_I(s) \
1951 StgAddr x = PopTaggedAddr(); \
1952 int y = PopTaggedInt(); \
1957 #define OP_AI_A(s) \
1959 StgAddr x = PopTaggedAddr(); \
1960 int y = PopTaggedInt(); \
1963 PushTaggedAddr(s); \
1965 #define OP_AI_F(s) \
1967 StgAddr x = PopTaggedAddr(); \
1968 int y = PopTaggedInt(); \
1971 PushTaggedFloat(r); \
1973 #define OP_AI_D(s) \
1975 StgAddr x = PopTaggedAddr(); \
1976 int y = PopTaggedInt(); \
1979 PushTaggedDouble(r); \
1981 #define OP_AI_s(s) \
1983 StgAddr x = PopTaggedAddr(); \
1984 int y = PopTaggedInt(); \
1987 PushTaggedStablePtr(r); \
1989 #define OP_AIC_(s) \
1991 StgAddr x = PopTaggedAddr(); \
1992 int y = PopTaggedInt(); \
1993 StgChar z = PopTaggedChar(); \
1996 #define OP_AII_(s) \
1998 StgAddr x = PopTaggedAddr(); \
1999 int y = PopTaggedInt(); \
2000 StgInt z = PopTaggedInt(); \
2003 #define OP_AIA_(s) \
2005 StgAddr x = PopTaggedAddr(); \
2006 int y = PopTaggedInt(); \
2007 StgAddr z = PopTaggedAddr(); \
2010 #define OP_AIF_(s) \
2012 StgAddr x = PopTaggedAddr(); \
2013 int y = PopTaggedInt(); \
2014 StgFloat z = PopTaggedFloat(); \
2017 #define OP_AID_(s) \
2019 StgAddr x = PopTaggedAddr(); \
2020 int y = PopTaggedInt(); \
2021 StgDouble z = PopTaggedDouble(); \
2024 #define OP_AIs_(s) \
2026 StgAddr x = PopTaggedAddr(); \
2027 int y = PopTaggedInt(); \
2028 StgStablePtr z = PopTaggedStablePtr(); \
2033 #define OP_FF_B(e) \
2035 StgFloat x = PopTaggedFloat(); \
2036 StgFloat y = PopTaggedFloat(); \
2037 PushTaggedBool(e); \
2040 #define OP_FF_F(e) \
2042 StgFloat x = PopTaggedFloat(); \
2043 StgFloat y = PopTaggedFloat(); \
2044 PushTaggedFloat(e); \
2049 StgFloat x = PopTaggedFloat(); \
2050 PushTaggedFloat(e); \
2055 StgFloat x = PopTaggedFloat(); \
2056 PushTaggedBool(e); \
2061 StgFloat x = PopTaggedFloat(); \
2067 StgFloat x = PopTaggedFloat(); \
2068 PushTaggedDouble(e); \
2071 #define OP_DD_B(e) \
2073 StgDouble x = PopTaggedDouble(); \
2074 StgDouble y = PopTaggedDouble(); \
2075 PushTaggedBool(e); \
2078 #define OP_DD_D(e) \
2080 StgDouble x = PopTaggedDouble(); \
2081 StgDouble y = PopTaggedDouble(); \
2082 PushTaggedDouble(e); \
2087 StgDouble x = PopTaggedDouble(); \
2088 PushTaggedBool(e); \
2093 StgDouble x = PopTaggedDouble(); \
2094 PushTaggedDouble(e); \
2099 StgDouble x = PopTaggedDouble(); \
2105 StgDouble x = PopTaggedDouble(); \
2106 PushTaggedFloat(e); \
2110 #ifdef STANDALONE_INTEGER
2111 StgPtr CreateByteArrayToHoldInteger ( int nbytes )
2113 StgInt words = (nbytes+sizeof(W_)-1)/sizeof(W_);
2114 StgWord size = sizeofW(StgArrWords) + words;
2115 StgArrWords* arr = (StgArrWords*)allocate(size);
2116 SET_HDR(arr,&ARR_WORDS_info,CCCS);
2118 ASSERT(nbytes <= arr->words * sizeof(W_));
2121 for (i = 0; i < words; ++i) {
2122 arr->payload[i] = 0xdeadbeef;
2124 { B* b = (B*) &(arr->payload[0]);
2125 b->used = b->sign = 0;
2131 B* IntegerInsideByteArray ( StgPtr arr0 )
2134 StgArrWords* arr = (StgArrWords*)arr0;
2135 ASSERT(GET_INFO(arr) == &ARR_WORDS_info);
2136 b = (B*) &(arr->payload[0]);
2140 void SloppifyIntegerEnd ( StgPtr arr0 )
2142 StgArrWords* arr = (StgArrWords*)arr0;
2143 B* b = (B*) & (arr->payload[0]);
2144 I_ nwunused = arr->words - sizeofW(B) - (b->used+sizeof(W_)-1)/sizeof(W_);
2145 if (nwunused >= ((I_)sizeofW(StgArrWords))) {
2147 b->size -= nwunused * sizeof(W_);
2148 if (b->size < b->used) b->size = b->used;
2151 arr->words -= nwunused;
2152 slop = (StgArrWords*)&(arr->payload[arr->words]);
2153 SET_HDR(slop,&ARR_WORDS_info,CCCS);
2154 slop->words = nwunused - sizeofW(StgArrWords);
2155 ASSERT( &(slop->payload[slop->words]) ==
2156 &(arr->payload[arr->words + nwunused]) );
2160 #define OP_Z_Z(op) \
2162 B* x = IntegerInsideByteArray(PopPtr()); \
2163 int n = mycat2(size_,op)(x); \
2164 StgPtr p = CreateByteArrayToHoldInteger(n); \
2165 mycat2(do_,op)(x,n,IntegerInsideByteArray(p)); \
2166 SloppifyIntegerEnd(p); \
2169 #define OP_ZZ_Z(op) \
2171 B* x = IntegerInsideByteArray(PopPtr()); \
2172 B* y = IntegerInsideByteArray(PopPtr()); \
2173 int n = mycat2(size_,op)(x,y); \
2174 StgPtr p = CreateByteArrayToHoldInteger(n); \
2175 mycat2(do_,op)(x,y,n,IntegerInsideByteArray(p)); \
2176 SloppifyIntegerEnd(p); \
2184 #define HEADER_mI(ty,where) \
2185 StgArrWords* x = stgCast(StgArrWords*,PopPtr()); \
2186 nat i = PopTaggedInt(); \
2187 if (i * sizeof(ty) + (sizeof(ty)) > sizeof(StgWord) * x->words) { \
2188 return (raiseIndex(where)); \
2190 #define OP_mI_ty(ty,where,s) \
2192 HEADER_mI(mycat2(Stg,ty),where) \
2193 { mycat2(Stg,ty) r; \
2195 mycat2(PushTagged,ty)(r); \
2198 #define OP_mIty_(ty,where,s) \
2200 HEADER_mI(mycat2(Stg,ty),where) \
2202 mycat2(Stg,ty) z = mycat2(PopTagged,ty)(); \
2208 void myStackCheck ( Capability* cap )
2210 /* fprintf(stderr, "myStackCheck\n"); */
2211 if (!(gSpLim <= gSp && gSp <= stgCast(StgPtr,gSu))) {
2212 fprintf(stderr, "myStackCheck: invalid initial gSp/gSu \n" );
2216 if (!(gSu >= cap->rCurrentTSO->stack
2217 && gSu <= cap->rCurrentTSO->stack
2218 + cap->rCurrentTSO->stack_size)) {
2219 fprintf ( stderr, "myStackCheck: gSu out of stack\n" );
2222 switch (get_itbl(stgCast(StgClosure*,gSu))->type) {
2224 gSu = (StgPtr) ((StgCatchFrame*)(gSu))->link;
2227 gSu = (StgPtr) ((StgUpdateFrame*)(gSu))->link;
2230 gSu = (StgPtr) ((StgSeqFrame*)(gSu))->link;
2235 fprintf(stderr, "myStackCheck: invalid activation record\n"); assert(0);
2242 /* --------------------------------------------------------------------------
2243 * Primop stuff for bytecode interpreter
2244 * ------------------------------------------------------------------------*/
2246 /* Returns & of the next thing to enter (if throwing an exception),
2247 or NULL in the normal case.
2249 static void* enterBCO_primop1 ( int primop1code )
2251 switch (primop1code) {
2252 case i_pushseqframe:
2254 StgClosure* c = PopCPtr();
2259 case i_pushcatchframe:
2261 StgClosure* e = PopCPtr();
2262 StgClosure* h = PopCPtr();
2268 case i_gtChar: OP_CC_B(x>y); break;
2269 case i_geChar: OP_CC_B(x>=y); break;
2270 case i_eqChar: OP_CC_B(x==y); break;
2271 case i_neChar: OP_CC_B(x!=y); break;
2272 case i_ltChar: OP_CC_B(x<y); break;
2273 case i_leChar: OP_CC_B(x<=y); break;
2274 case i_charToInt: OP_C_I(x); break;
2275 case i_intToChar: OP_I_C(x); break;
2277 case i_gtInt: OP_II_B(x>y); break;
2278 case i_geInt: OP_II_B(x>=y); break;
2279 case i_eqInt: OP_II_B(x==y); break;
2280 case i_neInt: OP_II_B(x!=y); break;
2281 case i_ltInt: OP_II_B(x<y); break;
2282 case i_leInt: OP_II_B(x<=y); break;
2283 case i_minInt: OP__I(INT_MIN); break;
2284 case i_maxInt: OP__I(INT_MAX); break;
2285 case i_plusInt: OP_II_I(x+y); break;
2286 case i_minusInt: OP_II_I(x-y); break;
2287 case i_timesInt: OP_II_I(x*y); break;
2290 int x = PopTaggedInt();
2291 int y = PopTaggedInt();
2293 return (raiseDiv0("quotInt"));
2295 /* ToDo: protect against minInt / -1 errors
2296 * (repeat for all other division primops) */
2302 int x = PopTaggedInt();
2303 int y = PopTaggedInt();
2305 return (raiseDiv0("remInt"));
2312 StgInt x = PopTaggedInt();
2313 StgInt y = PopTaggedInt();
2315 return (raiseDiv0("quotRemInt"));
2317 PushTaggedInt(x%y); /* last result */
2318 PushTaggedInt(x/y); /* first result */
2321 case i_negateInt: OP_I_I(-x); break;
2323 case i_andInt: OP_II_I(x&y); break;
2324 case i_orInt: OP_II_I(x|y); break;
2325 case i_xorInt: OP_II_I(x^y); break;
2326 case i_notInt: OP_I_I(~x); break;
2327 case i_shiftLInt: OP_II_I(x<<y); break;
2328 case i_shiftRAInt: OP_II_I(x>>y); break; /* ToDo */
2329 case i_shiftRLInt: OP_II_I(x>>y); break; /* ToDo */
2331 case i_gtWord: OP_WW_B(x>y); break;
2332 case i_geWord: OP_WW_B(x>=y); break;
2333 case i_eqWord: OP_WW_B(x==y); break;
2334 case i_neWord: OP_WW_B(x!=y); break;
2335 case i_ltWord: OP_WW_B(x<y); break;
2336 case i_leWord: OP_WW_B(x<=y); break;
2337 case i_minWord: OP__W(0); break;
2338 case i_maxWord: OP__W(UINT_MAX); break;
2339 case i_plusWord: OP_WW_W(x+y); break;
2340 case i_minusWord: OP_WW_W(x-y); break;
2341 case i_timesWord: OP_WW_W(x*y); break;
2344 StgWord x = PopTaggedWord();
2345 StgWord y = PopTaggedWord();
2347 return (raiseDiv0("quotWord"));
2349 PushTaggedWord(x/y);
2354 StgWord x = PopTaggedWord();
2355 StgWord y = PopTaggedWord();
2357 return (raiseDiv0("remWord"));
2359 PushTaggedWord(x%y);
2364 StgWord x = PopTaggedWord();
2365 StgWord y = PopTaggedWord();
2367 return (raiseDiv0("quotRemWord"));
2369 PushTaggedWord(x%y); /* last result */
2370 PushTaggedWord(x/y); /* first result */
2373 case i_negateWord: OP_W_W(-x); break;
2374 case i_andWord: OP_WW_W(x&y); break;
2375 case i_orWord: OP_WW_W(x|y); break;
2376 case i_xorWord: OP_WW_W(x^y); break;
2377 case i_notWord: OP_W_W(~x); break;
2378 case i_shiftLWord: OP_WW_W(x<<y); break;
2379 case i_shiftRAWord: OP_WW_W(x>>y); break; /* ToDo */
2380 case i_shiftRLWord: OP_WW_W(x>>y); break; /* ToDo */
2381 case i_intToWord: OP_I_W(x); break;
2382 case i_wordToInt: OP_W_I(x); break;
2384 case i_gtAddr: OP_AA_B(x>y); break;
2385 case i_geAddr: OP_AA_B(x>=y); break;
2386 case i_eqAddr: OP_AA_B(x==y); break;
2387 case i_neAddr: OP_AA_B(x!=y); break;
2388 case i_ltAddr: OP_AA_B(x<y); break;
2389 case i_leAddr: OP_AA_B(x<=y); break;
2390 case i_intToAddr: OP_I_A((StgAddr)x); break; /* ToDo */
2391 case i_addrToInt: OP_A_I((StgInt)x); break; /* ToDo */
2393 case i_intToStable: OP_I_s(x); break;
2394 case i_stableToInt: OP_s_I(x); break;
2396 case i_indexCharOffAddr: OP_AI_C(indexCharOffAddrzh(r,x,y)); break;
2397 case i_readCharOffAddr: OP_AI_C(indexCharOffAddrzh(r,x,y)); break;
2398 case i_writeCharOffAddr: OP_AIC_(writeCharOffAddrzh(x,y,z)); break;
2400 case i_indexIntOffAddr: OP_AI_I(indexIntOffAddrzh(r,x,y)); break;
2401 case i_readIntOffAddr: OP_AI_I(indexIntOffAddrzh(r,x,y)); break;
2402 case i_writeIntOffAddr: OP_AII_(writeIntOffAddrzh(x,y,z)); break;
2404 case i_indexAddrOffAddr: OP_AI_A(indexAddrOffAddrzh(r,x,y)); break;
2405 case i_readAddrOffAddr: OP_AI_A(indexAddrOffAddrzh(r,x,y)); break;
2406 case i_writeAddrOffAddr: OP_AIA_(writeAddrOffAddrzh(x,y,z)); break;
2408 case i_indexFloatOffAddr: OP_AI_F(indexFloatOffAddrzh(r,x,y)); break;
2409 case i_readFloatOffAddr: OP_AI_F(indexFloatOffAddrzh(r,x,y)); break;
2410 case i_writeFloatOffAddr: OP_AIF_(writeFloatOffAddrzh(x,y,z)); break;
2412 case i_indexDoubleOffAddr: OP_AI_D(indexDoubleOffAddrzh(r,x,y)); break;
2413 case i_readDoubleOffAddr: OP_AI_D(indexDoubleOffAddrzh(r,x,y)); break;
2414 case i_writeDoubleOffAddr: OP_AID_(writeDoubleOffAddrzh(x,y,z)); break;
2416 case i_indexStableOffAddr: OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break;
2417 case i_readStableOffAddr: OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break;
2418 case i_writeStableOffAddr: OP_AIs_(writeStablePtrOffAddrzh(x,y,z)); break;
2420 #ifdef STANDALONE_INTEGER
2421 case i_compareInteger:
2423 B* x = IntegerInsideByteArray(PopPtr());
2424 B* y = IntegerInsideByteArray(PopPtr());
2425 StgInt r = do_cmp(x,y);
2426 PushTaggedInt(r<0 ? -1 : (r>0 ? 1 : 0));
2429 case i_negateInteger: OP_Z_Z(neg); break;
2430 case i_plusInteger: OP_ZZ_Z(add); break;
2431 case i_minusInteger: OP_ZZ_Z(sub); break;
2432 case i_timesInteger: OP_ZZ_Z(mul); break;
2433 case i_quotRemInteger:
2435 B* x = IntegerInsideByteArray(PopPtr());
2436 B* y = IntegerInsideByteArray(PopPtr());
2437 int n = size_qrm(x,y);
2438 StgPtr q = CreateByteArrayToHoldInteger(n);
2439 StgPtr r = CreateByteArrayToHoldInteger(n);
2440 if (do_getsign(y)==0)
2441 return (raiseDiv0("quotRemInteger"));
2442 do_qrm(x,y,n,IntegerInsideByteArray(q),
2443 IntegerInsideByteArray(r));
2444 SloppifyIntegerEnd(q);
2445 SloppifyIntegerEnd(r);
2450 case i_intToInteger:
2452 int n = size_fromInt();
2453 StgPtr p = CreateByteArrayToHoldInteger(n);
2454 do_fromInt( PopTaggedInt(), n, IntegerInsideByteArray(p));
2458 case i_wordToInteger:
2460 int n = size_fromWord();
2461 StgPtr p = CreateByteArrayToHoldInteger(n);
2462 do_fromWord( PopTaggedWord(), n, IntegerInsideByteArray(p));
2466 case i_integerToInt: PushTaggedInt(do_toInt(
2467 IntegerInsideByteArray(PopPtr())
2471 case i_integerToWord: PushTaggedWord(do_toWord(
2472 IntegerInsideByteArray(PopPtr())
2476 case i_integerToFloat: PushTaggedFloat(do_toFloat(
2477 IntegerInsideByteArray(PopPtr())
2481 case i_integerToDouble: PushTaggedDouble(do_toDouble(
2482 IntegerInsideByteArray(PopPtr())
2486 #error Non-standalone integer not yet implemented
2487 #endif /* STANDALONE_INTEGER */
2489 case i_gtFloat: OP_FF_B(x>y); break;
2490 case i_geFloat: OP_FF_B(x>=y); break;
2491 case i_eqFloat: OP_FF_B(x==y); break;
2492 case i_neFloat: OP_FF_B(x!=y); break;
2493 case i_ltFloat: OP_FF_B(x<y); break;
2494 case i_leFloat: OP_FF_B(x<=y); break;
2495 case i_minFloat: OP__F(FLT_MIN); break;
2496 case i_maxFloat: OP__F(FLT_MAX); break;
2497 case i_radixFloat: OP__I(FLT_RADIX); break;
2498 case i_digitsFloat: OP__I(FLT_MANT_DIG); break;
2499 case i_minExpFloat: OP__I(FLT_MIN_EXP); break;
2500 case i_maxExpFloat: OP__I(FLT_MAX_EXP); break;
2501 case i_plusFloat: OP_FF_F(x+y); break;
2502 case i_minusFloat: OP_FF_F(x-y); break;
2503 case i_timesFloat: OP_FF_F(x*y); break;
2506 StgFloat x = PopTaggedFloat();
2507 StgFloat y = PopTaggedFloat();
2508 PushTaggedFloat(x/y);
2511 case i_negateFloat: OP_F_F(-x); break;
2512 case i_floatToInt: OP_F_I(x); break;
2513 case i_intToFloat: OP_I_F(x); break;
2514 case i_expFloat: OP_F_F(exp(x)); break;
2515 case i_logFloat: OP_F_F(log(x)); break;
2516 case i_sqrtFloat: OP_F_F(sqrt(x)); break;
2517 case i_sinFloat: OP_F_F(sin(x)); break;
2518 case i_cosFloat: OP_F_F(cos(x)); break;
2519 case i_tanFloat: OP_F_F(tan(x)); break;
2520 case i_asinFloat: OP_F_F(asin(x)); break;
2521 case i_acosFloat: OP_F_F(acos(x)); break;
2522 case i_atanFloat: OP_F_F(atan(x)); break;
2523 case i_sinhFloat: OP_F_F(sinh(x)); break;
2524 case i_coshFloat: OP_F_F(cosh(x)); break;
2525 case i_tanhFloat: OP_F_F(tanh(x)); break;
2526 case i_powerFloat: OP_FF_F(pow(x,y)); break;
2528 #ifdef STANDALONE_INTEGER
2529 case i_encodeFloatZ:
2531 StgPtr sig = PopPtr();
2532 StgInt exp = PopTaggedInt();
2534 B__encodeFloat(IntegerInsideByteArray(sig), exp)
2538 case i_decodeFloatZ:
2540 StgFloat f = PopTaggedFloat();
2541 StgPtr sig = CreateByteArrayToHoldInteger(size_fltmantissa());
2543 B__decodeFloat(IntegerInsideByteArray(sig), &exp, f);
2549 #error encode/decodeFloatZ not yet implemented for GHC ints
2551 case i_isNaNFloat: OP_F_B(isFloatNaN(x)); break;
2552 case i_isInfiniteFloat: OP_F_B(isFloatInfinite(x)); break;
2553 case i_isNegativeZeroFloat: OP_F_B(isFloatNegativeZero(x)); break;
2554 case i_isDenormalizedFloat: OP_F_B(isFloatDenormalized(x)); break;
2555 case i_gtDouble: OP_DD_B(x>y); break;
2556 case i_geDouble: OP_DD_B(x>=y); break;
2557 case i_eqDouble: OP_DD_B(x==y); break;
2558 case i_neDouble: OP_DD_B(x!=y); break;
2559 case i_ltDouble: OP_DD_B(x<y); break;
2560 case i_leDouble: OP_DD_B(x<=y) break;
2561 case i_minDouble: OP__D(DBL_MIN); break;
2562 case i_maxDouble: OP__D(DBL_MAX); break;
2563 case i_radixDouble: OP__I(FLT_RADIX); break;
2564 case i_digitsDouble: OP__I(DBL_MANT_DIG); break;
2565 case i_minExpDouble: OP__I(DBL_MIN_EXP); break;
2566 case i_maxExpDouble: OP__I(DBL_MAX_EXP); break;
2567 case i_plusDouble: OP_DD_D(x+y); break;
2568 case i_minusDouble: OP_DD_D(x-y); break;
2569 case i_timesDouble: OP_DD_D(x*y); break;
2570 case i_divideDouble:
2572 StgDouble x = PopTaggedDouble();
2573 StgDouble y = PopTaggedDouble();
2574 PushTaggedDouble(x/y);
2577 case i_negateDouble: OP_D_D(-x); break;
2578 case i_doubleToInt: OP_D_I(x); break;
2579 case i_intToDouble: OP_I_D(x); break;
2580 case i_doubleToFloat: OP_D_F(x); break;
2581 case i_floatToDouble: OP_F_F(x); break;
2582 case i_expDouble: OP_D_D(exp(x)); break;
2583 case i_logDouble: OP_D_D(log(x)); break;
2584 case i_sqrtDouble: OP_D_D(sqrt(x)); break;
2585 case i_sinDouble: OP_D_D(sin(x)); break;
2586 case i_cosDouble: OP_D_D(cos(x)); break;
2587 case i_tanDouble: OP_D_D(tan(x)); break;
2588 case i_asinDouble: OP_D_D(asin(x)); break;
2589 case i_acosDouble: OP_D_D(acos(x)); break;
2590 case i_atanDouble: OP_D_D(atan(x)); break;
2591 case i_sinhDouble: OP_D_D(sinh(x)); break;
2592 case i_coshDouble: OP_D_D(cosh(x)); break;
2593 case i_tanhDouble: OP_D_D(tanh(x)); break;
2594 case i_powerDouble: OP_DD_D(pow(x,y)); break;
2596 #ifdef STANDALONE_INTEGER
2597 case i_encodeDoubleZ:
2599 StgPtr sig = PopPtr();
2600 StgInt exp = PopTaggedInt();
2602 B__encodeDouble(IntegerInsideByteArray(sig), exp)
2606 case i_decodeDoubleZ:
2608 StgDouble d = PopTaggedDouble();
2609 StgPtr sig = CreateByteArrayToHoldInteger(size_dblmantissa());
2611 B__decodeDouble(IntegerInsideByteArray(sig), &exp, d);
2617 #error encode/decodeDoubleZ not yet implemented for GHC ints
2619 case i_isNaNDouble: OP_D_B(isDoubleNaN(x)); break;
2620 case i_isInfiniteDouble: OP_D_B(isDoubleInfinite(x)); break;
2621 case i_isNegativeZeroDouble: OP_D_B(isDoubleNegativeZero(x)); break;
2622 case i_isDenormalizedDouble: OP_D_B(isDoubleDenormalized(x)); break;
2623 case i_isIEEEDouble:
2625 PushTaggedBool(rtsTrue);
2629 barf("Unrecognised primop1");
2636 /* For normal cases, return NULL and leave *return2 unchanged.
2637 To return the address of the next thing to enter,
2638 return the address of it and leave *return2 unchanged.
2639 To return a StgThreadReturnCode to the scheduler,
2640 set *return2 to it and return a non-NULL value.
2642 static void* enterBCO_primop2 ( int primop2code,
2643 int* /*StgThreadReturnCode* */ return2,
2647 switch (primop2code) {
2648 case i_raise: /* raise#{err} */
2650 StgClosure* err = PopCPtr();
2651 return (raiseAnError(err));
2656 StgClosure* init = PopCPtr();
2658 = stgCast(StgMutVar*,allocate(sizeofW(StgMutVar)));
2659 SET_HDR(mv,&MUT_VAR_info,CCCS);
2661 PushPtr(stgCast(StgPtr,mv));
2666 StgMutVar* mv = stgCast(StgMutVar*,PopPtr());
2672 StgMutVar* mv = stgCast(StgMutVar*,PopPtr());
2673 StgClosure* value = PopCPtr();
2679 nat n = PopTaggedInt(); /* or Word?? */
2680 StgClosure* init = PopCPtr();
2681 StgWord size = sizeofW(StgMutArrPtrs) + n;
2684 = stgCast(StgMutArrPtrs*,allocate(size));
2685 SET_HDR(arr,&MUT_ARR_PTRS_info,CCCS);
2687 for (i = 0; i < n; ++i) {
2688 arr->payload[i] = init;
2690 PushPtr(stgCast(StgPtr,arr));
2696 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2697 nat i = PopTaggedInt(); /* or Word?? */
2698 StgWord n = arr->ptrs;
2700 return (raiseIndex("{index,read}Array"));
2702 PushCPtr(arr->payload[i]);
2707 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2708 nat i = PopTaggedInt(); /* or Word? */
2709 StgClosure* v = PopCPtr();
2710 StgWord n = arr->ptrs;
2712 return (raiseIndex("{index,read}Array"));
2714 arr->payload[i] = v;
2718 case i_sizeMutableArray:
2720 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2721 PushTaggedInt(arr->ptrs);
2724 case i_unsafeFreezeArray:
2726 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2727 SET_INFO(arr,&MUT_ARR_PTRS_FROZEN_info);
2728 PushPtr(stgCast(StgPtr,arr));
2731 case i_unsafeFreezeByteArray:
2733 /* Delightfully simple :-) */
2737 case i_sameMutableArray:
2738 case i_sameMutableByteArray:
2740 StgPtr x = PopPtr();
2741 StgPtr y = PopPtr();
2742 PushTaggedBool(x==y);
2746 case i_newByteArray:
2748 nat n = PopTaggedInt(); /* or Word?? */
2749 StgInt words = (n+sizeof(W_)-1)/sizeof(W_);
2750 StgWord size = sizeofW(StgArrWords) + words;
2751 StgArrWords* arr = stgCast(StgArrWords*,allocate(size));
2752 SET_HDR(arr,&ARR_WORDS_info,CCCS);
2756 for (i = 0; i < n; ++i) {
2757 arr->payload[i] = 0xdeadbeef;
2760 PushPtr(stgCast(StgPtr,arr));
2764 /* Most of these generate alignment warnings on Sparcs and similar architectures.
2765 * These are harmless and are caused by the cast to C* in BYTE_ARR_CTS.
2767 case i_indexCharArray:
2768 OP_mI_ty(Char,"indexCharArray", indexCharArrayzh(r,x,i)); break;
2769 case i_readCharArray:
2770 OP_mI_ty(Char,"readCharArray", readCharArrayzh(r,x,i)); break;
2771 case i_writeCharArray:
2772 OP_mIty_(Char,"writeCharArray", writeCharArrayzh(x,i,z)); break;
2774 case i_indexIntArray:
2775 OP_mI_ty(Int,"indexIntArray", indexIntArrayzh(r,x,i)); break;
2776 case i_readIntArray:
2777 OP_mI_ty(Int,"readIntArray", readIntArrayzh(r,x,i)); break;
2778 case i_writeIntArray:
2779 OP_mIty_(Int,"writeIntArray", writeIntArrayzh(x,i,z)); break;
2781 case i_indexAddrArray:
2782 OP_mI_ty(Addr,"indexAddrArray", indexAddrArrayzh(r,x,i)); break;
2783 case i_readAddrArray:
2784 OP_mI_ty(Addr,"readAddrArray", readAddrArrayzh(r,x,i)); break;
2785 case i_writeAddrArray:
2786 OP_mIty_(Addr,"writeAddrArray", writeAddrArrayzh(x,i,z)); break;
2788 case i_indexFloatArray:
2789 OP_mI_ty(Float,"indexFloatArray", indexFloatArrayzh(r,x,i)); break;
2790 case i_readFloatArray:
2791 OP_mI_ty(Float,"readFloatArray", readFloatArrayzh(r,x,i)); break;
2792 case i_writeFloatArray:
2793 OP_mIty_(Float,"writeFloatArray", writeFloatArrayzh(x,i,z)); break;
2795 case i_indexDoubleArray:
2796 OP_mI_ty(Double,"indexDoubleArray", indexDoubleArrayzh(r,x,i)); break;
2797 case i_readDoubleArray:
2798 OP_mI_ty(Double,"readDoubleArray", readDoubleArrayzh(r,x,i)); break;
2799 case i_writeDoubleArray:
2800 OP_mIty_(Double,"writeDoubleArray", writeDoubleArrayzh(x,i,z)); break;
2803 #ifdef PROVIDE_STABLE
2804 case i_indexStableArray:
2805 OP_mI_ty(StablePtr,"indexStableArray", indexStablePtrArrayzh(r,x,i)); break;
2806 case i_readStableArray:
2807 OP_mI_ty(StablePtr,"readStableArray", readStablePtrArrayzh(r,x,i)); break;
2808 case i_writeStableArray:
2809 OP_mIty_(StablePtr,"writeStableArray", writeStablePtrArrayzh(x,i,z)); break;
2815 #ifdef PROVIDE_COERCE
2816 case i_unsafeCoerce:
2818 /* Another nullop */
2822 #ifdef PROVIDE_PTREQUALITY
2823 case i_reallyUnsafePtrEquality:
2824 { /* identical to i_sameRef */
2825 StgPtr x = PopPtr();
2826 StgPtr y = PopPtr();
2827 PushTaggedBool(x==y);
2831 #ifdef PROVIDE_FOREIGN
2832 /* ForeignObj# operations */
2833 case i_makeForeignObj:
2835 StgForeignObj *result
2836 = stgCast(StgForeignObj*,allocate(sizeofW(StgForeignObj)));
2837 SET_HDR(result,&FOREIGN_info,CCCS);
2838 result -> data = PopTaggedAddr();
2839 PushPtr(stgCast(StgPtr,result));
2842 #endif /* PROVIDE_FOREIGN */
2847 = stgCast(StgWeak*,allocate(sizeofW(StgWeak)));
2848 SET_HDR(w, &WEAK_info, CCCS);
2850 w->value = PopCPtr();
2851 w->finaliser = PopCPtr();
2852 w->link = weak_ptr_list;
2854 IF_DEBUG(weak, fprintf(stderr,"New weak pointer at %p\n",w));
2855 PushPtr(stgCast(StgPtr,w));
2860 StgWeak *w = stgCast(StgWeak*,PopPtr());
2861 if (w->header.info == &WEAK_info) {
2862 PushCPtr(w->value); /* last result */
2863 PushTaggedInt(1); /* first result */
2865 PushPtr(stgCast(StgPtr,w));
2866 /* ToDo: error thunk would be better */
2871 #endif /* PROVIDE_WEAK */
2873 case i_makeStablePtr:
2875 StgPtr p = PopPtr();
2876 StgStablePtr sp = getStablePtr ( p );
2877 PushTaggedStablePtr(sp);
2880 case i_deRefStablePtr:
2883 StgStablePtr sp = PopTaggedStablePtr();
2884 p = deRefStablePtr(sp);
2888 case i_freeStablePtr:
2890 StgStablePtr sp = PopTaggedStablePtr();
2895 case i_createAdjThunkARCH:
2897 StgStablePtr stableptr = PopTaggedStablePtr();
2898 StgAddr typestr = PopTaggedAddr();
2899 StgChar callconv = PopTaggedChar();
2900 StgAddr adj_thunk = createAdjThunk(stableptr,typestr,callconv);
2901 PushTaggedAddr(adj_thunk);
2907 StgInt n = prog_argc;
2913 StgInt n = PopTaggedInt();
2914 StgAddr a = (StgAddr)prog_argv[n];
2921 StgMVar *mvar = stgCast(StgMVar*,allocate(sizeofW(StgMVar)));
2922 SET_INFO(mvar,&EMPTY_MVAR_info);
2923 mvar->head = mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
2924 mvar->value = stgCast(StgClosure*,&END_TSO_QUEUE_closure);
2925 PushPtr(stgCast(StgPtr,mvar));
2930 StgMVar *mvar = (StgMVar*)PopCPtr();
2931 if (GET_INFO(mvar) == &EMPTY_MVAR_info) {
2933 /* The MVar is empty. Attach ourselves to the TSO's
2936 if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
2937 mvar->head = cap->rCurrentTSO;
2939 mvar->tail->link = cap->rCurrentTSO;
2941 cap->rCurrentTSO->link = (StgTSO *)&END_TSO_QUEUE_closure;
2942 cap->rCurrentTSO->why_blocked = BlockedOnMVar;
2943 cap->rCurrentTSO->block_info.closure = (StgClosure *)mvar;
2944 mvar->tail = cap->rCurrentTSO;
2946 /* At this point, the top-of-stack holds the MVar,
2947 and underneath is the world token (). So the
2948 stack is in the same state as when primTakeMVar
2949 was entered (primTakeMVar is handwritten bytecode).
2950 Push obj, which is this BCO, and return to the
2951 scheduler. When the MVar is filled, the scheduler
2952 will re-enter primTakeMVar, with the args still on
2953 the top of the stack.
2955 PushCPtr((StgClosure*)(*bco));
2956 *return2 = ThreadBlocked;
2957 return (void*)(1+(NULL));
2960 PushCPtr(mvar->value);
2961 mvar->value = (StgClosure *)&END_TSO_QUEUE_closure;
2962 SET_INFO(mvar,&EMPTY_MVAR_info);
2968 StgMVar* mvar = stgCast(StgMVar*,PopPtr());
2969 StgClosure* value = PopCPtr();
2970 if (GET_INFO(mvar) == &FULL_MVAR_info) {
2971 return (makeErrorCall("putMVar {full MVar}"));
2973 /* wake up the first thread on the
2974 * queue, it will continue with the
2975 * takeMVar operation and mark the
2978 mvar->value = value;
2980 if (mvar->head != (StgTSO *)&END_TSO_QUEUE_closure) {
2981 ASSERT(mvar->head->why_blocked == BlockedOnMVar);
2982 mvar->head = unblockOne(mvar->head);
2983 if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
2984 mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
2988 /* unlocks the MVar in the SMP case */
2989 SET_INFO(mvar,&FULL_MVAR_info);
2991 /* yield for better communication performance */
2997 { /* identical to i_sameRef */
2998 StgMVar* x = (StgMVar*)PopPtr();
2999 StgMVar* y = (StgMVar*)PopPtr();
3000 PushTaggedBool(x==y);
3005 StgWord tid = cap->rCurrentTSO->id;
3006 PushTaggedWord(tid);
3009 case i_cmpThreadIds:
3011 StgWord tid1 = PopTaggedWord();
3012 StgWord tid2 = PopTaggedWord();
3013 if (tid1 < tid2) PushTaggedInt(-1);
3014 else if (tid1 > tid2) PushTaggedInt(1);
3015 else PushTaggedInt(0);
3020 StgClosure* closure;
3023 closure = PopCPtr();
3024 tso = createGenThread (RtsFlags.GcFlags.initialStkSize,closure);
3026 scheduleThread(tso);
3028 PushTaggedWord(tid);
3032 #ifdef PROVIDE_CONCURRENT
3035 StgTSO* tso = stgCast(StgTSO*,PopPtr());
3037 if (tso == cap->rCurrentTSO) { /* suicide */
3038 *return2 = ThreadFinished;
3039 return (void*)(1+(NULL));
3046 ToDo: another way out of the problem might be to add an explicit
3047 continuation to primTakeMVar: takeMVar v = primTakeMVar v takeMVar.
3048 The problem with this plan is that now I dont know how much to chop
3055 /* As PrimOps.h says: Hmm, I'll think about these later. */
3058 #endif /* PROVIDE_CONCURRENT */
3060 case i_ccall_ccall_Id:
3061 case i_ccall_ccall_IO:
3062 case i_ccall_stdcall_Id:
3063 case i_ccall_stdcall_IO:
3066 CFunDescriptor* descriptor = PopTaggedAddr();
3067 void (*funPtr)(void) = PopTaggedAddr();
3068 char cc = (primop2code == i_ccall_stdcall_Id ||
3069 primop2code == i_ccall_stdcall_IO)
3071 r = ccall(descriptor,funPtr,bco,cc,cap);
3074 return makeErrorCall(
3075 "unhandled type or too many args/results in ccall");
3077 barf("ccall not configured correctly for this platform");
3078 barf("unknown return code from ccall");
3081 barf("Unrecognised primop2");
3087 /* -----------------------------------------------------------------------------
3088 * ccall support code:
3089 * marshall moves args from C stack to Haskell stack
3090 * unmarshall moves args from Haskell stack to C stack
3091 * argSize calculates how much gSpace you need on the C stack
3092 * ---------------------------------------------------------------------------*/
3094 /* Pop arguments off the C stack and Push them onto the Hugs stack.
3095 * Used when preparing for C calling Haskell or in regSponse to
3096 * Haskell calling C.
3098 nat marshall(char arg_ty, void* arg)
3102 PushTaggedInt(*((int*)arg));
3103 return ARG_SIZE(INT_TAG);
3104 #ifdef TODO_STANDALONE_INTEGER
3106 PushTaggedInteger(*((mpz_ptr*)arg));
3107 return ARG_SIZE(INTEGER_TAG);
3110 PushTaggedWord(*((unsigned int*)arg));
3111 return ARG_SIZE(WORD_TAG);
3113 PushTaggedChar(*((char*)arg));
3114 return ARG_SIZE(CHAR_TAG);
3116 PushTaggedFloat(*((float*)arg));
3117 return ARG_SIZE(FLOAT_TAG);
3119 PushTaggedDouble(*((double*)arg));
3120 return ARG_SIZE(DOUBLE_TAG);
3122 PushTaggedAddr(*((void**)arg));
3123 return ARG_SIZE(ADDR_TAG);
3125 PushTaggedStablePtr(*((StgStablePtr*)arg));
3126 return ARG_SIZE(STABLE_TAG);
3127 #ifdef PROVIDE_FOREIGN
3129 /* Not allowed in this direction - you have to
3130 * call makeForeignPtr explicitly
3132 barf("marshall: ForeignPtr#\n");
3137 /* Not allowed in this direction */
3138 barf("marshall: [Mutable]ByteArray#\n");
3141 barf("marshall: unrecognised arg type %d\n",arg_ty);
3146 /* Pop arguments off the Hugs stack and Push them onto the C stack.
3147 * Used when preparing for Haskell calling C or in regSponse to
3148 * C calling Haskell.
3150 nat unmarshall(char res_ty, void* res)
3154 *((int*)res) = PopTaggedInt();
3155 return ARG_SIZE(INT_TAG);
3156 #ifdef TODO_STANDALONE_INTEGER
3158 *((mpz_ptr*)res) = PopTaggedInteger();
3159 return ARG_SIZE(INTEGER_TAG);
3162 *((unsigned int*)res) = PopTaggedWord();
3163 return ARG_SIZE(WORD_TAG);
3165 *((int*)res) = PopTaggedChar();
3166 return ARG_SIZE(CHAR_TAG);
3168 *((float*)res) = PopTaggedFloat();
3169 return ARG_SIZE(FLOAT_TAG);
3171 *((double*)res) = PopTaggedDouble();
3172 return ARG_SIZE(DOUBLE_TAG);
3174 *((void**)res) = PopTaggedAddr();
3175 return ARG_SIZE(ADDR_TAG);
3177 *((StgStablePtr*)res) = PopTaggedStablePtr();
3178 return ARG_SIZE(STABLE_TAG);
3179 #ifdef PROVIDE_FOREIGN
3182 StgForeignObj *result = stgCast(StgForeignObj*,PopPtr());
3183 *((void**)res) = result->data;
3184 return sizeofW(StgPtr);
3190 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
3191 *((void**)res) = stgCast(void*,&(arr->payload));
3192 return sizeofW(StgPtr);
3195 barf("unmarshall: unrecognised result type %d\n",res_ty);
3199 nat argSize( const char* ks )
3202 for( ; *ks != '\0'; ++ks) {
3205 sz += sizeof(StgWord) * ARG_SIZE(INT_TAG);
3207 #ifdef TODO_STANDALONE_INTEGER
3209 sz += sizeof(StgWord) * ARG_SIZE(INTEGER_TAG);
3213 sz += sizeof(StgWord) * ARG_SIZE(WORD_TAG);
3216 sz += sizeof(StgWord) * ARG_SIZE(CHAR_TAG);
3219 sz += sizeof(StgWord) * ARG_SIZE(FLOAT_TAG);
3222 sz += sizeof(StgWord) * ARG_SIZE(DOUBLE_TAG);
3225 sz += sizeof(StgWord) * ARG_SIZE(ADDR_TAG);
3228 sz += sizeof(StgWord) * ARG_SIZE(STABLE_TAG);
3230 #ifdef PROVIDE_FOREIGN
3235 sz += sizeof(StgPtr);
3238 barf("argSize: unrecognised result type %d\n",*ks);
3246 /* -----------------------------------------------------------------------------
3247 * encode/decode Float/Double code for standalone Hugs
3248 * Code based on the HBC code (lib/fltcode.c) and more recently GHC
3249 * (ghc/rts/StgPrimFloat.c)
3250 * ---------------------------------------------------------------------------*/
3252 #ifdef STANDALONE_INTEGER
3254 #if IEEE_FLOATING_POINT
3255 #define MY_DMINEXP ((DBL_MIN_EXP) - (DBL_MANT_DIG) - 1)
3256 /* DMINEXP is defined in values.h on Linux (for example) */
3257 #define DHIGHBIT 0x00100000
3258 #define DMSBIT 0x80000000
3260 #define MY_FMINEXP ((FLT_MIN_EXP) - (FLT_MANT_DIG) - 1)
3261 #define FHIGHBIT 0x00800000
3262 #define FMSBIT 0x80000000
3264 #error The following code doesnt work in a non-IEEE FP environment
3267 #ifdef WORDS_BIGENDIAN
3276 StgDouble B__encodeDouble (B* s, I_ e) /* result = s * 2^e */
3281 /* Convert a B to a double; knows a lot about internal rep! */
3282 for(r = 0.0, i = s->used-1; i >= 0; i--)
3283 r = (r * B_BASE_FLT) + s->stuff[i];
3285 /* Now raise to the exponent */
3286 if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
3289 /* handle the sign */
3290 if (s->sign < 0) r = -r;
3297 #if ! FLOATS_AS_DOUBLES
3298 StgFloat B__encodeFloat (B* s, I_ e) /* result = s * 2^e */
3303 /* Convert a B to a float; knows a lot about internal rep! */
3304 for(r = 0.0, i = s->used-1; i >= 0; i--)
3305 r = (r * B_BASE_FLT) + s->stuff[i];
3307 /* Now raise to the exponent */
3308 if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
3311 /* handle the sign */
3312 if (s->sign < 0) r = -r;
3316 #endif /* FLOATS_AS_DOUBLES */
3320 /* This only supports IEEE floating point */
3321 void B__decodeDouble (B* man, I_* exp, StgDouble dbl)
3323 /* Do some bit fiddling on IEEE */
3324 nat low, high; /* assuming 32 bit ints */
3326 union { double d; int i[2]; } u; /* assuming 32 bit ints, 64 bit double */
3328 u.d = dbl; /* grab chunks of the double */
3332 ASSERT(B_BASE == 256);
3334 /* Assume that the supplied B is the right size */
3337 if (low == 0 && (high & ~DMSBIT) == 0) {
3338 man->sign = man->used = 0;
3343 iexp = ((high >> 20) & 0x7ff) + MY_DMINEXP;
3347 if (iexp != MY_DMINEXP) /* don't add hidden bit to denorms */
3351 /* A denorm, normalize the mantissa */
3352 while (! (high & DHIGHBIT)) {
3362 man->stuff[7] = (((W_)high) >> 24) & 0xff;
3363 man->stuff[6] = (((W_)high) >> 16) & 0xff;
3364 man->stuff[5] = (((W_)high) >> 8) & 0xff;
3365 man->stuff[4] = (((W_)high) ) & 0xff;
3367 man->stuff[3] = (((W_)low) >> 24) & 0xff;
3368 man->stuff[2] = (((W_)low) >> 16) & 0xff;
3369 man->stuff[1] = (((W_)low) >> 8) & 0xff;
3370 man->stuff[0] = (((W_)low) ) & 0xff;
3372 if (sign < 0) man->sign = -1;
3374 do_renormalise(man);
3378 #if ! FLOATS_AS_DOUBLES
3379 void B__decodeFloat (B* man, I_* exp, StgFloat flt)
3381 /* Do some bit fiddling on IEEE */
3382 int high, sign; /* assuming 32 bit ints */
3383 union { float f; int i; } u; /* assuming 32 bit float and int */
3385 u.f = flt; /* grab the float */
3388 ASSERT(B_BASE == 256);
3390 /* Assume that the supplied B is the right size */
3393 if ((high & ~FMSBIT) == 0) {
3394 man->sign = man->used = 0;
3399 *exp = ((high >> 23) & 0xff) + MY_FMINEXP;
3403 if (*exp != MY_FMINEXP) /* don't add hidden bit to denorms */
3407 /* A denorm, normalize the mantissa */
3408 while (! (high & FHIGHBIT)) {
3413 man->stuff[3] = (((W_)high) >> 24) & 0xff;
3414 man->stuff[2] = (((W_)high) >> 16) & 0xff;
3415 man->stuff[1] = (((W_)high) >> 8) & 0xff;
3416 man->stuff[0] = (((W_)high) ) & 0xff;
3418 if (sign < 0) man->sign = -1;
3420 do_renormalise(man);
3423 #endif /* FLOATS_AS_DOUBLES */
3425 #endif /* STANDALONE_INTEGER */
3427 #endif /* INTERPRETER */