2 /* -----------------------------------------------------------------------------
5 * Copyright (c) 1994-1998.
7 * $RCSfile: Evaluator.c,v $
9 * $Date: 1999/11/01 18:19:41 $
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;
258 /* --------------------------------------------------------------------------
261 * ToDo: figure out why these are being used and crush them!
262 * ------------------------------------------------------------------------*/
264 void OnExitHook (void)
267 void StackOverflowHook (unsigned long stack_size)
269 fprintf(stderr,"Stack Overflow\n");
272 void OutOfHeapHook (unsigned long request_size, unsigned long heap_size)
274 fprintf(stderr,"Out Of Heap\n");
277 void MallocFailHook (unsigned long request_size /* in bytes */, char *msg)
279 fprintf(stderr,"Malloc Fail\n");
282 void defaultsHook (void)
288 /* --------------------------------------------------------------------------
289 * Entering-objects and bytecode interpreter part of evaluator
290 * ------------------------------------------------------------------------*/
292 /* The primop (and all other) parts of this evaluator operate upon the
293 machine state which lives in MainRegTable. enter is different:
294 to make its closure- and bytecode-interpreting loops go fast, some of that
295 state is pulled out into local vars (viz, registers, if we are lucky).
296 That means that we need to save(load) the local state at every exit(reentry)
297 into enter. That is, around every procedure call it makes. Blargh!
298 If you modify this code, __be warned__ it will fail in mysterious ways if
299 you fail to preserve this property.
301 Currently the pulled-out state is Sp in xSp, Su in xSu and SpLim in xSpLim.
302 The SSS macros saves the state back in MainRegTable, and LLL loads it from
303 MainRegTable. RETURN(v) does SSS and then returns v; all exits should
304 be via RETURN and not plain return.
306 Since xSp, xSu and xSpLim are local vars in enter, they are not visible
307 in procedures called from enter. To fix this, either (1) turn the
308 procedures into macros, so they get copied inline, or (2) bracket
309 the procedure call with SSS and LLL so that the local and global
310 machine states are synchronised for the duration of the call.
314 /* Forward decls ... */
315 static void* enterBCO_primop1 ( int );
316 static void* enterBCO_primop2 ( int , int* /*StgThreadReturnCode* */, StgBCO** );
317 static inline void PopUpdateFrame ( StgClosure* obj );
318 static inline void PopCatchFrame ( void );
319 static inline void PopSeqFrame ( void );
320 static inline void PopStopFrame( StgClosure* obj );
321 static inline void PushTaggedRealWorld( void );
322 static inline void PushTaggedInteger ( mpz_ptr );
323 static inline StgPtr grabHpUpd( nat size );
324 static inline StgPtr grabHpNonUpd( nat size );
325 static StgClosure* raiseAnError ( StgClosure* errObj );
327 static int enterCountI = 0;
329 #ifdef STANDALONE_INTEGER
330 StgDouble B__encodeDouble (B* s, I_ e);
331 void B__decodeDouble (B* man, I_* exp, StgDouble dbl);
332 #if ! FLOATS_AS_DOUBLES
333 StgFloat B__encodeFloat (B* s, I_ e);
334 void B__decodeFloat (B* man, I_* exp, StgFloat flt);
335 StgPtr CreateByteArrayToHoldInteger ( int );
336 B* IntegerInsideByteArray ( StgPtr );
337 void SloppifyIntegerEnd ( StgPtr );
344 /* Macros to save/load local state. */
346 #define SSS { tSp=Sp = xSp; tSu=Su = xSu; tSpLim=SpLim = xSpLim; }
347 #define LLL { tSp=xSp = Sp; tSu=xSu = Su; tSpLim=xSpLim = SpLim; }
349 #define SSS { Sp = xSp; Su = xSu; SpLim = xSpLim; }
350 #define LLL { xSp = Sp; xSu = Su; xSpLim = SpLim; }
353 #define RETURN(vvv) { \
354 StgThreadReturnCode retVal=(vvv); SSS; \
355 /* SaveThreadState() is done by the scheduler. */ \
360 /* Macros to operate directly on the pulled-out machine state.
361 These mirror some of the small procedures used in the primop code
362 below, except you have to be careful about side effects,
363 ie xPushPtr(xStackPtr(n)) won't work! It certainly isn't the
364 same as PushPtr(StackPtr(n)). Also note that (1) some of
365 the macros, in particular xPopTagged*, do not make the tag
366 sanity checks that their non-x cousins do, and (2) some of
367 the macros depend critically on the semantics of C comma
368 expressions to work properly
370 #define xPushPtr(ppp) { xSp--; *xSp=(StgWord)(ppp); }
371 #define xPopPtr() ((StgPtr)(*xSp++))
373 #define xPushCPtr(ppp) { xSp--; *xSp=(StgWord)(ppp); }
374 #define xPopCPtr() ((StgClosure*)(*xSp++))
376 #define xPushWord(ppp) { xSp--; *xSp=(StgWord)(ppp); }
377 #define xPopWord() ((StgWord)(*xSp++))
379 #define xStackPtr(nnn) ((StgPtr)(*(xSp+(nnn))))
380 #define xStackWord(nnn) ((StgWord)(*(xSp+(nnn))))
381 #define xSetStackWord(iii,www) xSp[iii]=(StgWord)(www)
383 #define xPushTag(ttt) { xSp--; *xSp=(StgWord)(ttt); }
384 #define xPopTag(ttt) { StackTag t = (StackTag)(*xSp++); \
387 #define xPushTaggedInt(xxx) { xSp -= sizeofW(StgInt); \
388 *xSp = (xxx); xPushTag(INT_TAG); }
389 #define xTaggedStackInt(iii) ((StgInt)(*(xSp+1+(iii))))
390 #define xPopTaggedInt() ((xSp++,xSp+=sizeofW(StgInt), \
391 (StgInt)(*(xSp-sizeofW(StgInt)))))
393 #define xPushTaggedWord(xxx) { xSp -= sizeofW(StgWord); \
394 *xSp = (xxx); xPushTag(WORD_TAG); }
395 #define xTaggedStackWord(iii) ((StgWord)(*(xSp+1+(iii))))
396 #define xPopTaggedWord() ((xSp++,xSp+=sizeofW(StgWord), \
397 (StgWord)(*(xSp-sizeofW(StgWord)))))
399 #define xPushTaggedAddr(xxx) { xSp -= sizeofW(StgAddr); \
400 *xSp = (StgWord)(xxx); xPushTag(ADDR_TAG); }
401 #define xTaggedStackAddr(iii) ((StgAddr)(*(xSp+1+(iii))))
402 #define xPopTaggedAddr() ((xSp++,xSp+=sizeofW(StgAddr), \
403 (StgAddr)(*(xSp-sizeofW(StgAddr)))))
405 #define xPushTaggedStable(xxx) { xSp -= sizeofW(StgStablePtr); \
406 *xSp = (StgWord)(xxx); xPushTag(STABLE_TAG); }
407 #define xTaggedStackStable(iii) ((StgStablePtr)(*(xSp+1+(iii))))
408 #define xPopTaggedStable() ((xSp++,xSp+=sizeofW(StgStablePtr), \
409 (StgStablePtr)(*(xSp-sizeofW(StgStablePtr)))))
411 #define xPushTaggedChar(xxx) { xSp -= sizeofW(StgChar); \
412 *xSp = (StgWord)(xxx); xPushTag(CHAR_TAG); }
413 #define xTaggedStackChar(iii) ((StgChar)(*(xSp+1+(iii))))
414 #define xPopTaggedChar() ((xSp++,xSp+=sizeofW(StgChar), \
415 (StgChar)(*(xSp-sizeofW(StgChar)))))
417 #define xPushTaggedFloat(xxx) { xSp -= sizeofW(StgFloat); \
418 ASSIGN_FLT(xSp,xxx); xPushTag(FLOAT_TAG); }
419 #define xTaggedStackFloat(iii) PK_FLT(xSp+1+(iii))
420 #define xPopTaggedFloat() ((xSp++,xSp+=sizeofW(StgFloat), \
421 PK_FLT(xSp-sizeofW(StgFloat))))
423 #define xPushTaggedDouble(xxx) { xSp -= sizeofW(StgDouble); \
424 ASSIGN_DBL(xSp,xxx); xPushTag(DOUBLE_TAG); }
425 #define xTaggedStackDouble(iii) PK_DBL(xSp+1+(iii))
426 #define xPopTaggedDouble() ((xSp++,xSp+=sizeofW(StgDouble), \
427 PK_DBL(xSp-sizeofW(StgDouble))))
430 #define xPopUpdateFrame(ooo) \
432 /* NB: doesn't assume that Sp == Su */ \
433 IF_DEBUG(evaluator, \
434 fprintf(stderr, "Updating "); \
435 printPtr(stgCast(StgPtr,xSu->updatee)); \
436 fprintf(stderr, " with "); \
438 fprintf(stderr,"xSp = %p\txSu = %p\n\n", xSp, xSu); \
440 UPD_IND(xSu->updatee,ooo); \
441 xSp = stgCast(StgStackPtr,xSu) + sizeofW(StgUpdateFrame); \
447 /* Instruction stream macros */
448 #define BCO_INSTR_8 *bciPtr++
449 #define BCO_INSTR_16 ((bciPtr += 2, (*(bciPtr-2) << 8) + *(bciPtr-1)))
450 #define PC (bciPtr - &(bcoInstr(bco,0)))
453 StgThreadReturnCode enter( StgClosure* obj0 )
455 /* use of register here is primarily to make it clear to compilers
456 that these entities are non-aliasable.
458 register StgPtr xSp; /* local state -- stack pointer */
459 register StgUpdateFrame* xSu; /* local state -- frame pointer */
460 register StgPtr xSpLim; /* local state -- stack lim pointer */
461 register StgClosure* obj; /* object currently under evaluation */
462 char eCount; /* enter counter, for context switching */
465 /* use the t values to check that Su/Sp/SpLim do not change unexpectedly */
466 StgPtr tSp; StgUpdateFrame* tSu; StgPtr tSpLim;
468 /* LoadThreadState() is done by the scheduler. */
470 tSp = Sp; tSu = Su; tSpLim = SpLim;
476 /* Load the local state from global state, and Party On, Dudes! */
477 /* From here onwards, we operate with the local state and
478 save/reload it as necessary.
487 assert(SpLim == tSpLim);
491 ASSERT(xSpLim <= xSp && xSp <= stgCast(StgPtr,xSu));
493 "\n---------------------------------------------------------------\n");
494 fprintf(stderr,"(%d) Entering: ",enterCountI); printObj(obj);
495 fprintf(stderr,"xSp = %p\txSu = %p\n", xSp, xSu);
496 fprintf(stderr, "\n" );
497 printStack(xSp,CurrentTSO->stack+CurrentTSO->stack_size,xSu);
498 fprintf(stderr, "\n\n");
508 if (context_switch) {
509 xPushCPtr(obj); /* code to restart with */
510 RETURN(ThreadYielding);
514 switch ( get_itbl(obj)->type ) {
516 barf("Invalid object %p",obj);
520 /* ---------------------------------------------------- */
521 /* Start of the bytecode evaluator */
522 /* ---------------------------------------------------- */
525 # define Ins(x) &&l##x
526 static void *labs[] = { INSTRLIST };
528 # define LoopTopLabel
529 # define Case(x) l##x
530 # define Continue goto *labs[BCO_INSTR_8]
531 # define Dispatch Continue;
534 # define LoopTopLabel insnloop:
535 # define Case(x) case x
536 # define Continue goto insnloop
537 # define Dispatch switch (BCO_INSTR_8) {
538 # define EndDispatch }
541 register StgWord8* bciPtr; /* instruction pointer */
542 register StgBCO* bco = (StgBCO*)obj;
545 /* Don't need to SSS ... LLL around doYouWantToGC */
546 wantToGC = doYouWantToGC();
548 xPushCPtr((StgClosure*)bco); /* code to restart with */
549 RETURN(HeapOverflow);
557 bciPtr = &(bcoInstr(bco,0));
561 ASSERT(PC < bco->n_instrs);
563 fprintf(stderr,"Sp = %p\tSu = %p\tpc = %d\t", xSp, xSu, PC);
567 fprintf(stderr,"\n");
568 for (i = 8; i >= 0; i--)
569 fprintf(stderr, "%d %p\n", i, (StgPtr)(*(Sp+i)));
571 fprintf(stderr,"\n");
576 SSS; cp_bill_insns(1); LLL;
581 Case(i_INTERNAL_ERROR):
582 barf("INTERNAL_ERROR at %p:%d",bco,PC-1);
584 barf("PANIC at %p:%d",bco,PC-1);
588 if (xSp - n < xSpLim) {
589 xPushCPtr((StgClosure*)bco); /* code to restart with */
590 RETURN(StackOverflow);
594 Case(i_STK_CHECK_big):
596 int n = BCO_INSTR_16;
597 if (xSp - n < xSpLim) {
598 xPushCPtr((StgClosure*)bco); /* code to restart with */
599 RETURN(StackOverflow);
606 if ((StgPtr*)(xSp + n) > (StgPtr*)xSu) {
607 StgWord words = (P_)xSu - xSp;
609 /* first build a PAP */
610 ASSERT((P_)xSu >= xSp); /* was (words >= 0) but that's always true */
611 if (words == 0) { /* optimisation */
612 /* Skip building the PAP and update with an indirection. */
615 /* In the evaluator, we avoid the need to do
616 * a heap check here by including the size of
617 * the PAP in the heap check we performed
618 * when we entered the BCO.
622 SSS; pap = (StgPAP*)grabHpNonUpd(PAP_sizeW(words)); LLL;
623 SET_HDR(pap,&PAP_info,CC_pap);
626 for (i = 0; i < (I_)words; ++i) {
627 payloadWord(pap,i) = xSp[i];
630 obj = stgCast(StgClosure*,pap);
633 /* now deal with "update frame" */
634 /* as an optimisation, we process all on top of stack */
635 /* instead of just the top one */
636 ASSERT(xSp==(P_)xSu);
638 switch (get_itbl(xSu)->type) {
640 /* Hit a catch frame during an arg satisfaction check,
641 * so the thing returning (1) has not thrown an
642 * exception, and (2) is of functional type. Just
643 * zap the catch frame and carry on down the stack
644 * (looking for more arguments, basically).
646 SSS; PopCatchFrame(); LLL;
649 xPopUpdateFrame(obj);
652 SSS; PopStopFrame(obj); LLL;
653 RETURN(ThreadFinished);
655 SSS; PopSeqFrame(); LLL;
656 ASSERT(xSp != (P_)xSu);
657 /* Hit a SEQ frame during an arg satisfaction check.
658 * So now return to bco_info which is under the
659 * SEQ frame. The following code is copied from a
660 * case RET_BCO further down. (The reason why we're
661 * here is that something of functional type has
662 * been seq-d on, and we're now returning to the
663 * algebraic-case-continuation which forced the
664 * evaluation in the first place.)
676 barf("Invalid update frame during argcheck");
678 } while (xSp==(P_)xSu);
686 int words = BCO_INSTR_8;
687 SSS; p = grabHpUpd(AP_sizeW(words)); LLL;
691 Case(i_ALLOC_CONSTR):
694 StgInfoTable* info = bcoConstAddr(bco,BCO_INSTR_8);
695 SSS; p = grabHpNonUpd(sizeW_fromITBL(info)); LLL;
696 SET_HDR((StgClosure*)p,info,??);
702 int x = BCO_INSTR_8; /* ToDo: Word not Int! */
704 StgAP_UPD* o = stgCast(StgAP_UPD*,xStackPtr(x));
705 SET_HDR(o,&AP_UPD_info,??);
707 o->fun = stgCast(StgClosure*,xPopPtr());
708 for(x=0; x < y; ++x) {
709 payloadWord(o,x) = xPopWord();
712 fprintf(stderr,"\tBuilt ");
714 printObj(stgCast(StgClosure*,o));
725 o = stgCast(StgAP_UPD*,xStackPtr(x));
726 SET_HDR(o,&AP_UPD_info,??);
728 o->fun = stgCast(StgClosure*,xPopPtr());
729 for(x=0; x < y; ++x) {
730 payloadWord(o,x) = xPopWord();
733 fprintf(stderr,"\tBuilt ");
735 printObj(stgCast(StgClosure*,o));
744 StgPAP* o = stgCast(StgPAP*,xStackPtr(x));
745 SET_HDR(o,&PAP_info,??);
747 o->fun = stgCast(StgClosure*,xPopPtr());
748 for(x=0; x < y; ++x) {
749 payloadWord(o,x) = xPopWord();
752 fprintf(stderr,"\tBuilt ");
754 printObj(stgCast(StgClosure*,o));
761 int offset = BCO_INSTR_8;
762 StgClosure* o = stgCast(StgClosure*,xStackPtr(offset));
763 const StgInfoTable* info = get_itbl(o);
764 nat p = info->layout.payload.ptrs;
765 nat np = info->layout.payload.nptrs;
767 for(i=0; i < p; ++i) {
768 payloadCPtr(o,i) = xPopCPtr();
770 for(i=0; i < np; ++i) {
771 payloadWord(o,p+i) = 0xdeadbeef;
774 fprintf(stderr,"\tBuilt ");
776 printObj(stgCast(StgClosure*,o));
783 int offset = BCO_INSTR_16;
784 StgClosure* o = stgCast(StgClosure*,xStackPtr(offset));
785 const StgInfoTable* info = get_itbl(o);
786 nat p = info->layout.payload.ptrs;
787 nat np = info->layout.payload.nptrs;
789 for(i=0; i < p; ++i) {
790 payloadCPtr(o,i) = xPopCPtr();
792 for(i=0; i < np; ++i) {
793 payloadWord(o,p+i) = 0xdeadbeef;
796 fprintf(stderr,"\tBuilt ");
798 printObj(stgCast(StgClosure*,o));
807 ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
808 /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
810 xSetStackWord(x+y,xStackWord(x));
820 ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
821 /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
823 xSetStackWord(x+y,xStackWord(x));
835 xPushPtr(bcoConstPtr(bco,BCO_INSTR_8));
836 xPushPtr(stgCast(StgPtr,&ret_bco_info));
841 int tag = BCO_INSTR_8;
842 StgWord offset = BCO_INSTR_16;
843 if (constrTag(stgCast(StgClosure*,xStackPtr(0))) != tag) {
850 StgClosure* o = stgCast(StgClosure*,xStackPtr(0));
851 const StgInfoTable* itbl = get_itbl(o);
852 int i = itbl->layout.payload.ptrs;
853 ASSERT( itbl->type == CONSTR
854 || itbl->type == CONSTR_STATIC
855 || itbl->type == CONSTR_NOCAF_STATIC
856 || itbl->type == CONSTR_1_0
857 || itbl->type == CONSTR_0_1
858 || itbl->type == CONSTR_2_0
859 || itbl->type == CONSTR_1_1
860 || itbl->type == CONSTR_0_2
863 xPushCPtr(payloadCPtr(o,i));
869 int n = BCO_INSTR_16;
870 StgPtr p = xStackPtr(n);
876 StgPtr p = xStackPtr(BCO_INSTR_8);
882 xPushPtr(stgCast(StgPtr,bcoConstPtr(bco,BCO_INSTR_8)));
887 int n = BCO_INSTR_16;
888 xPushPtr(stgCast(StgPtr,bcoConstPtr(bco,n)));
893 SSS; PushTaggedRealWorld(); LLL;
898 StgInt i = xTaggedStackInt(BCO_INSTR_8);
904 xPushTaggedInt(bcoConstInt(bco,BCO_INSTR_8));
910 SSS; o = (StgClosure*)grabHpNonUpd(Izh_sizeW); LLL;
911 SET_HDR(o,&Izh_con_info,??);
912 payloadWord(o,0) = xPopTaggedInt();
914 fprintf(stderr,"\tBuilt ");
916 printObj(stgCast(StgClosure*,o));
919 xPushPtr(stgCast(StgPtr,o));
924 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
925 /* ASSERT(isIntLike(con)); */
926 xPushTaggedInt(payloadWord(con,0));
931 StgWord offset = BCO_INSTR_16;
932 StgInt x = xPopTaggedInt();
933 StgInt y = xPopTaggedInt();
939 Case(i_CONST_INTEGER):
943 char* s = bcoConstAddr(bco,BCO_INSTR_8);
946 p = CreateByteArrayToHoldInteger(n);
947 do_fromStr ( s, n, IntegerInsideByteArray(p));
948 SloppifyIntegerEnd(p);
955 StgWord w = xTaggedStackWord(BCO_INSTR_8);
961 xPushTaggedWord(bcoConstWord(bco,BCO_INSTR_8));
967 SSS; o = (StgClosure*)grabHpNonUpd(Wzh_sizeW); LLL;
968 SET_HDR(o,&Wzh_con_info,??);
969 payloadWord(o,0) = xPopTaggedWord();
971 fprintf(stderr,"\tBuilt ");
973 printObj(stgCast(StgClosure*,o));
976 xPushPtr(stgCast(StgPtr,o));
981 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
982 /* ASSERT(isWordLike(con)); */
983 xPushTaggedWord(payloadWord(con,0));
988 StgAddr a = xTaggedStackAddr(BCO_INSTR_8);
994 xPushTaggedAddr(bcoConstAddr(bco,BCO_INSTR_8));
1000 SSS; o = (StgClosure*)grabHpNonUpd(Azh_sizeW); LLL;
1001 SET_HDR(o,&Azh_con_info,??);
1002 payloadPtr(o,0) = xPopTaggedAddr();
1004 fprintf(stderr,"\tBuilt ");
1006 printObj(stgCast(StgClosure*,o));
1009 xPushPtr(stgCast(StgPtr,o));
1012 Case(i_UNPACK_ADDR):
1014 StgClosure* con = (StgClosure*)xStackPtr(0);
1015 /* ASSERT(isAddrLike(con)); */
1016 xPushTaggedAddr(payloadPtr(con,0));
1021 StgChar c = xTaggedStackChar(BCO_INSTR_8);
1027 xPushTaggedChar(bcoConstChar(bco,BCO_INSTR_8));
1033 SSS; o = (StgClosure*)grabHpNonUpd(Czh_sizeW); LLL;
1034 SET_HDR(o,&Czh_con_info,??);
1035 payloadWord(o,0) = xPopTaggedChar();
1036 xPushPtr(stgCast(StgPtr,o));
1038 fprintf(stderr,"\tBuilt ");
1040 printObj(stgCast(StgClosure*,o));
1045 Case(i_UNPACK_CHAR):
1047 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1048 /* ASSERT(isCharLike(con)); */
1049 xPushTaggedChar(payloadWord(con,0));
1054 StgFloat f = xTaggedStackFloat(BCO_INSTR_8);
1055 xPushTaggedFloat(f);
1058 Case(i_CONST_FLOAT):
1060 xPushTaggedFloat(bcoConstFloat(bco,BCO_INSTR_8));
1066 SSS; o = (StgClosure*)grabHpNonUpd(Fzh_sizeW); LLL;
1067 SET_HDR(o,&Fzh_con_info,??);
1068 ASSIGN_FLT(&payloadWord(o,0),xPopTaggedFloat());
1070 fprintf(stderr,"\tBuilt ");
1072 printObj(stgCast(StgClosure*,o));
1075 xPushPtr(stgCast(StgPtr,o));
1078 Case(i_UNPACK_FLOAT):
1080 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1081 /* ASSERT(isFloatLike(con)); */
1082 xPushTaggedFloat(PK_FLT(&payloadWord(con,0)));
1087 StgDouble d = xTaggedStackDouble(BCO_INSTR_8);
1088 xPushTaggedDouble(d);
1091 Case(i_CONST_DOUBLE):
1093 xPushTaggedDouble(bcoConstDouble(bco,BCO_INSTR_8));
1096 Case(i_CONST_DOUBLE_big):
1098 int n = BCO_INSTR_16;
1099 xPushTaggedDouble(bcoConstDouble(bco,n));
1102 Case(i_PACK_DOUBLE):
1105 SSS; o = (StgClosure*)grabHpNonUpd(Dzh_sizeW); LLL;
1106 SET_HDR(o,&Dzh_con_info,??);
1107 ASSIGN_DBL(&payloadWord(o,0),xPopTaggedDouble());
1109 fprintf(stderr,"\tBuilt ");
1110 printObj(stgCast(StgClosure*,o));
1112 xPushPtr(stgCast(StgPtr,o));
1115 Case(i_UNPACK_DOUBLE):
1117 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1118 /* ASSERT(isDoubleLike(con)); */
1119 xPushTaggedDouble(PK_DBL(&payloadWord(con,0)));
1124 StgStablePtr s = xTaggedStackStable(BCO_INSTR_8);
1125 xPushTaggedStable(s);
1128 Case(i_PACK_STABLE):
1131 SSS; o = (StgClosure*)grabHpNonUpd(Stablezh_sizeW); LLL;
1132 SET_HDR(o,&StablePtr_con_info,??);
1133 payloadWord(o,0) = xPopTaggedStable();
1135 fprintf(stderr,"\tBuilt ");
1137 printObj(stgCast(StgClosure*,o));
1140 xPushPtr(stgCast(StgPtr,o));
1143 Case(i_UNPACK_STABLE):
1145 StgClosure* con = (StgClosure*)xStackPtr(0);
1146 /* ASSERT(isStableLike(con)); */
1147 xPushTaggedStable(payloadWord(con,0));
1155 SSS; p = enterBCO_primop1 ( i ); LLL;
1156 if (p) { obj = p; goto enterLoop; };
1161 /* Remember to save */
1162 int i, trc, pc_saved;
1165 trc = 12345678; /* Assume != any StgThreadReturnCode */
1170 p = enterBCO_primop2 ( i, &trc, &bco_tmp );
1173 bciPtr = &(bcoInstr(bco,pc_saved));
1175 if (trc == 12345678) {
1176 /* we want to enter p */
1177 obj = p; goto enterLoop;
1179 /* p is the the StgThreadReturnCode for this thread */
1180 RETURN((StgThreadReturnCode)p);
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_CONST_INTEGER_big):
1264 Case(i_CONST_INT_big):
1265 Case(i_VAR_INT_big):
1266 Case(i_VAR_WORD_big):
1267 Case(i_RETADDR_big):
1271 disInstr ( bco, PC );
1272 barf("\nUnrecognised instruction");
1276 barf("enterBCO: ran off end of loop");
1280 # undef LoopTopLabel
1286 /* ---------------------------------------------------- */
1287 /* End of the bytecode evaluator */
1288 /* ---------------------------------------------------- */
1292 StgBlockingQueue* bh;
1293 StgCAF* caf = (StgCAF*)obj;
1294 if (xSp - sizeofW(StgUpdateFrame) < xSpLim) {
1295 xPushCPtr(obj); /* code to restart with */
1296 RETURN(StackOverflow);
1298 /* ToDo: look for xSp==xSu && stackInt(0) == UPD_FRAME
1299 and insert an indirection immediately */
1300 SSS; bh = (StgBlockingQueue*)grabHpUpd(BLACKHOLE_sizeW()); LLL;
1301 SET_INFO(bh,&CAF_BLACKHOLE_info);
1302 bh->blocking_queue = EndTSOQueue;
1304 fprintf(stderr,"Created CAF_BLACKHOLE %p for CAF %p in evaluator\n",bh,caf));
1305 SET_INFO(caf,&CAF_ENTERED_info);
1306 caf->value = (StgClosure*)bh;
1307 if (caf->mut_link == NULL) {
1308 SSS; recordOldToNewPtrs((StgMutClosure*)caf); LLL;
1310 SSS; PUSH_UPD_FRAME(bh,0); LLL;
1311 xSp -= sizeofW(StgUpdateFrame);
1312 caf->link = enteredCAFs;
1319 StgCAF* caf = (StgCAF*)obj;
1320 obj = caf->value; /* it's just a fancy indirection */
1326 case SE_CAF_BLACKHOLE:
1328 /*was StgBlackHole* */
1329 StgBlockingQueue* bh = (StgBlockingQueue*)obj;
1330 /* Put ourselves on the blocking queue for this black hole and block */
1331 CurrentTSO->link = bh->blocking_queue;
1332 bh->blocking_queue = CurrentTSO;
1333 xPushCPtr(obj); /* code to restart with */
1334 barf("enter: CAF_BLACKHOLE unexpected!");
1335 RETURN(ThreadBlocked);
1339 StgAP_UPD* ap = stgCast(StgAP_UPD*,obj);
1341 if (xSp - (i + sizeofW(StgUpdateFrame)) < xSpLim) {
1342 xPushCPtr(obj); /* code to restart with */
1343 RETURN(StackOverflow);
1345 /* ToDo: look for xSp==xSu && stackInt(0) == UPD_FRAME
1346 and insert an indirection immediately */
1347 SSS; PUSH_UPD_FRAME(ap,0); LLL;
1348 xSp -= sizeofW(StgUpdateFrame);
1350 xPushWord(payloadWord(ap,i));
1353 #ifdef EAGER_BLACKHOLING
1354 #warn LAZY_BLACKHOLING is default for StgHugs
1355 #error Dont know if EAGER_BLACKHOLING works in StgHugs
1357 /* superfluous - but makes debugging easier */
1358 StgBlackHole* bh = stgCast(StgBlackHole*,ap);
1359 SET_INFO(bh,&BLACKHOLE_info);
1360 bh->blocking_queue = EndTSOQueue;
1362 fprintf(stderr,"Eagerly blackholed AP_UPD %p in evaluator\n",bh));
1365 #endif /* EAGER_BLACKHOLING */
1370 StgPAP* pap = stgCast(StgPAP*,obj);
1371 int i = pap->n_args; /* ToDo: stack check */
1372 /* ToDo: if PAP is in whnf, we can update any update frames
1376 xPushWord(payloadWord(pap,i));
1383 obj = stgCast(StgInd*,obj)->indirectee;
1388 obj = stgCast(StgIndOldGen*,obj)->indirectee;
1397 case CONSTR_INTLIKE:
1398 case CONSTR_CHARLIKE:
1400 case CONSTR_NOCAF_STATIC:
1403 switch (get_itbl(stgCast(StgClosure*,xSp))->type) {
1405 SSS; PopCatchFrame(); LLL;
1408 xPopUpdateFrame(obj);
1411 SSS; PopSeqFrame(); LLL;
1415 ASSERT(xSp==(P_)xSu);
1418 fprintf(stderr, "hit a STOP_FRAME\n");
1420 fprintf(stderr,"xSp = %p\txSu = %p\n", xSp, xSu);
1421 printStack(xSp,CurrentTSO->stack+CurrentTSO->stack_size,xSu);
1424 SSS; PopStopFrame(obj); LLL;
1425 RETURN(ThreadFinished);
1435 /* was: goto enterLoop;
1436 But we know that obj must be a bco now, so jump directly.
1439 case RET_SMALL: /* return to GHC */
1443 // barf("todo: RET_[VEC_]{BIG,SMALL}");
1445 belch("entered CONSTR with invalid continuation on stack");
1448 printObj(stgCast(StgClosure*,xSp));
1451 barf("bailing out");
1458 //fprintf(stderr, "enterCountI = %d\n", enterCountI);
1459 //fprintf(stderr, "entering unknown closure -- yielding to sched\n");
1462 CurrentTSO->whatNext = ThreadEnterGHC;
1463 xPushCPtr(obj); /* code to restart with */
1464 RETURN(ThreadYielding);
1467 barf("Ran off the end of enter - yoiks");
1484 #undef xSetStackWord
1487 #undef xPushTaggedInt
1488 #undef xPopTaggedInt
1489 #undef xTaggedStackInt
1490 #undef xPushTaggedWord
1491 #undef xPopTaggedWord
1492 #undef xTaggedStackWord
1493 #undef xPushTaggedAddr
1494 #undef xTaggedStackAddr
1495 #undef xPopTaggedAddr
1496 #undef xPushTaggedStable
1497 #undef xTaggedStackStable
1498 #undef xPopTaggedStable
1499 #undef xPushTaggedChar
1500 #undef xTaggedStackChar
1501 #undef xPopTaggedChar
1502 #undef xPushTaggedFloat
1503 #undef xTaggedStackFloat
1504 #undef xPopTaggedFloat
1505 #undef xPushTaggedDouble
1506 #undef xTaggedStackDouble
1507 #undef xPopTaggedDouble
1511 /* --------------------------------------------------------------------------
1512 * Supporting routines for primops
1513 * ------------------------------------------------------------------------*/
1515 static inline void PushTag ( StackTag t )
1517 inline void PushPtr ( StgPtr x )
1518 { *(--stgCast(StgPtr*,Sp)) = x; }
1519 static inline void PushCPtr ( StgClosure* x )
1520 { *(--stgCast(StgClosure**,Sp)) = x; }
1521 static inline void PushInt ( StgInt x )
1522 { *(--stgCast(StgInt*,Sp)) = x; }
1523 static inline void PushWord ( StgWord x )
1524 { *(--stgCast(StgWord*,Sp)) = x; }
1527 static inline void checkTag ( StackTag t1, StackTag t2 )
1528 { ASSERT(t1 == t2);}
1529 static inline void PopTag ( StackTag t )
1530 { checkTag(t,*(Sp++)); }
1531 inline StgPtr PopPtr ( void )
1532 { return *stgCast(StgPtr*,Sp)++; }
1533 static inline StgClosure* PopCPtr ( void )
1534 { return *stgCast(StgClosure**,Sp)++; }
1535 static inline StgInt PopInt ( void )
1536 { return *stgCast(StgInt*,Sp)++; }
1537 static inline StgWord PopWord ( void )
1538 { return *stgCast(StgWord*,Sp)++; }
1540 static inline StgPtr stackPtr ( StgStackOffset i )
1541 { return *stgCast(StgPtr*, Sp+i); }
1542 static inline StgInt stackInt ( StgStackOffset i )
1543 { return *stgCast(StgInt*, Sp+i); }
1544 static inline StgWord stackWord ( StgStackOffset i )
1545 { return *stgCast(StgWord*,Sp+i); }
1547 static inline void setStackWord ( StgStackOffset i, StgWord w )
1550 static inline void PushTaggedRealWorld( void )
1551 { PushTag(REALWORLD_TAG); }
1552 inline void PushTaggedInt ( StgInt x )
1553 { Sp -= sizeofW(StgInt); *Sp = x; PushTag(INT_TAG); }
1554 inline void PushTaggedWord ( StgWord x )
1555 { Sp -= sizeofW(StgWord); *Sp = x; PushTag(WORD_TAG); }
1556 inline void PushTaggedAddr ( StgAddr x )
1557 { Sp -= sizeofW(StgAddr); *Sp = (W_)x; PushTag(ADDR_TAG); }
1558 inline void PushTaggedChar ( StgChar x )
1559 { Sp -= sizeofW(StgChar); *Sp = stgCast(StgWord,x); PushTag(CHAR_TAG); }
1560 inline void PushTaggedFloat ( StgFloat x )
1561 { Sp -= sizeofW(StgFloat); ASSIGN_FLT(Sp,x); PushTag(FLOAT_TAG); }
1562 inline void PushTaggedDouble ( StgDouble x )
1563 { Sp -= sizeofW(StgDouble); ASSIGN_DBL(Sp,x); PushTag(DOUBLE_TAG); }
1564 inline void PushTaggedStablePtr ( StgStablePtr x )
1565 { Sp -= sizeofW(StgStablePtr); *Sp = x; PushTag(STABLE_TAG); }
1566 static inline void PushTaggedBool ( int x )
1567 { PushTaggedInt(x); }
1571 static inline void PopTaggedRealWorld ( void )
1572 { PopTag(REALWORLD_TAG); }
1573 inline StgInt PopTaggedInt ( void )
1574 { StgInt r; PopTag(INT_TAG); r = *stgCast(StgInt*, Sp);
1575 Sp += sizeofW(StgInt); return r;}
1576 inline StgWord PopTaggedWord ( void )
1577 { StgWord r; PopTag(WORD_TAG); r = *stgCast(StgWord*, Sp);
1578 Sp += sizeofW(StgWord); return r;}
1579 inline StgAddr PopTaggedAddr ( void )
1580 { StgAddr r; PopTag(ADDR_TAG); r = *stgCast(StgAddr*, Sp);
1581 Sp += sizeofW(StgAddr); return r;}
1582 inline StgChar PopTaggedChar ( void )
1583 { StgChar r; PopTag(CHAR_TAG); r = stgCast(StgChar, *Sp);
1584 Sp += sizeofW(StgChar); return r;}
1585 inline StgFloat PopTaggedFloat ( void )
1586 { StgFloat r; PopTag(FLOAT_TAG); r = PK_FLT(Sp);
1587 Sp += sizeofW(StgFloat); return r;}
1588 inline StgDouble PopTaggedDouble ( void )
1589 { StgDouble r; PopTag(DOUBLE_TAG); r = PK_DBL(Sp);
1590 Sp += sizeofW(StgDouble); return r;}
1591 inline StgStablePtr PopTaggedStablePtr ( void )
1592 { StgInt r; PopTag(STABLE_TAG); r = *stgCast(StgStablePtr*, Sp);
1593 Sp += sizeofW(StgStablePtr); return r;}
1597 static inline StgInt taggedStackInt ( StgStackOffset i )
1598 { checkTag(INT_TAG,Sp[i]); return *stgCast(StgInt*, Sp+1+i); }
1599 static inline StgWord taggedStackWord ( StgStackOffset i )
1600 { checkTag(WORD_TAG,Sp[i]); return *stgCast(StgWord*, Sp+1+i); }
1601 static inline StgAddr taggedStackAddr ( StgStackOffset i )
1602 { checkTag(ADDR_TAG,Sp[i]); return *stgCast(StgAddr*, Sp+1+i); }
1603 static inline StgChar taggedStackChar ( StgStackOffset i )
1604 { checkTag(CHAR_TAG,Sp[i]); return stgCast(StgChar, *(Sp+1+i)) ; }
1605 static inline StgFloat taggedStackFloat ( StgStackOffset i )
1606 { checkTag(FLOAT_TAG,Sp[i]); return PK_FLT(Sp+1+i); }
1607 static inline StgDouble taggedStackDouble ( StgStackOffset i )
1608 { checkTag(DOUBLE_TAG,Sp[i]); return PK_DBL(Sp+1+i); }
1609 static inline StgStablePtr taggedStackStable ( StgStackOffset i )
1610 { checkTag(STABLE_TAG,Sp[i]); return *stgCast(StgStablePtr*, Sp+1+i); }
1613 /* --------------------------------------------------------------------------
1616 * Should we allocate from a nursery or use the
1617 * doYouWantToGC/allocate interface? We'd already implemented a
1618 * nursery-style scheme when the doYouWantToGC/allocate interface
1620 * One reason to prefer the doYouWantToGC/allocate interface is to
1621 * support operations which allocate an unknown amount in the heap
1622 * (array ops, gmp ops, etc)
1623 * ------------------------------------------------------------------------*/
1625 static inline StgPtr grabHpUpd( nat size )
1627 ASSERT( size >= MIN_UPD_SIZE + sizeofW(StgHeader) );
1628 #ifdef CRUDE_PROFILING
1629 cp_bill_words ( size );
1631 return allocate(size);
1634 static inline StgPtr grabHpNonUpd( nat size )
1636 ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
1637 #ifdef CRUDE_PROFILING
1638 cp_bill_words ( size );
1640 return allocate(size);
1643 /* --------------------------------------------------------------------------
1644 * Manipulate "update frame" list:
1645 * o Update frames (based on stg_do_update and friends in Updates.hc)
1646 * o Error handling/catching (based on catchzh_fast and friends in Prims.hc)
1647 * o Seq frames (based on seq_frame_entry in Prims.hc)
1649 * ------------------------------------------------------------------------*/
1651 static inline void PopUpdateFrame( StgClosure* obj )
1653 /* NB: doesn't assume that Sp == Su */
1655 fprintf(stderr, "Updating ");
1656 printPtr(stgCast(StgPtr,Su->updatee));
1657 fprintf(stderr, " with ");
1659 fprintf(stderr,"Sp = %p\tSu = %p\n\n", Sp, Su);
1661 #ifdef EAGER_BLACKHOLING
1662 #warn LAZY_BLACKHOLING is default for StgHugs
1663 #error Dont know if EAGER_BLACKHOLING works in StgHugs
1664 ASSERT(get_itbl(Su->updatee)->type == BLACKHOLE
1665 || get_itbl(Su->updatee)->type == SE_BLACKHOLE
1666 || get_itbl(Su->updatee)->type == CAF_BLACKHOLE
1667 || get_itbl(Su->updatee)->type == SE_CAF_BLACKHOLE
1669 #endif /* EAGER_BLACKHOLING */
1670 UPD_IND(Su->updatee,obj);
1671 Sp = stgCast(StgStackPtr,Su) + sizeofW(StgUpdateFrame);
1675 static inline void PopStopFrame( StgClosure* obj )
1677 /* Move Su just off the end of the stack, we're about to spam the
1678 * STOP_FRAME with the return value.
1680 Su = stgCast(StgUpdateFrame*,Sp+1);
1681 *stgCast(StgClosure**,Sp) = obj;
1684 static inline void PushCatchFrame( StgClosure* handler )
1687 /* ToDo: stack check! */
1688 Sp -= sizeofW(StgCatchFrame);
1689 fp = stgCast(StgCatchFrame*,Sp);
1690 SET_HDR(fp,(StgInfoTable*)&catch_frame_info,CCCS);
1691 fp->handler = handler;
1693 Su = stgCast(StgUpdateFrame*,fp);
1696 static inline void PopCatchFrame( void )
1698 /* NB: doesn't assume that Sp == Su */
1699 /* fprintf(stderr,"Popping catch frame\n"); */
1700 Sp = stgCast(StgStackPtr,Su) + sizeofW(StgCatchFrame);
1701 Su = stgCast(StgCatchFrame*,Su)->link;
1704 static inline void PushSeqFrame( void )
1707 /* ToDo: stack check! */
1708 Sp -= sizeofW(StgSeqFrame);
1709 fp = stgCast(StgSeqFrame*,Sp);
1710 SET_HDR(fp,(StgInfoTable*)&seq_frame_info,CCCS);
1712 Su = stgCast(StgUpdateFrame*,fp);
1715 static inline void PopSeqFrame( void )
1717 /* NB: doesn't assume that Sp == Su */
1718 Sp = stgCast(StgStackPtr,Su) + sizeofW(StgSeqFrame);
1719 Su = stgCast(StgSeqFrame*,Su)->link;
1722 static inline StgClosure* raiseAnError( StgClosure* errObj )
1724 StgClosure *raise_closure;
1726 /* This closure represents the expression 'raise# E' where E
1727 * is the exception raised. It is used to overwrite all the
1728 * thunks which are currently under evaluataion.
1730 raise_closure = (StgClosure *)allocate(sizeofW(StgClosure)+1);
1731 raise_closure->header.info = &raise_info;
1732 raise_closure->payload[0] = R1.cl;
1735 switch (get_itbl(Su)->type) {
1737 UPD_IND(Su->updatee,raise_closure);
1738 Sp = stgCast(StgStackPtr,Su) + sizeofW(StgUpdateFrame);
1744 case CATCH_FRAME: /* found it! */
1746 StgCatchFrame* fp = stgCast(StgCatchFrame*,Su);
1747 StgClosure *handler = fp->handler;
1749 Sp += sizeofW(StgCatchFrame); /* Pop */
1754 barf("raiseError: uncaught exception: STOP_FRAME");
1756 barf("raiseError: weird activation record");
1762 static StgClosure* makeErrorCall ( const char* msg )
1764 /* Note! the msg string should be allocated in a
1765 place which will not get freed -- preferably
1766 read-only data of the program. That's because
1767 the thunk we build here may linger indefinitely.
1768 (thinks: probably not so, but anyway ...)
1771 = asmClosureOfObject(getHugs_AsmObject_for("error"));
1773 = asmClosureOfObject(getHugs_AsmObject_for("primUnpackString"));
1775 = rts_apply ( unpack, rts_mkAddr ( (void*)msg ) );
1777 = rts_apply ( error, thunk );
1779 (StgClosure*) thunk;
1782 #define raiseIndex(where) makeErrorCall("Array index out of range in " where)
1783 #define raiseDiv0(where) makeErrorCall("Division by zero in " where)
1785 /* --------------------------------------------------------------------------
1787 * ------------------------------------------------------------------------*/
1789 #define OP_CC_B(e) \
1791 unsigned char x = PopTaggedChar(); \
1792 unsigned char y = PopTaggedChar(); \
1793 PushTaggedBool(e); \
1798 unsigned char x = PopTaggedChar(); \
1807 #define OP_IW_I(e) \
1809 StgInt x = PopTaggedInt(); \
1810 StgWord y = PopTaggedWord(); \
1814 #define OP_II_I(e) \
1816 StgInt x = PopTaggedInt(); \
1817 StgInt y = PopTaggedInt(); \
1821 #define OP_II_B(e) \
1823 StgInt x = PopTaggedInt(); \
1824 StgInt y = PopTaggedInt(); \
1825 PushTaggedBool(e); \
1830 PushTaggedAddr(e); \
1835 StgInt x = PopTaggedInt(); \
1836 PushTaggedAddr(e); \
1841 StgInt x = PopTaggedInt(); \
1847 PushTaggedChar(e); \
1852 StgInt x = PopTaggedInt(); \
1853 PushTaggedChar(e); \
1858 PushTaggedWord(e); \
1863 StgInt x = PopTaggedInt(); \
1864 PushTaggedWord(e); \
1869 StgInt x = PopTaggedInt(); \
1870 PushTaggedStablePtr(e); \
1875 PushTaggedFloat(e); \
1880 StgInt x = PopTaggedInt(); \
1881 PushTaggedFloat(e); \
1886 PushTaggedDouble(e); \
1891 StgInt x = PopTaggedInt(); \
1892 PushTaggedDouble(e); \
1895 #define OP_WW_B(e) \
1897 StgWord x = PopTaggedWord(); \
1898 StgWord y = PopTaggedWord(); \
1899 PushTaggedBool(e); \
1902 #define OP_WW_W(e) \
1904 StgWord x = PopTaggedWord(); \
1905 StgWord y = PopTaggedWord(); \
1906 PushTaggedWord(e); \
1911 StgWord x = PopTaggedWord(); \
1917 StgStablePtr x = PopTaggedStablePtr(); \
1923 StgWord x = PopTaggedWord(); \
1924 PushTaggedWord(e); \
1927 #define OP_AA_B(e) \
1929 StgAddr x = PopTaggedAddr(); \
1930 StgAddr y = PopTaggedAddr(); \
1931 PushTaggedBool(e); \
1935 StgAddr x = PopTaggedAddr(); \
1938 #define OP_AI_C(s) \
1940 StgAddr x = PopTaggedAddr(); \
1941 int y = PopTaggedInt(); \
1944 PushTaggedChar(r); \
1946 #define OP_AI_I(s) \
1948 StgAddr x = PopTaggedAddr(); \
1949 int y = PopTaggedInt(); \
1954 #define OP_AI_A(s) \
1956 StgAddr x = PopTaggedAddr(); \
1957 int y = PopTaggedInt(); \
1960 PushTaggedAddr(s); \
1962 #define OP_AI_F(s) \
1964 StgAddr x = PopTaggedAddr(); \
1965 int y = PopTaggedInt(); \
1968 PushTaggedFloat(r); \
1970 #define OP_AI_D(s) \
1972 StgAddr x = PopTaggedAddr(); \
1973 int y = PopTaggedInt(); \
1976 PushTaggedDouble(r); \
1978 #define OP_AI_s(s) \
1980 StgAddr x = PopTaggedAddr(); \
1981 int y = PopTaggedInt(); \
1984 PushTaggedStablePtr(r); \
1986 #define OP_AIC_(s) \
1988 StgAddr x = PopTaggedAddr(); \
1989 int y = PopTaggedInt(); \
1990 StgChar z = PopTaggedChar(); \
1993 #define OP_AII_(s) \
1995 StgAddr x = PopTaggedAddr(); \
1996 int y = PopTaggedInt(); \
1997 StgInt z = PopTaggedInt(); \
2000 #define OP_AIA_(s) \
2002 StgAddr x = PopTaggedAddr(); \
2003 int y = PopTaggedInt(); \
2004 StgAddr z = PopTaggedAddr(); \
2007 #define OP_AIF_(s) \
2009 StgAddr x = PopTaggedAddr(); \
2010 int y = PopTaggedInt(); \
2011 StgFloat z = PopTaggedFloat(); \
2014 #define OP_AID_(s) \
2016 StgAddr x = PopTaggedAddr(); \
2017 int y = PopTaggedInt(); \
2018 StgDouble z = PopTaggedDouble(); \
2021 #define OP_AIs_(s) \
2023 StgAddr x = PopTaggedAddr(); \
2024 int y = PopTaggedInt(); \
2025 StgStablePtr z = PopTaggedStablePtr(); \
2030 #define OP_FF_B(e) \
2032 StgFloat x = PopTaggedFloat(); \
2033 StgFloat y = PopTaggedFloat(); \
2034 PushTaggedBool(e); \
2037 #define OP_FF_F(e) \
2039 StgFloat x = PopTaggedFloat(); \
2040 StgFloat y = PopTaggedFloat(); \
2041 PushTaggedFloat(e); \
2046 StgFloat x = PopTaggedFloat(); \
2047 PushTaggedFloat(e); \
2052 StgFloat x = PopTaggedFloat(); \
2053 PushTaggedBool(e); \
2058 StgFloat x = PopTaggedFloat(); \
2064 StgFloat x = PopTaggedFloat(); \
2065 PushTaggedDouble(e); \
2068 #define OP_DD_B(e) \
2070 StgDouble x = PopTaggedDouble(); \
2071 StgDouble y = PopTaggedDouble(); \
2072 PushTaggedBool(e); \
2075 #define OP_DD_D(e) \
2077 StgDouble x = PopTaggedDouble(); \
2078 StgDouble y = PopTaggedDouble(); \
2079 PushTaggedDouble(e); \
2084 StgDouble x = PopTaggedDouble(); \
2085 PushTaggedBool(e); \
2090 StgDouble x = PopTaggedDouble(); \
2091 PushTaggedDouble(e); \
2096 StgDouble x = PopTaggedDouble(); \
2102 StgDouble x = PopTaggedDouble(); \
2103 PushTaggedFloat(e); \
2107 #ifdef STANDALONE_INTEGER
2108 StgPtr CreateByteArrayToHoldInteger ( int nbytes )
2110 StgInt words = (nbytes+sizeof(W_)-1)/sizeof(W_);
2111 StgWord size = sizeofW(StgArrWords) + words;
2112 StgArrWords* arr = (StgArrWords*)allocate(size);
2113 SET_HDR(arr,&ARR_WORDS_info,CCCS);
2115 ASSERT(nbytes <= arr->words * sizeof(W_));
2118 for (i = 0; i < words; ++i) {
2119 arr->payload[i] = 0xdeadbeef;
2121 { B* b = (B*) &(arr->payload[0]);
2122 b->used = b->sign = 0;
2128 B* IntegerInsideByteArray ( StgPtr arr0 )
2131 StgArrWords* arr = (StgArrWords*)arr0;
2132 ASSERT(GET_INFO(arr) == &ARR_WORDS_info);
2133 b = (B*) &(arr->payload[0]);
2137 void SloppifyIntegerEnd ( StgPtr arr0 )
2139 StgArrWords* arr = (StgArrWords*)arr0;
2140 B* b = (B*) & (arr->payload[0]);
2141 I_ nwunused = arr->words - sizeofW(B) - (b->used+sizeof(W_)-1)/sizeof(W_);
2142 if (nwunused >= ((I_)sizeofW(StgArrWords))) {
2144 b->size -= nwunused * sizeof(W_);
2145 if (b->size < b->used) b->size = b->used;
2148 arr->words -= nwunused;
2149 slop = (StgArrWords*)&(arr->payload[arr->words]);
2150 SET_HDR(slop,&ARR_WORDS_info,CCCS);
2151 slop->words = nwunused - sizeofW(StgArrWords);
2152 ASSERT( &(slop->payload[slop->words]) ==
2153 &(arr->payload[arr->words + nwunused]) );
2157 #define OP_Z_Z(op) \
2159 B* x = IntegerInsideByteArray(PopPtr()); \
2160 int n = mycat2(size_,op)(x); \
2161 StgPtr p = CreateByteArrayToHoldInteger(n); \
2162 mycat2(do_,op)(x,n,IntegerInsideByteArray(p)); \
2163 SloppifyIntegerEnd(p); \
2166 #define OP_ZZ_Z(op) \
2168 B* x = IntegerInsideByteArray(PopPtr()); \
2169 B* y = IntegerInsideByteArray(PopPtr()); \
2170 int n = mycat2(size_,op)(x,y); \
2171 StgPtr p = CreateByteArrayToHoldInteger(n); \
2172 mycat2(do_,op)(x,y,n,IntegerInsideByteArray(p)); \
2173 SloppifyIntegerEnd(p); \
2181 #define HEADER_mI(ty,where) \
2182 StgArrWords* x = stgCast(StgArrWords*,PopPtr()); \
2183 nat i = PopTaggedInt(); \
2184 if (i * sizeof(ty) + (sizeof(ty)) > sizeof(StgWord) * x->words) { \
2185 return (raiseIndex(where)); \
2187 #define OP_mI_ty(ty,where,s) \
2189 HEADER_mI(mycat2(Stg,ty),where) \
2190 { mycat2(Stg,ty) r; \
2192 mycat2(PushTagged,ty)(r); \
2195 #define OP_mIty_(ty,where,s) \
2197 HEADER_mI(mycat2(Stg,ty),where) \
2199 mycat2(Stg,ty) z = mycat2(PopTagged,ty)(); \
2205 void myStackCheck ( void )
2207 //StgPtr sp = (StgPtr)Sp;
2208 StgPtr su = (StgPtr)Su;
2209 //fprintf(stderr, "myStackCheck\n");
2210 if (!(SpLim <= Sp && Sp <= stgCast(StgPtr,Su))) {
2211 fprintf(stderr, "myStackCheck: invalid initial Sp/Su \n" );
2215 if (!(su >= CurrentTSO->stack && su <= CurrentTSO->stack + CurrentTSO->stack_size)) {
2216 fprintf ( stderr, "myStackCheck: su out of stack\n" );
2219 switch (get_itbl(stgCast(StgClosure*,su))->type) {
2221 su = (StgPtr) ((StgCatchFrame*)(su))->link;
2224 su = (StgPtr) ((StgUpdateFrame*)(su))->link;
2227 su = (StgPtr) ((StgSeqFrame*)(su))->link;
2232 fprintf(stderr, "myStackCheck: invalid activation record\n"); assert(0);
2239 /* --------------------------------------------------------------------------
2240 * Primop stuff for bytecode interpreter
2241 * ------------------------------------------------------------------------*/
2243 /* Returns & of the next thing to enter (if throwing an exception),
2244 or NULL in the normal case.
2246 static void* enterBCO_primop1 ( int primop1code )
2248 switch (primop1code) {
2249 case i_pushseqframe:
2251 StgClosure* c = PopCPtr();
2256 case i_pushcatchframe:
2258 StgClosure* e = PopCPtr();
2259 StgClosure* h = PopCPtr();
2265 case i_gtChar: OP_CC_B(x>y); break;
2266 case i_geChar: OP_CC_B(x>=y); break;
2267 case i_eqChar: OP_CC_B(x==y); break;
2268 case i_neChar: OP_CC_B(x!=y); break;
2269 case i_ltChar: OP_CC_B(x<y); break;
2270 case i_leChar: OP_CC_B(x<=y); break;
2271 case i_charToInt: OP_C_I(x); break;
2272 case i_intToChar: OP_I_C(x); break;
2274 case i_gtInt: OP_II_B(x>y); break;
2275 case i_geInt: OP_II_B(x>=y); break;
2276 case i_eqInt: OP_II_B(x==y); break;
2277 case i_neInt: OP_II_B(x!=y); break;
2278 case i_ltInt: OP_II_B(x<y); break;
2279 case i_leInt: OP_II_B(x<=y); break;
2280 case i_minInt: OP__I(INT_MIN); break;
2281 case i_maxInt: OP__I(INT_MAX); break;
2282 case i_plusInt: OP_II_I(x+y); break;
2283 case i_minusInt: OP_II_I(x-y); break;
2284 case i_timesInt: OP_II_I(x*y); break;
2287 int x = PopTaggedInt();
2288 int y = PopTaggedInt();
2290 return (raiseDiv0("quotInt"));
2292 /* ToDo: protect against minInt / -1 errors
2293 * (repeat for all other division primops) */
2299 int x = PopTaggedInt();
2300 int y = PopTaggedInt();
2302 return (raiseDiv0("remInt"));
2309 StgInt x = PopTaggedInt();
2310 StgInt y = PopTaggedInt();
2312 return (raiseDiv0("quotRemInt"));
2314 PushTaggedInt(x%y); /* last result */
2315 PushTaggedInt(x/y); /* first result */
2318 case i_negateInt: OP_I_I(-x); break;
2320 case i_andInt: OP_II_I(x&y); break;
2321 case i_orInt: OP_II_I(x|y); break;
2322 case i_xorInt: OP_II_I(x^y); break;
2323 case i_notInt: OP_I_I(~x); break;
2324 case i_shiftLInt: OP_II_I(x<<y); break;
2325 case i_shiftRAInt: OP_II_I(x>>y); break; /* ToDo */
2326 case i_shiftRLInt: OP_II_I(x>>y); break; /* ToDo */
2328 case i_gtWord: OP_WW_B(x>y); break;
2329 case i_geWord: OP_WW_B(x>=y); break;
2330 case i_eqWord: OP_WW_B(x==y); break;
2331 case i_neWord: OP_WW_B(x!=y); break;
2332 case i_ltWord: OP_WW_B(x<y); break;
2333 case i_leWord: OP_WW_B(x<=y); break;
2334 case i_minWord: OP__W(0); break;
2335 case i_maxWord: OP__W(UINT_MAX); break;
2336 case i_plusWord: OP_WW_W(x+y); break;
2337 case i_minusWord: OP_WW_W(x-y); break;
2338 case i_timesWord: OP_WW_W(x*y); break;
2341 StgWord x = PopTaggedWord();
2342 StgWord y = PopTaggedWord();
2344 return (raiseDiv0("quotWord"));
2346 PushTaggedWord(x/y);
2351 StgWord x = PopTaggedWord();
2352 StgWord y = PopTaggedWord();
2354 return (raiseDiv0("remWord"));
2356 PushTaggedWord(x%y);
2361 StgWord x = PopTaggedWord();
2362 StgWord y = PopTaggedWord();
2364 return (raiseDiv0("quotRemWord"));
2366 PushTaggedWord(x%y); /* last result */
2367 PushTaggedWord(x/y); /* first result */
2370 case i_negateWord: OP_W_W(-x); break;
2371 case i_andWord: OP_WW_W(x&y); break;
2372 case i_orWord: OP_WW_W(x|y); break;
2373 case i_xorWord: OP_WW_W(x^y); break;
2374 case i_notWord: OP_W_W(~x); break;
2375 case i_shiftLWord: OP_WW_W(x<<y); break;
2376 case i_shiftRAWord: OP_WW_W(x>>y); break; /* ToDo */
2377 case i_shiftRLWord: OP_WW_W(x>>y); break; /* ToDo */
2378 case i_intToWord: OP_I_W(x); break;
2379 case i_wordToInt: OP_W_I(x); break;
2381 case i_gtAddr: OP_AA_B(x>y); break;
2382 case i_geAddr: OP_AA_B(x>=y); break;
2383 case i_eqAddr: OP_AA_B(x==y); break;
2384 case i_neAddr: OP_AA_B(x!=y); break;
2385 case i_ltAddr: OP_AA_B(x<y); break;
2386 case i_leAddr: OP_AA_B(x<=y); break;
2387 case i_intToAddr: OP_I_A((StgAddr)x); break; /* ToDo */
2388 case i_addrToInt: OP_A_I((StgInt)x); break; /* ToDo */
2390 case i_intToStable: OP_I_s(x); break;
2391 case i_stableToInt: OP_s_I(x); break;
2393 case i_indexCharOffAddr: OP_AI_C(indexCharOffAddrzh(r,x,y)); break;
2394 case i_readCharOffAddr: OP_AI_C(indexCharOffAddrzh(r,x,y)); break;
2395 case i_writeCharOffAddr: OP_AIC_(writeCharOffAddrzh(x,y,z)); break;
2397 case i_indexIntOffAddr: OP_AI_I(indexIntOffAddrzh(r,x,y)); break;
2398 case i_readIntOffAddr: OP_AI_I(indexIntOffAddrzh(r,x,y)); break;
2399 case i_writeIntOffAddr: OP_AII_(writeIntOffAddrzh(x,y,z)); break;
2401 case i_indexAddrOffAddr: OP_AI_A(indexAddrOffAddrzh(r,x,y)); break;
2402 case i_readAddrOffAddr: OP_AI_A(indexAddrOffAddrzh(r,x,y)); break;
2403 case i_writeAddrOffAddr: OP_AIA_(writeAddrOffAddrzh(x,y,z)); break;
2405 case i_indexFloatOffAddr: OP_AI_F(indexFloatOffAddrzh(r,x,y)); break;
2406 case i_readFloatOffAddr: OP_AI_F(indexFloatOffAddrzh(r,x,y)); break;
2407 case i_writeFloatOffAddr: OP_AIF_(writeFloatOffAddrzh(x,y,z)); break;
2409 case i_indexDoubleOffAddr: OP_AI_D(indexDoubleOffAddrzh(r,x,y)); break;
2410 case i_readDoubleOffAddr: OP_AI_D(indexDoubleOffAddrzh(r,x,y)); break;
2411 case i_writeDoubleOffAddr: OP_AID_(writeDoubleOffAddrzh(x,y,z)); break;
2413 case i_indexStableOffAddr: OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break;
2414 case i_readStableOffAddr: OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break;
2415 case i_writeStableOffAddr: OP_AIs_(writeStablePtrOffAddrzh(x,y,z)); break;
2417 #ifdef STANDALONE_INTEGER
2418 case i_compareInteger:
2420 B* x = IntegerInsideByteArray(PopPtr());
2421 B* y = IntegerInsideByteArray(PopPtr());
2422 StgInt r = do_cmp(x,y);
2423 PushTaggedInt(r<0 ? -1 : (r>0 ? 1 : 0));
2426 case i_negateInteger: OP_Z_Z(neg); break;
2427 case i_plusInteger: OP_ZZ_Z(add); break;
2428 case i_minusInteger: OP_ZZ_Z(sub); break;
2429 case i_timesInteger: OP_ZZ_Z(mul); break;
2430 case i_quotRemInteger:
2432 B* x = IntegerInsideByteArray(PopPtr());
2433 B* y = IntegerInsideByteArray(PopPtr());
2434 int n = size_qrm(x,y);
2435 StgPtr q = CreateByteArrayToHoldInteger(n);
2436 StgPtr r = CreateByteArrayToHoldInteger(n);
2437 if (do_getsign(y)==0)
2438 return (raiseDiv0("quotRemInteger"));
2439 do_qrm(x,y,n,IntegerInsideByteArray(q),
2440 IntegerInsideByteArray(r));
2441 SloppifyIntegerEnd(q);
2442 SloppifyIntegerEnd(r);
2447 case i_intToInteger:
2449 int n = size_fromInt();
2450 StgPtr p = CreateByteArrayToHoldInteger(n);
2451 do_fromInt( PopTaggedInt(), n, IntegerInsideByteArray(p));
2455 case i_wordToInteger:
2457 int n = size_fromWord();
2458 StgPtr p = CreateByteArrayToHoldInteger(n);
2459 do_fromWord( PopTaggedWord(), n, IntegerInsideByteArray(p));
2463 case i_integerToInt: PushTaggedInt(do_toInt(
2464 IntegerInsideByteArray(PopPtr())
2468 case i_integerToWord: PushTaggedWord(do_toWord(
2469 IntegerInsideByteArray(PopPtr())
2473 case i_integerToFloat: PushTaggedFloat(do_toFloat(
2474 IntegerInsideByteArray(PopPtr())
2478 case i_integerToDouble: PushTaggedDouble(do_toDouble(
2479 IntegerInsideByteArray(PopPtr())
2483 #error Non-standalone integer not yet implemented
2484 #endif /* STANDALONE_INTEGER */
2486 case i_gtFloat: OP_FF_B(x>y); break;
2487 case i_geFloat: OP_FF_B(x>=y); break;
2488 case i_eqFloat: OP_FF_B(x==y); break;
2489 case i_neFloat: OP_FF_B(x!=y); break;
2490 case i_ltFloat: OP_FF_B(x<y); break;
2491 case i_leFloat: OP_FF_B(x<=y); break;
2492 case i_minFloat: OP__F(FLT_MIN); break;
2493 case i_maxFloat: OP__F(FLT_MAX); break;
2494 case i_radixFloat: OP__I(FLT_RADIX); break;
2495 case i_digitsFloat: OP__I(FLT_MANT_DIG); break;
2496 case i_minExpFloat: OP__I(FLT_MIN_EXP); break;
2497 case i_maxExpFloat: OP__I(FLT_MAX_EXP); break;
2498 case i_plusFloat: OP_FF_F(x+y); break;
2499 case i_minusFloat: OP_FF_F(x-y); break;
2500 case i_timesFloat: OP_FF_F(x*y); break;
2503 StgFloat x = PopTaggedFloat();
2504 StgFloat y = PopTaggedFloat();
2505 PushTaggedFloat(x/y);
2508 case i_negateFloat: OP_F_F(-x); break;
2509 case i_floatToInt: OP_F_I(x); break;
2510 case i_intToFloat: OP_I_F(x); break;
2511 case i_expFloat: OP_F_F(exp(x)); break;
2512 case i_logFloat: OP_F_F(log(x)); break;
2513 case i_sqrtFloat: OP_F_F(sqrt(x)); break;
2514 case i_sinFloat: OP_F_F(sin(x)); break;
2515 case i_cosFloat: OP_F_F(cos(x)); break;
2516 case i_tanFloat: OP_F_F(tan(x)); break;
2517 case i_asinFloat: OP_F_F(asin(x)); break;
2518 case i_acosFloat: OP_F_F(acos(x)); break;
2519 case i_atanFloat: OP_F_F(atan(x)); break;
2520 case i_sinhFloat: OP_F_F(sinh(x)); break;
2521 case i_coshFloat: OP_F_F(cosh(x)); break;
2522 case i_tanhFloat: OP_F_F(tanh(x)); break;
2523 case i_powerFloat: OP_FF_F(pow(x,y)); break;
2525 #ifdef STANDALONE_INTEGER
2526 case i_encodeFloatZ:
2528 StgPtr sig = PopPtr();
2529 StgInt exp = PopTaggedInt();
2531 B__encodeFloat(IntegerInsideByteArray(sig), exp)
2535 case i_decodeFloatZ:
2537 StgFloat f = PopTaggedFloat();
2538 StgPtr sig = CreateByteArrayToHoldInteger(size_fltmantissa());
2540 B__decodeFloat(IntegerInsideByteArray(sig), &exp, f);
2546 #error encode/decodeFloatZ not yet implemented for GHC ints
2548 case i_isNaNFloat: OP_F_B(isFloatNaN(x)); break;
2549 case i_isInfiniteFloat: OP_F_B(isFloatInfinite(x)); break;
2550 case i_isNegativeZeroFloat: OP_F_B(isFloatNegativeZero(x)); break;
2551 case i_isDenormalizedFloat: OP_F_B(isFloatDenormalized(x)); break;
2552 case i_gtDouble: OP_DD_B(x>y); break;
2553 case i_geDouble: OP_DD_B(x>=y); break;
2554 case i_eqDouble: OP_DD_B(x==y); break;
2555 case i_neDouble: OP_DD_B(x!=y); break;
2556 case i_ltDouble: OP_DD_B(x<y); break;
2557 case i_leDouble: OP_DD_B(x<=y) break;
2558 case i_minDouble: OP__D(DBL_MIN); break;
2559 case i_maxDouble: OP__D(DBL_MAX); break;
2560 case i_radixDouble: OP__I(FLT_RADIX); break;
2561 case i_digitsDouble: OP__I(DBL_MANT_DIG); break;
2562 case i_minExpDouble: OP__I(DBL_MIN_EXP); break;
2563 case i_maxExpDouble: OP__I(DBL_MAX_EXP); break;
2564 case i_plusDouble: OP_DD_D(x+y); break;
2565 case i_minusDouble: OP_DD_D(x-y); break;
2566 case i_timesDouble: OP_DD_D(x*y); break;
2567 case i_divideDouble:
2569 StgDouble x = PopTaggedDouble();
2570 StgDouble y = PopTaggedDouble();
2571 PushTaggedDouble(x/y);
2574 case i_negateDouble: OP_D_D(-x); break;
2575 case i_doubleToInt: OP_D_I(x); break;
2576 case i_intToDouble: OP_I_D(x); break;
2577 case i_doubleToFloat: OP_D_F(x); break;
2578 case i_floatToDouble: OP_F_F(x); break;
2579 case i_expDouble: OP_D_D(exp(x)); break;
2580 case i_logDouble: OP_D_D(log(x)); break;
2581 case i_sqrtDouble: OP_D_D(sqrt(x)); break;
2582 case i_sinDouble: OP_D_D(sin(x)); break;
2583 case i_cosDouble: OP_D_D(cos(x)); break;
2584 case i_tanDouble: OP_D_D(tan(x)); break;
2585 case i_asinDouble: OP_D_D(asin(x)); break;
2586 case i_acosDouble: OP_D_D(acos(x)); break;
2587 case i_atanDouble: OP_D_D(atan(x)); break;
2588 case i_sinhDouble: OP_D_D(sinh(x)); break;
2589 case i_coshDouble: OP_D_D(cosh(x)); break;
2590 case i_tanhDouble: OP_D_D(tanh(x)); break;
2591 case i_powerDouble: OP_DD_D(pow(x,y)); break;
2593 #ifdef STANDALONE_INTEGER
2594 case i_encodeDoubleZ:
2596 StgPtr sig = PopPtr();
2597 StgInt exp = PopTaggedInt();
2599 B__encodeDouble(IntegerInsideByteArray(sig), exp)
2603 case i_decodeDoubleZ:
2605 StgDouble d = PopTaggedDouble();
2606 StgPtr sig = CreateByteArrayToHoldInteger(size_dblmantissa());
2608 B__decodeDouble(IntegerInsideByteArray(sig), &exp, d);
2614 #error encode/decodeDoubleZ not yet implemented for GHC ints
2616 case i_isNaNDouble: OP_D_B(isDoubleNaN(x)); break;
2617 case i_isInfiniteDouble: OP_D_B(isDoubleInfinite(x)); break;
2618 case i_isNegativeZeroDouble: OP_D_B(isDoubleNegativeZero(x)); break;
2619 case i_isDenormalizedDouble: OP_D_B(isDoubleDenormalized(x)); break;
2620 case i_isIEEEDouble:
2622 PushTaggedBool(rtsTrue);
2626 barf("Unrecognised primop1");
2633 /* For normal cases, return NULL and leave *return2 unchanged.
2634 To return the address of the next thing to enter,
2635 return the address of it and leave *return2 unchanged.
2636 To return a StgThreadReturnCode to the scheduler,
2637 set *return2 to it and return a non-NULL value.
2639 static void* enterBCO_primop2 ( int primop2code,
2640 int* /*StgThreadReturnCode* */ return2,
2643 switch (primop2code) {
2644 case i_raise: /* raise#{err} */
2646 StgClosure* err = PopCPtr();
2647 return (raiseAnError(err));
2652 StgClosure* init = PopCPtr();
2654 = stgCast(StgMutVar*,allocate(sizeofW(StgMutVar)));
2655 SET_HDR(mv,&MUT_VAR_info,CCCS);
2657 PushPtr(stgCast(StgPtr,mv));
2662 StgMutVar* mv = stgCast(StgMutVar*,PopPtr());
2668 StgMutVar* mv = stgCast(StgMutVar*,PopPtr());
2669 StgClosure* value = PopCPtr();
2675 nat n = PopTaggedInt(); /* or Word?? */
2676 StgClosure* init = PopCPtr();
2677 StgWord size = sizeofW(StgMutArrPtrs) + n;
2680 = stgCast(StgMutArrPtrs*,allocate(size));
2681 SET_HDR(arr,&MUT_ARR_PTRS_info,CCCS);
2683 for (i = 0; i < n; ++i) {
2684 arr->payload[i] = init;
2686 PushPtr(stgCast(StgPtr,arr));
2692 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2693 nat i = PopTaggedInt(); /* or Word?? */
2694 StgWord n = arr->ptrs;
2696 return (raiseIndex("{index,read}Array"));
2698 PushCPtr(arr->payload[i]);
2703 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2704 nat i = PopTaggedInt(); /* or Word? */
2705 StgClosure* v = PopCPtr();
2706 StgWord n = arr->ptrs;
2708 return (raiseIndex("{index,read}Array"));
2710 arr->payload[i] = v;
2714 case i_sizeMutableArray:
2716 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2717 PushTaggedInt(arr->ptrs);
2720 case i_unsafeFreezeArray:
2722 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2723 SET_INFO(arr,&MUT_ARR_PTRS_FROZEN_info);
2724 PushPtr(stgCast(StgPtr,arr));
2727 case i_unsafeFreezeByteArray:
2729 /* Delightfully simple :-) */
2733 case i_sameMutableArray:
2734 case i_sameMutableByteArray:
2736 StgPtr x = PopPtr();
2737 StgPtr y = PopPtr();
2738 PushTaggedBool(x==y);
2742 case i_newByteArray:
2744 nat n = PopTaggedInt(); /* or Word?? */
2745 StgInt words = (n+sizeof(W_)-1)/sizeof(W_);
2746 StgWord size = sizeofW(StgArrWords) + words;
2747 StgArrWords* arr = stgCast(StgArrWords*,allocate(size));
2748 SET_HDR(arr,&ARR_WORDS_info,CCCS);
2752 for (i = 0; i < n; ++i) {
2753 arr->payload[i] = 0xdeadbeef;
2756 PushPtr(stgCast(StgPtr,arr));
2760 /* Most of these generate alignment warnings on Sparcs and similar architectures.
2761 * These are harmless and are caused by the cast to C* in BYTE_ARR_CTS.
2763 case i_indexCharArray:
2764 OP_mI_ty(Char,"indexCharArray", indexCharArrayzh(r,x,i)); break;
2765 case i_readCharArray:
2766 OP_mI_ty(Char,"readCharArray", readCharArrayzh(r,x,i)); break;
2767 case i_writeCharArray:
2768 OP_mIty_(Char,"writeCharArray", writeCharArrayzh(x,i,z)); break;
2770 case i_indexIntArray:
2771 OP_mI_ty(Int,"indexIntArray", indexIntArrayzh(r,x,i)); break;
2772 case i_readIntArray:
2773 OP_mI_ty(Int,"readIntArray", readIntArrayzh(r,x,i)); break;
2774 case i_writeIntArray:
2775 OP_mIty_(Int,"writeIntArray", writeIntArrayzh(x,i,z)); break;
2777 case i_indexAddrArray:
2778 OP_mI_ty(Addr,"indexAddrArray", indexAddrArrayzh(r,x,i)); break;
2779 case i_readAddrArray:
2780 OP_mI_ty(Addr,"readAddrArray", readAddrArrayzh(r,x,i)); break;
2781 case i_writeAddrArray:
2782 OP_mIty_(Addr,"writeAddrArray", writeAddrArrayzh(x,i,z)); break;
2784 case i_indexFloatArray:
2785 OP_mI_ty(Float,"indexFloatArray", indexFloatArrayzh(r,x,i)); break;
2786 case i_readFloatArray:
2787 OP_mI_ty(Float,"readFloatArray", readFloatArrayzh(r,x,i)); break;
2788 case i_writeFloatArray:
2789 OP_mIty_(Float,"writeFloatArray", writeFloatArrayzh(x,i,z)); break;
2791 case i_indexDoubleArray:
2792 OP_mI_ty(Double,"indexDoubleArray", indexDoubleArrayzh(r,x,i)); break;
2793 case i_readDoubleArray:
2794 OP_mI_ty(Double,"readDoubleArray", readDoubleArrayzh(r,x,i)); break;
2795 case i_writeDoubleArray:
2796 OP_mIty_(Double,"writeDoubleArray", writeDoubleArrayzh(x,i,z)); break;
2799 #ifdef PROVIDE_STABLE
2800 case i_indexStableArray:
2801 OP_mI_ty(StablePtr,"indexStableArray", indexStablePtrArrayzh(r,x,i)); break;
2802 case i_readStableArray:
2803 OP_mI_ty(StablePtr,"readStableArray", readStablePtrArrayzh(r,x,i)); break;
2804 case i_writeStableArray:
2805 OP_mIty_(StablePtr,"writeStableArray", writeStablePtrArrayzh(x,i,z)); break;
2811 #ifdef PROVIDE_COERCE
2812 case i_unsafeCoerce:
2814 /* Another nullop */
2818 #ifdef PROVIDE_PTREQUALITY
2819 case i_reallyUnsafePtrEquality:
2820 { /* identical to i_sameRef */
2821 StgPtr x = PopPtr();
2822 StgPtr y = PopPtr();
2823 PushTaggedBool(x==y);
2827 #ifdef PROVIDE_FOREIGN
2828 /* ForeignObj# operations */
2829 case i_makeForeignObj:
2831 StgForeignObj *result
2832 = stgCast(StgForeignObj*,allocate(sizeofW(StgForeignObj)));
2833 SET_HDR(result,&FOREIGN_info,CCCS);
2834 result -> data = PopTaggedAddr();
2835 PushPtr(stgCast(StgPtr,result));
2838 #endif /* PROVIDE_FOREIGN */
2843 = stgCast(StgWeak*,allocate(sizeofW(StgWeak)));
2844 SET_HDR(w, &WEAK_info, CCCS);
2846 w->value = PopCPtr();
2847 w->finaliser = PopCPtr();
2848 w->link = weak_ptr_list;
2850 IF_DEBUG(weak, fprintf(stderr,"New weak pointer at %p\n",w));
2851 PushPtr(stgCast(StgPtr,w));
2856 StgWeak *w = stgCast(StgWeak*,PopPtr());
2857 if (w->header.info == &WEAK_info) {
2858 PushCPtr(w->value); /* last result */
2859 PushTaggedInt(1); /* first result */
2861 PushPtr(stgCast(StgPtr,w));
2862 /* ToDo: error thunk would be better */
2867 #endif /* PROVIDE_WEAK */
2869 case i_makeStablePtr:
2871 StgPtr p = PopPtr();
2872 StgStablePtr sp = getStablePtr ( p );
2873 PushTaggedStablePtr(sp);
2876 case i_deRefStablePtr:
2879 StgStablePtr sp = PopTaggedStablePtr();
2880 p = deRefStablePtr(sp);
2884 case i_freeStablePtr:
2886 StgStablePtr sp = PopTaggedStablePtr();
2891 case i_createAdjThunkARCH:
2893 StgStablePtr stableptr = PopTaggedStablePtr();
2894 StgAddr typestr = PopTaggedAddr();
2895 StgChar callconv = PopTaggedChar();
2896 StgAddr adj_thunk = createAdjThunk(stableptr,typestr,callconv);
2897 PushTaggedAddr(adj_thunk);
2903 StgInt n = prog_argc;
2909 StgInt n = PopTaggedInt();
2910 StgAddr a = (StgAddr)prog_argv[n];
2915 #ifdef PROVIDE_CONCURRENT
2918 StgClosure* c = PopCPtr();
2919 StgTSO* t = createGenThread(RtsFlags.GcFlags.initialStkSize,c);
2920 PushPtr(stgCast(StgPtr,t));
2922 /* switch at the earliest opportunity */
2924 /* but don't automatically switch to GHC - or you'll waste your
2925 * time slice switching back.
2927 * Actually, there's more to it than that: the default
2928 * (ThreadEnterGHC) causes the thread to crash - don't
2929 * understand why. - ADR
2931 t->whatNext = ThreadEnterHugs;
2936 StgTSO* tso = stgCast(StgTSO*,PopPtr());
2938 if (tso == CurrentTSO) { /* suicide */
2939 *return2 = ThreadFinished;
2940 return (void*)(1+(NULL));
2945 { /* identical to i_sameRef */
2946 StgPtr x = PopPtr();
2947 StgPtr y = PopPtr();
2948 PushTaggedBool(x==y);
2953 StgMVar *mvar = stgCast(StgMVar*,allocate(sizeofW(StgMVar)));
2954 SET_INFO(mvar,&EMPTY_MVAR_info);
2955 mvar->head = mvar->tail = EndTSOQueue;
2956 /* ToDo: this is a little strange */
2957 mvar->value = stgCast(StgClosure*,&END_TSO_QUEUE_closure);
2958 PushPtr(stgCast(StgPtr,mvar));
2963 ToDo: another way out of the problem might be to add an explicit
2964 continuation to primTakeMVar: takeMVar v = primTakeMVar v takeMVar.
2965 The problem with this plan is that now I dont know how much to chop
2970 StgMVar *mvar = stgCast(StgMVar*,PopPtr());
2971 /* If the MVar is empty, put ourselves
2972 * on its blocking queue, and wait
2973 * until we're woken up.
2975 if (GET_INFO(mvar) != &FULL_MVAR_info) {
2976 if (mvar->head == EndTSOQueue) {
2977 mvar->head = CurrentTSO;
2979 mvar->tail->link = CurrentTSO;
2981 CurrentTSO->link = EndTSOQueue;
2982 mvar->tail = CurrentTSO;
2984 /* Hack, hack, hack.
2985 * When we block, we push a restart closure
2986 * on the stack - but which closure?
2987 * We happen to know that the BCO we're
2988 * executing looks like this:
2997 * 14: ALLOC_CONSTR 0x8213a80
3007 * so we rearrange the stack to look the
3008 * way it did when we entered this BCO
3010 * What a disgusting hack!
3016 *return2 = ThreadBlocked;
3017 return (void*)(1+(NULL));
3020 PushCPtr(mvar->value);
3021 SET_INFO(mvar,&EMPTY_MVAR_info);
3022 /* ToDo: this is a little strange */
3023 mvar->value = (StgClosure*)&END_TSO_QUEUE_closure;
3030 StgMVar* mvar = stgCast(StgMVar*,PopPtr());
3031 StgClosure* value = PopCPtr();
3032 if (GET_INFO(mvar) == &FULL_MVAR_info) {
3033 return (raisePrim("putMVar {full MVar}"));
3035 /* wake up the first thread on the
3036 * queue, it will continue with the
3037 * takeMVar operation and mark the
3040 StgTSO* tso = mvar->head;
3041 SET_INFO(mvar,&FULL_MVAR_info);
3042 mvar->value = value;
3043 if (tso != EndTSOQueue) {
3044 PUSH_ON_RUN_QUEUE(tso);
3045 mvar->head = tso->link;
3046 tso->link = EndTSOQueue;
3047 if (mvar->head == EndTSOQueue) {
3048 mvar->tail = EndTSOQueue;
3052 /* yield for better communication performance */
3059 /* As PrimOps.h says: Hmm, I'll think about these later. */
3062 #endif /* PROVIDE_CONCURRENT */
3063 case i_ccall_ccall_Id:
3064 case i_ccall_ccall_IO:
3065 case i_ccall_stdcall_Id:
3066 case i_ccall_stdcall_IO:
3069 CFunDescriptor* descriptor = PopTaggedAddr();
3070 void (*funPtr)(void) = PopTaggedAddr();
3071 char cc = (primop2code == i_ccall_stdcall_Id ||
3072 primop2code == i_ccall_stdcall_IO)
3074 r = ccall(descriptor,funPtr,bco,cc);
3077 return makeErrorCall(
3078 "unhandled type or too many args/results in ccall");
3080 barf("ccall not configured correctly for this platform");
3081 barf("unknown return code from ccall");
3084 barf("Unrecognised primop2");
3090 /* -----------------------------------------------------------------------------
3091 * ccall support code:
3092 * marshall moves args from C stack to Haskell stack
3093 * unmarshall moves args from Haskell stack to C stack
3094 * argSize calculates how much space you need on the C stack
3095 * ---------------------------------------------------------------------------*/
3097 /* Pop arguments off the C stack and Push them onto the Hugs stack.
3098 * Used when preparing for C calling Haskell or in response to
3099 * Haskell calling C.
3101 nat marshall(char arg_ty, void* arg)
3105 PushTaggedInt(*((int*)arg));
3106 return ARG_SIZE(INT_TAG);
3107 #ifdef TODO_STANDALONE_INTEGER
3109 PushTaggedInteger(*((mpz_ptr*)arg));
3110 return ARG_SIZE(INTEGER_TAG);
3113 PushTaggedWord(*((unsigned int*)arg));
3114 return ARG_SIZE(WORD_TAG);
3116 PushTaggedChar(*((char*)arg));
3117 return ARG_SIZE(CHAR_TAG);
3119 PushTaggedFloat(*((float*)arg));
3120 return ARG_SIZE(FLOAT_TAG);
3122 PushTaggedDouble(*((double*)arg));
3123 return ARG_SIZE(DOUBLE_TAG);
3125 PushTaggedAddr(*((void**)arg));
3126 return ARG_SIZE(ADDR_TAG);
3128 PushTaggedStablePtr(*((StgStablePtr*)arg));
3129 return ARG_SIZE(STABLE_TAG);
3130 #ifdef PROVIDE_FOREIGN
3132 /* Not allowed in this direction - you have to
3133 * call makeForeignPtr explicitly
3135 barf("marshall: ForeignPtr#\n");
3140 /* Not allowed in this direction */
3141 barf("marshall: [Mutable]ByteArray#\n");
3144 barf("marshall: unrecognised arg type %d\n",arg_ty);
3149 /* Pop arguments off the Hugs stack and Push them onto the C stack.
3150 * Used when preparing for Haskell calling C or in response to
3151 * C calling Haskell.
3153 nat unmarshall(char res_ty, void* res)
3157 *((int*)res) = PopTaggedInt();
3158 return ARG_SIZE(INT_TAG);
3159 #ifdef TODO_STANDALONE_INTEGER
3161 *((mpz_ptr*)res) = PopTaggedInteger();
3162 return ARG_SIZE(INTEGER_TAG);
3165 *((unsigned int*)res) = PopTaggedWord();
3166 return ARG_SIZE(WORD_TAG);
3168 *((int*)res) = PopTaggedChar();
3169 return ARG_SIZE(CHAR_TAG);
3171 *((float*)res) = PopTaggedFloat();
3172 return ARG_SIZE(FLOAT_TAG);
3174 *((double*)res) = PopTaggedDouble();
3175 return ARG_SIZE(DOUBLE_TAG);
3177 *((void**)res) = PopTaggedAddr();
3178 return ARG_SIZE(ADDR_TAG);
3180 *((StgStablePtr*)res) = PopTaggedStablePtr();
3181 return ARG_SIZE(STABLE_TAG);
3182 #ifdef PROVIDE_FOREIGN
3185 StgForeignObj *result = stgCast(StgForeignObj*,PopPtr());
3186 *((void**)res) = result->data;
3187 return sizeofW(StgPtr);
3193 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
3194 *((void**)res) = stgCast(void*,&(arr->payload));
3195 return sizeofW(StgPtr);
3198 barf("unmarshall: unrecognised result type %d\n",res_ty);
3202 nat argSize( const char* ks )
3205 for( ; *ks != '\0'; ++ks) {
3208 sz += sizeof(StgWord) * ARG_SIZE(INT_TAG);
3210 #ifdef TODO_STANDALONE_INTEGER
3212 sz += sizeof(StgWord) * ARG_SIZE(INTEGER_TAG);
3216 sz += sizeof(StgWord) * ARG_SIZE(WORD_TAG);
3219 sz += sizeof(StgWord) * ARG_SIZE(CHAR_TAG);
3222 sz += sizeof(StgWord) * ARG_SIZE(FLOAT_TAG);
3225 sz += sizeof(StgWord) * ARG_SIZE(DOUBLE_TAG);
3228 sz += sizeof(StgWord) * ARG_SIZE(ADDR_TAG);
3231 sz += sizeof(StgWord) * ARG_SIZE(STABLE_TAG);
3233 #ifdef PROVIDE_FOREIGN
3238 sz += sizeof(StgPtr);
3241 barf("argSize: unrecognised result type %d\n",*ks);
3249 /* -----------------------------------------------------------------------------
3250 * encode/decode Float/Double code for standalone Hugs
3251 * Code based on the HBC code (lib/fltcode.c) and more recently GHC
3252 * (ghc/rts/StgPrimFloat.c)
3253 * ---------------------------------------------------------------------------*/
3255 #ifdef STANDALONE_INTEGER
3257 #if IEEE_FLOATING_POINT
3258 #define MY_DMINEXP ((DBL_MIN_EXP) - (DBL_MANT_DIG) - 1)
3259 /* DMINEXP is defined in values.h on Linux (for example) */
3260 #define DHIGHBIT 0x00100000
3261 #define DMSBIT 0x80000000
3263 #define MY_FMINEXP ((FLT_MIN_EXP) - (FLT_MANT_DIG) - 1)
3264 #define FHIGHBIT 0x00800000
3265 #define FMSBIT 0x80000000
3267 #error The following code doesnt work in a non-IEEE FP environment
3270 #ifdef WORDS_BIGENDIAN
3279 StgDouble B__encodeDouble (B* s, I_ e) /* result = s * 2^e */
3284 /* Convert a B to a double; knows a lot about internal rep! */
3285 for(r = 0.0, i = s->used-1; i >= 0; i--)
3286 r = (r * B_BASE_FLT) + s->stuff[i];
3288 /* Now raise to the exponent */
3289 if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
3292 /* handle the sign */
3293 if (s->sign < 0) r = -r;
3300 #if ! FLOATS_AS_DOUBLES
3301 StgFloat B__encodeFloat (B* s, I_ e) /* result = s * 2^e */
3306 /* Convert a B to a float; knows a lot about internal rep! */
3307 for(r = 0.0, i = s->used-1; i >= 0; i--)
3308 r = (r * B_BASE_FLT) + s->stuff[i];
3310 /* Now raise to the exponent */
3311 if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
3314 /* handle the sign */
3315 if (s->sign < 0) r = -r;
3319 #endif /* FLOATS_AS_DOUBLES */
3323 /* This only supports IEEE floating point */
3324 void B__decodeDouble (B* man, I_* exp, StgDouble dbl)
3326 /* Do some bit fiddling on IEEE */
3327 nat low, high; /* assuming 32 bit ints */
3329 union { double d; int i[2]; } u; /* assuming 32 bit ints, 64 bit double */
3331 u.d = dbl; /* grab chunks of the double */
3335 ASSERT(B_BASE == 256);
3337 /* Assume that the supplied B is the right size */
3340 if (low == 0 && (high & ~DMSBIT) == 0) {
3341 man->sign = man->used = 0;
3346 iexp = ((high >> 20) & 0x7ff) + MY_DMINEXP;
3350 if (iexp != MY_DMINEXP) /* don't add hidden bit to denorms */
3354 /* A denorm, normalize the mantissa */
3355 while (! (high & DHIGHBIT)) {
3365 man->stuff[7] = (((W_)high) >> 24) & 0xff;
3366 man->stuff[6] = (((W_)high) >> 16) & 0xff;
3367 man->stuff[5] = (((W_)high) >> 8) & 0xff;
3368 man->stuff[4] = (((W_)high) ) & 0xff;
3370 man->stuff[3] = (((W_)low) >> 24) & 0xff;
3371 man->stuff[2] = (((W_)low) >> 16) & 0xff;
3372 man->stuff[1] = (((W_)low) >> 8) & 0xff;
3373 man->stuff[0] = (((W_)low) ) & 0xff;
3375 if (sign < 0) man->sign = -1;
3377 do_renormalise(man);
3381 #if ! FLOATS_AS_DOUBLES
3382 void B__decodeFloat (B* man, I_* exp, StgFloat flt)
3384 /* Do some bit fiddling on IEEE */
3385 int high, sign; /* assuming 32 bit ints */
3386 union { float f; int i; } u; /* assuming 32 bit float and int */
3388 u.f = flt; /* grab the float */
3391 ASSERT(B_BASE == 256);
3393 /* Assume that the supplied B is the right size */
3396 if ((high & ~FMSBIT) == 0) {
3397 man->sign = man->used = 0;
3402 *exp = ((high >> 23) & 0xff) + MY_FMINEXP;
3406 if (*exp != MY_FMINEXP) /* don't add hidden bit to denorms */
3410 /* A denorm, normalize the mantissa */
3411 while (! (high & FHIGHBIT)) {
3416 man->stuff[3] = (((W_)high) >> 24) & 0xff;
3417 man->stuff[2] = (((W_)high) >> 16) & 0xff;
3418 man->stuff[1] = (((W_)high) >> 8) & 0xff;
3419 man->stuff[0] = (((W_)high) ) & 0xff;
3421 if (sign < 0) man->sign = -1;
3423 do_renormalise(man);
3426 #endif /* FLOATS_AS_DOUBLES */
3428 #endif /* STANDALONE_INTEGER */
3430 #endif /* INTERPRETER */