2 /* -----------------------------------------------------------------------------
5 * Copyright (c) 1994-1998.
7 * $RCSfile: Evaluator.c,v $
9 * $Date: 1999/07/06 16:40:24 $
10 * ---------------------------------------------------------------------------*/
20 #include "SchedAPI.h" /* for createGenThread */
21 #include "Schedule.h" /* for context_switch */
23 #include "Bytecodes.h"
24 #include "Assembler.h" /* for CFun stuff */
25 #include "ForeignCall.h"
26 #include "StablePriv.h"
27 #include "PrimOps.h" /* for __{encode,decode}{Float,Double} */
28 #include "Evaluator.h"
32 #include "Disassembler.h"
38 #include <math.h> /* These are for primops */
39 #include <limits.h> /* These are for primops */
40 #include <float.h> /* These are for primops */
42 #include <ieee754.h> /* These are for primops */
45 #ifdef STANDALONE_INTEGER
46 #include "sainteger.h"
48 #error Non-standalone integer not yet supported
52 /* An incredibly useful abbreviation.
53 * Interestingly, there are some uses of END_TSO_QUEUE_closure that
54 * can't use it because they use the closure at type StgClosure* or
55 * even StgPtr*. I suspect they should be changed. -- ADR
57 #define EndTSOQueue stgCast(StgTSO*,(void*)&END_TSO_QUEUE_closure)
59 /* These macros are rather delicate - read a good ANSI C book carefully
63 #define mycat(x,y) x##y
64 #define mycat2(x,y) mycat(x,y)
65 #define mycat3(x,y,z) mycat2(x,mycat2(y,z))
67 #if defined(__GNUC__) && !defined(DEBUG)
68 #define USE_GCC_LABELS 1
70 #define USE_GCC_LABELS 0
73 /* --------------------------------------------------------------------------
74 * Crude profiling stuff (mainly to assess effect of optimiser)
75 * ------------------------------------------------------------------------*/
77 #ifdef CRUDE_PROFILING
86 struct { int /*StgVar*/ who;
94 CPRecord cpTab[M_CPTAB];
101 for (i = 0; i < M_CPTAB; i++)
102 cpTab[i].who = CP_NIL;
106 void cp_enter ( StgBCO* b )
110 int /*StgVar*/ v = b->stgexpr;
111 if ((void*)v == NULL) return;
120 h = (-v) % M_CPTAB; else
123 assert (h >= 0 && h < M_CPTAB);
124 while (cpTab[h].who != v && cpTab[h].who != CP_NIL) {
125 h++; if (h == M_CPTAB) h = 0;
128 if (cpTab[cpCurr].who == CP_NIL) {
129 cpTab[cpCurr].who = v;
130 if (!is_ret_cont) cpTab[cpCurr].enters = 1;
131 cpTab[cpCurr].bytes = cpTab[cpCurr].insns = 0;
133 if (cpInUse * 2 > M_CPTAB) {
134 fprintf(stderr, "\nCRUDE_PROFILING hash table is too full\n" );
138 if (!is_ret_cont) cpTab[cpCurr].enters++;
144 void cp_bill_words ( int nw )
146 if (cpCurr == CP_NIL) return;
147 cpTab[cpCurr].bytes += sizeof(StgWord)*nw;
151 void cp_bill_insns ( int ni )
153 if (cpCurr == CP_NIL) return;
154 cpTab[cpCurr].insns += ni;
158 static double percent ( double a, double b )
160 return (100.0 * a) / b;
164 void cp_show ( void )
166 int i, j, max, maxN, totE, totB, totI, cumE, cumB, cumI;
169 if (cpInUse == -1) return;
171 fflush(stdout);fflush(stderr);
174 totE = totB = totI = 0;
175 for (i = 0; i < M_CPTAB; i++) {
176 cpTab[i].twho = cpTab[i].who;
177 if (cpTab[i].who != CP_NIL) {
178 totE += cpTab[i].enters;
179 totB += cpTab[i].bytes;
180 totI += cpTab[i].insns;
185 "%6d (%7.3f M) enters, "
186 "%6d (%7.3f M) insns, "
187 "%6d (%7.3f M) bytes\n\n",
188 totE, totE/1000000.0, totI, totI/1000000.0, totB, totB/1000000.0 );
190 cumE = cumB = cumI = 0;
191 for (j = 0; j < 32; j++) {
194 for (i = 0; i < M_CPTAB; i++)
195 if (cpTab[i].who != CP_NIL &&
196 cpTab[i].enters > maxN) {
197 maxN = cpTab[i].enters;
200 if (max == -1) break;
202 cumE += cpTab[max].enters;
203 cumB += cpTab[max].bytes;
204 cumI += cpTab[max].insns;
206 strcpy(nm, maybeName(cpTab[max].who));
207 if (strcmp(nm, "(unknown)")==0)
208 sprintf ( nm, "id%d", -cpTab[max].who);
210 printf ( "%20s %7d es (%4.1f%%, %4.1f%% c) "
211 "%7d bs (%4.1f%%, %4.1f%% c) "
212 "%7d is (%4.1f%%, %4.1f%% c)\n",
214 cpTab[max].enters, percent(cpTab[max].enters,totE), percent(cumE,totE),
215 cpTab[max].bytes, percent(cpTab[max].bytes,totB), percent(cumB,totB),
216 cpTab[max].insns, percent(cpTab[max].insns,totI), percent(cumI,totI)
219 cpTab[max].twho = cpTab[max].who;
220 cpTab[max].who = CP_NIL;
223 for (i = 0; i < M_CPTAB; i++)
224 cpTab[i].who = cpTab[i].twho;
232 /* --------------------------------------------------------------------------
233 * Hugs Hooks - a bit of a hack
234 * ------------------------------------------------------------------------*/
236 /* A total hack -- this code has an endian dependancy and only works
237 on little-endian archs.
239 void setRtsFlags( int x );
240 void setRtsFlags( int x )
242 *(int*)(&(RtsFlags.DebugFlags)) = x;
245 /* --------------------------------------------------------------------------
248 * ToDo: figure out why these are being used and crush them!
249 * ------------------------------------------------------------------------*/
251 void OnExitHook (void)
254 void StackOverflowHook (unsigned long stack_size)
256 fprintf(stderr,"Stack Overflow\n");
259 void OutOfHeapHook (unsigned long request_size, unsigned long heap_size)
261 fprintf(stderr,"Out Of Heap\n");
264 void MallocFailHook (unsigned long request_size /* in bytes */, char *msg)
266 fprintf(stderr,"Malloc Fail\n");
269 void defaultsHook (void)
275 /* --------------------------------------------------------------------------
276 * Entering-objects and bytecode interpreter part of evaluator
277 * ------------------------------------------------------------------------*/
279 /* The primop (and all other) parts of this evaluator operate upon the
280 machine state which lives in MainRegTable. enter is different:
281 to make its closure- and bytecode-interpreting loops go fast, some of that
282 state is pulled out into local vars (viz, registers, if we are lucky).
283 That means that we need to save(load) the local state at every exit(reentry)
284 into enter. That is, around every procedure call it makes. Blargh!
285 If you modify this code, __be warned__ it will fail in mysterious ways if
286 you fail to preserve this property.
288 Currently the pulled-out state is Sp in xSp, Su in xSu and SpLim in xSpLim.
289 The SSS macros saves the state back in MainRegTable, and LLL loads it from
290 MainRegTable. RETURN(v) does SSS and then returns v; all exits should
291 be via RETURN and not plain return.
293 Since xSp, xSu and xSpLim are local vars in enter, they are not visible
294 in procedures called from enter. To fix this, either (1) turn the
295 procedures into macros, so they get copied inline, or (2) bracket
296 the procedure call with SSS and LLL so that the local and global
297 machine states are synchronised for the duration of the call.
301 /* Forward decls ... */
302 static void* enterBCO_primop1 ( int );
303 static void* enterBCO_primop2 ( int , int* /*StgThreadReturnCode* */ );
304 static inline void PopUpdateFrame ( StgClosure* obj );
305 static inline void PopCatchFrame ( void );
306 static inline void PopSeqFrame ( void );
307 static inline void PopStopFrame( StgClosure* obj );
308 static inline void PushTaggedRealWorld( void );
309 static inline void PushTaggedInteger ( mpz_ptr );
310 static inline StgPtr grabHpUpd( nat size );
311 static inline StgPtr grabHpNonUpd( nat size );
312 static StgClosure* raiseAnError ( StgClosure* errObj );
314 static int enterCountI = 0;
316 #ifdef STANDALONE_INTEGER
317 StgDouble B__encodeDouble (B* s, I_ e);
318 void B__decodeDouble (B* man, I_* exp, StgDouble dbl);
319 #if ! FLOATS_AS_DOUBLES
320 StgFloat B__encodeFloat (B* s, I_ e);
321 void B__decodeFloat (B* man, I_* exp, StgFloat flt);
322 StgPtr CreateByteArrayToHoldInteger ( int );
323 B* IntegerInsideByteArray ( StgPtr );
324 void SloppifyIntegerEnd ( StgPtr );
331 /* Macros to save/load local state. */
333 #define SSS { tSp=Sp = xSp; tSu=Su = xSu; tSpLim=SpLim = xSpLim; }
334 #define LLL { tSp=xSp = Sp; tSu=xSu = Su; tSpLim=xSpLim = SpLim; }
336 #define SSS { Sp = xSp; Su = xSu; SpLim = xSpLim; }
337 #define LLL { xSp = Sp; xSu = Su; xSpLim = SpLim; }
340 #define RETURN(vvv) { StgThreadReturnCode retVal=(vvv); SSS; return retVal; }
343 /* Macros to operate directly on the pulled-out machine state.
344 These mirror some of the small procedures used in the primop code
345 below, except you have to be careful about side effects,
346 ie xPushPtr(xStackPtr(n)) won't work! It certainly isn't the
347 same as PushPtr(StackPtr(n)). Also note that (1) some of
348 the macros, in particular xPopTagged*, do not make the tag
349 sanity checks that their non-x cousins do, and (2) some of
350 the macros depend critically on the semantics of C comma
351 expressions to work properly
353 #define xPushPtr(ppp) { xSp--; *xSp=(StgWord)(ppp); }
354 #define xPopPtr() ((StgPtr)(*xSp++))
356 #define xPushCPtr(ppp) { xSp--; *xSp=(StgWord)(ppp); }
357 #define xPopCPtr() ((StgClosure*)(*xSp++))
359 #define xPushWord(ppp) { xSp--; *xSp=(StgWord)(ppp); }
360 #define xPopWord() ((StgWord)(*xSp++))
362 #define xStackPtr(nnn) ((StgPtr)(*(xSp+(nnn))))
363 #define xStackWord(nnn) ((StgWord)(*(xSp+(nnn))))
364 #define xSetStackWord(iii,www) xSp[iii]=(StgWord)(www)
366 #define xPushTag(ttt) { xSp--; *xSp=(StgWord)(ttt); }
367 #define xPopTag(ttt) { StackTag t = (StackTag)(*xSp++); \
370 #define xPushTaggedInt(xxx) { xSp -= sizeofW(StgInt); \
371 *xSp = (xxx); xPushTag(INT_TAG); }
372 #define xTaggedStackInt(iii) ((StgInt)(*(xSp+1+(iii))))
373 #define xPopTaggedInt() ((xSp++,xSp+=sizeofW(StgInt), \
374 (StgInt)(*(xSp-sizeofW(StgInt)))))
376 #define xPushTaggedWord(xxx) { xSp -= sizeofW(StgWord); \
377 *xSp = (xxx); xPushTag(WORD_TAG); }
378 #define xTaggedStackWord(iii) ((StgWord)(*(xSp+1+(iii))))
379 #define xPopTaggedWord() ((xSp++,xSp+=sizeofW(StgWord), \
380 (StgWord)(*(xSp-sizeofW(StgWord)))))
382 #define xPushTaggedAddr(xxx) { xSp -= sizeofW(StgAddr); \
383 *xSp = (StgWord)(xxx); xPushTag(ADDR_TAG); }
384 #define xTaggedStackAddr(iii) ((StgAddr)(*(xSp+1+(iii))))
385 #define xPopTaggedAddr() ((xSp++,xSp+=sizeofW(StgAddr), \
386 (StgAddr)(*(xSp-sizeofW(StgAddr)))))
388 #define xPushTaggedChar(xxx) { xSp -= sizeofW(StgChar); \
389 *xSp = (StgWord)(xxx); xPushTag(CHAR_TAG); }
390 #define xTaggedStackChar(iii) ((StgChar)(*(xSp+1+(iii))))
391 #define xPopTaggedChar() ((xSp++,xSp+=sizeofW(StgChar), \
392 (StgChar)(*(xSp-sizeofW(StgChar)))))
394 #define xPushTaggedFloat(xxx) { xSp -= sizeofW(StgFloat); \
395 ASSIGN_FLT(xSp,xxx); xPushTag(FLOAT_TAG); }
396 #define xTaggedStackFloat(iii) PK_FLT(xSp+1+(iii))
397 #define xPopTaggedFloat() ((xSp++,xSp+=sizeofW(StgFloat), \
398 PK_FLT(xSp-sizeofW(StgFloat))))
400 #define xPushTaggedDouble(xxx) { xSp -= sizeofW(StgDouble); \
401 ASSIGN_DBL(xSp,xxx); xPushTag(DOUBLE_TAG); }
402 #define xTaggedStackDouble(iii) PK_DBL(xSp+1+(iii))
403 #define xPopTaggedDouble() ((xSp++,xSp+=sizeofW(StgDouble), \
404 PK_DBL(xSp-sizeofW(StgDouble))))
407 #define xPopUpdateFrame(ooo) \
409 /* NB: doesn't assume that Sp == Su */ \
410 IF_DEBUG(evaluator, \
411 fprintf(stderr, "Updating "); \
412 printPtr(stgCast(StgPtr,xSu->updatee)); \
413 fprintf(stderr, " with "); \
415 fprintf(stderr,"xSp = %p\txSu = %p\n\n", xSp, xSu); \
417 UPD_IND(xSu->updatee,ooo); \
418 xSp = stgCast(StgStackPtr,xSu) + sizeofW(StgUpdateFrame); \
424 /* Instruction stream macros */
425 #define BCO_INSTR_8 *bciPtr++
426 #define BCO_INSTR_16 ((bciPtr += 2, (*(bciPtr-2) << 8) + *(bciPtr-1)))
427 #define PC (bciPtr - &(bcoInstr(bco,0)))
430 StgThreadReturnCode enter( StgClosure* obj0 )
432 /* use of register here is primarily to make it clear to compilers
433 that these entities are non-aliasable.
435 register StgPtr xSp; /* local state -- stack pointer */
436 register StgUpdateFrame* xSu; /* local state -- frame pointer */
437 register StgPtr xSpLim; /* local state -- stack lim pointer */
438 register StgClosure* obj; /* object currently under evaluation */
439 char eCount; /* enter counter, for context switching */
442 /* use the t values to check that Su/Sp/SpLim do not change unexpectedly */
443 StgPtr tSp = Sp; StgUpdateFrame* tSu = Su; StgPtr tSpLim = SpLim;
449 /* Load the local state from global state, and Party On, Dudes! */
450 /* From here onwards, we operate with the local state and
451 save/reload it as necessary.
460 assert(SpLim == tSpLim);
464 ASSERT(xSpLim <= xSp && xSp <= stgCast(StgPtr,xSu));
466 "\n---------------------------------------------------------------\n");
467 fprintf(stderr,"(%d) Entering: ",enterCountI); printObj(obj);
468 fprintf(stderr,"xSp = %p\txSu = %p\n", xSp, xSu);
469 fprintf(stderr, "\n" );
470 printStack(xSp,CurrentTSO->stack+CurrentTSO->stack_size,xSu);
471 fprintf(stderr, "\n\n");
481 if (context_switch) {
482 xPushCPtr(obj); /* code to restart with */
483 RETURN(ThreadYielding);
487 switch ( get_itbl(obj)->type ) {
489 barf("Invalid object %p",obj);
493 /* ---------------------------------------------------- */
494 /* Start of the bytecode evaluator */
495 /* ---------------------------------------------------- */
498 # define Ins(x) &&l##x
499 static void *labs[] = { INSTRLIST };
501 # define LoopTopLabel
502 # define Case(x) l##x
503 # define Continue goto *labs[BCO_INSTR_8]
504 # define Dispatch Continue;
507 # define LoopTopLabel insnloop:
508 # define Case(x) case x
509 # define Continue goto insnloop
510 # define Dispatch switch (BCO_INSTR_8) {
511 # define EndDispatch }
514 register StgWord8* bciPtr; /* instruction pointer */
515 register StgBCO* bco = (StgBCO*)obj;
518 /* Don't need to SSS ... LLL around doYouWantToGC */
519 wantToGC = doYouWantToGC();
521 xPushCPtr((StgClosure*)bco); /* code to restart with */
522 RETURN(HeapOverflow);
530 bciPtr = &(bcoInstr(bco,0));
534 ASSERT(PC < bco->n_instrs);
536 fprintf(stderr,"Sp = %p\tSu = %p\tpc = %d\t", xSp, xSu, PC);
540 fprintf(stderr,"\n");
541 for (i = 8; i >= 0; i--)
542 fprintf(stderr, "%d %p\n", i, (StgPtr)(*(Sp+i)));
544 fprintf(stderr,"\n");
549 SSS; cp_bill_insns(1); LLL;
554 Case(i_INTERNAL_ERROR):
555 barf("INTERNAL_ERROR at %p:%d",bco,PC-1);
557 barf("PANIC at %p:%d",bco,PC-1);
561 if (xSp - n < xSpLim) {
562 xPushCPtr((StgClosure*)bco); /* code to restart with */
563 RETURN(StackOverflow);
570 if ((StgPtr*)(xSp + n) > (StgPtr*)xSu) {
571 StgWord words = (P_)xSu - xSp;
573 /* first build a PAP */
574 ASSERT((P_)xSu >= xSp); /* was (words >= 0) but that's always true */
575 if (words == 0) { /* optimisation */
576 /* Skip building the PAP and update with an indirection. */
579 /* In the evaluator, we avoid the need to do
580 * a heap check here by including the size of
581 * the PAP in the heap check we performed
582 * when we entered the BCO.
586 SSS; pap = (StgPAP*)grabHpNonUpd(PAP_sizeW(words)); LLL;
587 SET_HDR(pap,&PAP_info,CC_pap);
590 for (i = 0; i < (I_)words; ++i) {
591 payloadWord(pap,i) = xSp[i];
594 obj = stgCast(StgClosure*,pap);
597 /* now deal with "update frame" */
598 /* as an optimisation, we process all on top of stack */
599 /* instead of just the top one */
600 ASSERT(xSp==(P_)xSu);
602 switch (get_itbl(xSu)->type) {
604 /* Hit a catch frame during an arg satisfaction check,
605 * so the thing returning (1) has not thrown an
606 * exception, and (2) is of functional type. Just
607 * zap the catch frame and carry on down the stack
608 * (looking for more arguments, basically).
610 SSS; PopCatchFrame(); LLL;
613 xPopUpdateFrame(obj);
616 SSS; PopStopFrame(obj); LLL;
617 RETURN(ThreadFinished);
619 SSS; PopSeqFrame(); LLL;
620 ASSERT(xSp != (P_)xSu);
621 /* Hit a SEQ frame during an arg satisfaction check.
622 * So now return to bco_info which is under the
623 * SEQ frame. The following code is copied from a
624 * case RET_BCO further down. (The reason why we're
625 * here is that something of functional type has
626 * been seq-d on, and we're now returning to the
627 * algebraic-case-continuation which forced the
628 * evaluation in the first place.)
640 barf("Invalid update frame during argcheck");
642 } while (xSp==(P_)xSu);
650 int words = BCO_INSTR_8;
651 SSS; p = grabHpUpd(AP_sizeW(words)); LLL;
655 Case(i_ALLOC_CONSTR):
658 StgInfoTable* info = bcoConstAddr(bco,BCO_INSTR_8);
659 SSS; p = grabHpNonUpd(sizeW_fromITBL(info)); LLL;
660 SET_HDR((StgClosure*)p,info,??);
666 int x = BCO_INSTR_8; /* ToDo: Word not Int! */
668 StgAP_UPD* o = stgCast(StgAP_UPD*,xStackPtr(x));
669 SET_HDR(o,&AP_UPD_info,??);
671 o->fun = stgCast(StgClosure*,xPopPtr());
672 for(x=0; x < y; ++x) {
673 payloadWord(o,x) = xPopWord();
676 fprintf(stderr,"\tBuilt ");
678 printObj(stgCast(StgClosure*,o));
689 o = stgCast(StgAP_UPD*,xStackPtr(x));
690 SET_HDR(o,&AP_UPD_info,??);
692 o->fun = stgCast(StgClosure*,xPopPtr());
693 for(x=0; x < y; ++x) {
694 payloadWord(o,x) = xPopWord();
697 fprintf(stderr,"\tBuilt ");
699 printObj(stgCast(StgClosure*,o));
708 StgPAP* o = stgCast(StgPAP*,xStackPtr(x));
709 SET_HDR(o,&PAP_info,??);
711 o->fun = stgCast(StgClosure*,xPopPtr());
712 for(x=0; x < y; ++x) {
713 payloadWord(o,x) = xPopWord();
716 fprintf(stderr,"\tBuilt ");
718 printObj(stgCast(StgClosure*,o));
725 int offset = BCO_INSTR_8;
726 StgClosure* o = stgCast(StgClosure*,xStackPtr(offset));
727 const StgInfoTable* info = get_itbl(o);
728 nat p = info->layout.payload.ptrs;
729 nat np = info->layout.payload.nptrs;
731 for(i=0; i < p; ++i) {
732 payloadCPtr(o,i) = xPopCPtr();
734 for(i=0; i < np; ++i) {
735 payloadWord(o,p+i) = 0xdeadbeef;
738 fprintf(stderr,"\tBuilt ");
740 printObj(stgCast(StgClosure*,o));
747 int offset = BCO_INSTR_16;
748 StgClosure* o = stgCast(StgClosure*,xStackPtr(offset));
749 const StgInfoTable* info = get_itbl(o);
750 nat p = info->layout.payload.ptrs;
751 nat np = info->layout.payload.nptrs;
753 for(i=0; i < p; ++i) {
754 payloadCPtr(o,i) = xPopCPtr();
756 for(i=0; i < np; ++i) {
757 payloadWord(o,p+i) = 0xdeadbeef;
760 fprintf(stderr,"\tBuilt ");
762 printObj(stgCast(StgClosure*,o));
771 ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
772 /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
774 xSetStackWord(x+y,xStackWord(x));
784 ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
785 /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
787 xSetStackWord(x+y,xStackWord(x));
799 xPushPtr(bcoConstPtr(bco,BCO_INSTR_8));
800 xPushPtr(stgCast(StgPtr,&ret_bco_info));
805 int tag = BCO_INSTR_8;
806 StgWord offset = BCO_INSTR_16;
807 if (constrTag(stgCast(StgClosure*,xStackPtr(0))) != tag) {
814 StgClosure* o = stgCast(StgClosure*,xStackPtr(0));
815 const StgInfoTable* itbl = get_itbl(o);
816 int i = itbl->layout.payload.ptrs;
817 ASSERT( itbl->type == CONSTR
818 || itbl->type == CONSTR_STATIC
819 || itbl->type == CONSTR_NOCAF_STATIC
820 || itbl->type == CONSTR_1_0
821 || itbl->type == CONSTR_0_1
822 || itbl->type == CONSTR_2_0
823 || itbl->type == CONSTR_1_1
824 || itbl->type == CONSTR_0_2
827 xPushCPtr(payloadCPtr(o,i));
833 int n = BCO_INSTR_16;
834 StgPtr p = xStackPtr(n);
840 StgPtr p = xStackPtr(BCO_INSTR_8);
846 xPushPtr(stgCast(StgPtr,bcoConstPtr(bco,BCO_INSTR_8)));
851 int n = BCO_INSTR_16;
852 xPushPtr(stgCast(StgPtr,bcoConstPtr(bco,n)));
857 SSS; PushTaggedRealWorld(); LLL;
862 StgInt i = xTaggedStackInt(BCO_INSTR_8);
868 xPushTaggedInt(bcoConstInt(bco,BCO_INSTR_8));
874 SSS; o = (StgClosure*)grabHpNonUpd(Izh_sizeW); LLL;
875 SET_HDR(o,&Izh_con_info,??);
876 payloadWord(o,0) = xPopTaggedInt();
878 fprintf(stderr,"\tBuilt ");
880 printObj(stgCast(StgClosure*,o));
883 xPushPtr(stgCast(StgPtr,o));
888 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
889 /* ASSERT(isIntLike(con)); */
890 xPushTaggedInt(payloadWord(con,0));
895 StgWord offset = BCO_INSTR_16;
896 StgInt x = xPopTaggedInt();
897 StgInt y = xPopTaggedInt();
903 Case(i_CONST_INTEGER):
907 char* s = bcoConstAddr(bco,BCO_INSTR_8);
910 p = CreateByteArrayToHoldInteger(n);
911 do_fromStr ( s, n, IntegerInsideByteArray(p));
912 SloppifyIntegerEnd(p);
919 StgWord w = xTaggedStackWord(BCO_INSTR_8);
925 xPushTaggedWord(bcoConstWord(bco,BCO_INSTR_8));
931 SSS; o = (StgClosure*)grabHpNonUpd(Wzh_sizeW); LLL;
932 SET_HDR(o,&Wzh_con_info,??);
933 payloadWord(o,0) = xPopTaggedWord();
935 fprintf(stderr,"\tBuilt ");
937 printObj(stgCast(StgClosure*,o));
940 xPushPtr(stgCast(StgPtr,o));
945 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
946 /* ASSERT(isWordLike(con)); */
947 xPushTaggedWord(payloadWord(con,0));
952 StgAddr a = xTaggedStackAddr(BCO_INSTR_8);
958 xPushTaggedAddr(bcoConstAddr(bco,BCO_INSTR_8));
964 SSS; o = (StgClosure*)grabHpNonUpd(Azh_sizeW); LLL;
965 SET_HDR(o,&Azh_con_info,??);
966 payloadPtr(o,0) = xPopTaggedAddr();
968 fprintf(stderr,"\tBuilt ");
970 printObj(stgCast(StgClosure*,o));
973 xPushPtr(stgCast(StgPtr,o));
978 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
979 /* ASSERT(isAddrLike(con)); */
980 xPushTaggedAddr(payloadPtr(con,0));
985 StgChar c = xTaggedStackChar(BCO_INSTR_8);
991 xPushTaggedChar(bcoConstChar(bco,BCO_INSTR_8));
997 SSS; o = (StgClosure*)grabHpNonUpd(Czh_sizeW); LLL;
998 SET_HDR(o,&Czh_con_info,??);
999 payloadWord(o,0) = xPopTaggedChar();
1000 xPushPtr(stgCast(StgPtr,o));
1002 fprintf(stderr,"\tBuilt ");
1004 printObj(stgCast(StgClosure*,o));
1009 Case(i_UNPACK_CHAR):
1011 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1012 /* ASSERT(isCharLike(con)); */
1013 xPushTaggedChar(payloadWord(con,0));
1018 StgFloat f = xTaggedStackFloat(BCO_INSTR_8);
1019 xPushTaggedFloat(f);
1022 Case(i_CONST_FLOAT):
1024 xPushTaggedFloat(bcoConstFloat(bco,BCO_INSTR_8));
1030 SSS; o = (StgClosure*)grabHpNonUpd(Fzh_sizeW); LLL;
1031 SET_HDR(o,&Fzh_con_info,??);
1032 ASSIGN_FLT(&payloadWord(o,0),xPopTaggedFloat());
1034 fprintf(stderr,"\tBuilt ");
1036 printObj(stgCast(StgClosure*,o));
1039 xPushPtr(stgCast(StgPtr,o));
1042 Case(i_UNPACK_FLOAT):
1044 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1045 /* ASSERT(isFloatLike(con)); */
1046 xPushTaggedFloat(PK_FLT(&payloadWord(con,0)));
1051 StgDouble d = xTaggedStackDouble(BCO_INSTR_8);
1052 xPushTaggedDouble(d);
1055 Case(i_CONST_DOUBLE):
1057 xPushTaggedDouble(bcoConstDouble(bco,BCO_INSTR_8));
1060 Case(i_CONST_DOUBLE_big):
1062 int n = BCO_INSTR_16;
1063 xPushTaggedDouble(bcoConstDouble(bco,n));
1066 Case(i_PACK_DOUBLE):
1069 SSS; o = (StgClosure*)grabHpNonUpd(Dzh_sizeW); LLL;
1070 SET_HDR(o,&Dzh_con_info,??);
1071 ASSIGN_DBL(&payloadWord(o,0),xPopTaggedDouble());
1073 fprintf(stderr,"\tBuilt ");
1074 printObj(stgCast(StgClosure*,o));
1076 xPushPtr(stgCast(StgPtr,o));
1079 Case(i_UNPACK_DOUBLE):
1081 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1082 /* ASSERT(isDoubleLike(con)); */
1083 xPushTaggedDouble(PK_DBL(&payloadWord(con,0)));
1088 fprintf(stderr, "unimp: i_VAR_STABLE\n" ); exit(0);
1089 /*fix side effects here ...*/
1091 xPushTaggedStablePtr(xTaggedStackStable(BCO_INSTR_8));
1095 Case(i_PACK_STABLE):
1098 fprintf(stderr, "unimp: i_PACK_STABLE\n" ); exit(0);
1100 SSS; o = (StgClosure*)grabHpNonUpd(Stablezh_sizeW); LLL;
1101 SET_HDR(o,&StablePtr_con_info,??);
1102 payloadWord(o,0) = xPopTaggedStablePtr();
1104 fprintf(stderr,"\tBuilt ");
1105 printObj(stgCast(StgClosure*,o));
1107 xPushPtr(stgCast(StgPtr,o));
1111 Case(i_UNPACK_STABLE):
1114 fprintf(stderr, "unimp: i_UNPACK_STABLE\n" ); exit(0);
1116 con = stgCast(StgClosure*,xStackPtr(0));
1117 ASSERT(isStableLike(con));
1118 xPushTaggedStablePtr(payloadWord(con,0));
1127 SSS; p = enterBCO_primop1 ( i ); LLL;
1128 if (p) { obj = p; goto enterLoop; };
1135 trc = 12345678; /* Hope that no StgThreadReturnCode has this value */
1137 SSS; p = enterBCO_primop2 ( i, &trc ); LLL;
1139 if (trc == 12345678) {
1140 /* we want to enter p */
1141 obj = p; goto enterLoop;
1143 /* p is the the StgThreadReturnCode for this thread */
1144 RETURN((StgThreadReturnCode)p);
1150 /* combined insns, created by peephole opt */
1153 int x = BCO_INSTR_8;
1154 int y = BCO_INSTR_8;
1155 ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
1156 /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
1163 xSetStackWord(x+y,xStackWord(x));
1173 p = xStackPtr(BCO_INSTR_8);
1175 p = xStackPtr(BCO_INSTR_8);
1182 xPushPtr(bcoConstPtr(bco,BCO_INSTR_8));
1183 xPushPtr(stgCast(StgPtr,&ret_bco_info));
1184 p = xStackPtr(BCO_INSTR_8);
1190 StgPtr retaddr = bcoConstPtr(bco,BCO_INSTR_8);
1191 StgPtr ptr = xStackPtr(BCO_INSTR_8);
1193 /* A shortcut. We're going to push the address of a
1194 return continuation, and then enter a variable, so
1195 that when the var is evaluated, we return to the
1196 continuation. The shortcut is: if the var is a
1197 constructor, don't bother to enter it. Instead,
1198 push the variable on the stack (since this is what
1199 the continuation expects) and jump directly to the
1202 if (get_itbl((StgClosure*)ptr)->type == CONSTR) {
1204 obj = (StgClosure*)retaddr;
1206 fprintf(stderr, "object to enter is a constructor -- "
1207 "jumping directly to return continuation\n" );
1212 /* This is the normal, non-short-cut route */
1214 xPushPtr(stgCast(StgPtr,&ret_bco_info));
1215 obj = (StgClosure*)ptr;
1220 Case(i_VAR_DOUBLE_big):
1221 Case(i_CONST_FLOAT_big):
1222 Case(i_VAR_FLOAT_big):
1223 Case(i_CONST_CHAR_big):
1224 Case(i_VAR_CHAR_big):
1225 Case(i_CONST_ADDR_big):
1226 Case(i_VAR_ADDR_big):
1227 Case(i_CONST_INTEGER_big):
1228 Case(i_CONST_INT_big):
1229 Case(i_VAR_INT_big):
1230 Case(i_VAR_WORD_big):
1231 Case(i_RETADDR_big):
1235 disInstr ( bco, PC );
1236 barf("\nUnrecognised instruction");
1240 barf("enterBCO: ran off end of loop");
1244 # undef LoopTopLabel
1250 /* ---------------------------------------------------- */
1251 /* End of the bytecode evaluator */
1252 /* ---------------------------------------------------- */
1256 StgBlockingQueue* bh;
1257 StgCAF* caf = (StgCAF*)obj;
1258 if (xSp - sizeofW(StgUpdateFrame) < xSpLim) {
1259 xPushCPtr(obj); /* code to restart with */
1260 RETURN(StackOverflow);
1262 /* ToDo: look for xSp==xSu && stackInt(0) == UPD_FRAME
1263 and insert an indirection immediately */
1264 SSS; bh = (StgBlockingQueue*)grabHpUpd(BLACKHOLE_sizeW()); LLL;
1265 SET_INFO(bh,&CAF_BLACKHOLE_info);
1266 bh->blocking_queue = EndTSOQueue;
1268 fprintf(stderr,"Created CAF_BLACKHOLE %p for CAF %p in evaluator\n",bh,caf));
1269 SET_INFO(caf,&CAF_ENTERED_info);
1270 caf->value = (StgClosure*)bh;
1271 if (caf->mut_link == NULL) {
1272 SSS; recordOldToNewPtrs((StgMutClosure*)caf); LLL;
1274 SSS; PUSH_UPD_FRAME(bh,0); LLL;
1275 xSp -= sizeofW(StgUpdateFrame);
1276 caf->link = enteredCAFs;
1283 StgCAF* caf = (StgCAF*)obj;
1284 obj = caf->value; /* it's just a fancy indirection */
1290 case SE_CAF_BLACKHOLE:
1292 /*was StgBlackHole* */
1293 StgBlockingQueue* bh = (StgBlockingQueue*)obj;
1294 /* Put ourselves on the blocking queue for this black hole and block */
1295 CurrentTSO->link = bh->blocking_queue;
1296 bh->blocking_queue = CurrentTSO;
1297 xPushCPtr(obj); /* code to restart with */
1298 barf("enter: CAF_BLACKHOLE unexpected!");
1299 RETURN(ThreadBlocked);
1303 StgAP_UPD* ap = stgCast(StgAP_UPD*,obj);
1305 if (xSp - (i + sizeofW(StgUpdateFrame)) < xSpLim) {
1306 xPushCPtr(obj); /* code to restart with */
1307 RETURN(StackOverflow);
1309 /* ToDo: look for xSp==xSu && stackInt(0) == UPD_FRAME
1310 and insert an indirection immediately */
1311 SSS; PUSH_UPD_FRAME(ap,0); LLL;
1312 xSp -= sizeofW(StgUpdateFrame);
1314 xPushWord(payloadWord(ap,i));
1317 #ifdef EAGER_BLACKHOLING
1319 /* superfluous - but makes debugging easier */
1320 StgBlackHole* bh = stgCast(StgBlackHole*,ap);
1321 SET_INFO(bh,&BLACKHOLE_info);
1322 bh->blocking_queue = EndTSOQueue;
1323 IF_DEBUG(gccafs,fprintf(stderr,"Eagerly blackholed AP_UPD %p in evaluator\n",bh));
1326 #endif /* EAGER_BLACKHOLING */
1331 StgPAP* pap = stgCast(StgPAP*,obj);
1332 int i = pap->n_args; /* ToDo: stack check */
1333 /* ToDo: if PAP is in whnf, we can update any update frames
1337 xPushWord(payloadWord(pap,i));
1344 obj = stgCast(StgInd*,obj)->indirectee;
1349 obj = stgCast(StgIndOldGen*,obj)->indirectee;
1358 case CONSTR_INTLIKE:
1359 case CONSTR_CHARLIKE:
1361 case CONSTR_NOCAF_STATIC:
1364 switch (get_itbl(stgCast(StgClosure*,xSp))->type) {
1366 SSS; PopCatchFrame(); LLL;
1369 xPopUpdateFrame(obj);
1372 SSS; PopSeqFrame(); LLL;
1376 ASSERT(xSp==(P_)xSu);
1380 /*fprintf(stderr,"xSp = %p\txSu = %p\n", xSp, xSu);*/
1381 /*printStack(xSp,CurrentTSO->stack+CurrentTSO->stack_size,xSu);*/
1384 SSS; PopStopFrame(obj); LLL;
1385 RETURN(ThreadFinished);
1395 /* was: goto enterLoop;
1396 But we know that obj must be a bco now, so jump directly.
1399 case RET_SMALL: /* return to GHC */
1403 barf("todo: RET_[VEC_]{BIG,SMALL}");
1405 belch("entered CONSTR with invalid continuation on stack");
1408 printObj(stgCast(StgClosure*,xSp));
1411 barf("bailing out");
1418 //fprintf(stderr, "enterCountI = %d\n", enterCountI);
1419 //fprintf(stderr, "entering unknown closure -- yielding to sched\n");
1422 CurrentTSO->whatNext = ThreadEnterGHC;
1423 xPushCPtr(obj); /* code to restart with */
1424 RETURN(ThreadYielding);
1427 barf("Ran off the end of enter - yoiks");
1444 #undef xSetStackWord
1447 #undef xPushTaggedInt
1448 #undef xPopTaggedInt
1449 #undef xTaggedStackInt
1450 #undef xPushTaggedWord
1451 #undef xPopTaggedWord
1452 #undef xTaggedStackWord
1453 #undef xPushTaggedAddr
1454 #undef xTaggedStackAddr
1455 #undef xPopTaggedAddr
1456 #undef xPushTaggedChar
1457 #undef xTaggedStackChar
1458 #undef xPopTaggedChar
1459 #undef xPushTaggedFloat
1460 #undef xTaggedStackFloat
1461 #undef xPopTaggedFloat
1462 #undef xPushTaggedDouble
1463 #undef xTaggedStackDouble
1464 #undef xPopTaggedDouble
1468 /* --------------------------------------------------------------------------
1469 * Supporting routines for primops
1470 * ------------------------------------------------------------------------*/
1472 static inline void PushTag ( StackTag t )
1474 static inline void PushPtr ( StgPtr x )
1475 { *(--stgCast(StgPtr*,Sp)) = x; }
1476 static inline void PushCPtr ( StgClosure* x )
1477 { *(--stgCast(StgClosure**,Sp)) = x; }
1478 static inline void PushInt ( StgInt x )
1479 { *(--stgCast(StgInt*,Sp)) = x; }
1480 static inline void PushWord ( StgWord x )
1481 { *(--stgCast(StgWord*,Sp)) = x; }
1484 static inline void checkTag ( StackTag t1, StackTag t2 )
1485 { ASSERT(t1 == t2);}
1486 static inline void PopTag ( StackTag t )
1487 { checkTag(t,*(Sp++)); }
1488 static inline StgPtr PopPtr ( void )
1489 { return *stgCast(StgPtr*,Sp)++; }
1490 static inline StgClosure* PopCPtr ( void )
1491 { return *stgCast(StgClosure**,Sp)++; }
1492 static inline StgInt PopInt ( void )
1493 { return *stgCast(StgInt*,Sp)++; }
1494 static inline StgWord PopWord ( void )
1495 { return *stgCast(StgWord*,Sp)++; }
1497 static inline StgPtr stackPtr ( StgStackOffset i )
1498 { return *stgCast(StgPtr*, Sp+i); }
1499 static inline StgInt stackInt ( StgStackOffset i )
1500 { return *stgCast(StgInt*, Sp+i); }
1501 static inline StgWord stackWord ( StgStackOffset i )
1502 { return *stgCast(StgWord*,Sp+i); }
1504 static inline void setStackWord ( StgStackOffset i, StgWord w )
1507 static inline void PushTaggedRealWorld( void )
1508 { PushTag(REALWORLD_TAG); }
1509 inline void PushTaggedInt ( StgInt x )
1510 { Sp -= sizeofW(StgInt); *Sp = x; PushTag(INT_TAG); }
1511 static inline void PushTaggedWord ( StgWord x )
1512 { Sp -= sizeofW(StgWord); *Sp = x; PushTag(WORD_TAG); }
1513 static inline void PushTaggedAddr ( StgAddr x )
1514 { Sp -= sizeofW(StgAddr); *Sp = (W_)x; PushTag(ADDR_TAG); }
1515 static inline void PushTaggedChar ( StgChar x )
1516 { Sp -= sizeofW(StgChar); *Sp = stgCast(StgWord,x); PushTag(CHAR_TAG); }
1517 static inline void PushTaggedFloat ( StgFloat x )
1518 { Sp -= sizeofW(StgFloat); ASSIGN_FLT(Sp,x); PushTag(FLOAT_TAG); }
1519 static inline void PushTaggedDouble ( StgDouble x )
1520 { Sp -= sizeofW(StgDouble); ASSIGN_DBL(Sp,x); PushTag(DOUBLE_TAG); }
1521 static inline void PushTaggedStablePtr ( StgStablePtr x )
1522 { Sp -= sizeofW(StgStablePtr); *Sp = x; PushTag(STABLE_TAG); }
1523 static inline void PushTaggedBool ( int x )
1524 { PushTaggedInt(x); }
1528 static inline void PopTaggedRealWorld ( void )
1529 { PopTag(REALWORLD_TAG); }
1530 inline StgInt PopTaggedInt ( void )
1531 { StgInt r; PopTag(INT_TAG); r = *stgCast(StgInt*, Sp);
1532 Sp += sizeofW(StgInt); return r;}
1533 static inline StgWord PopTaggedWord ( void )
1534 { StgWord r; PopTag(WORD_TAG); r = *stgCast(StgWord*, Sp);
1535 Sp += sizeofW(StgWord); return r;}
1536 static inline StgAddr PopTaggedAddr ( void )
1537 { StgAddr r; PopTag(ADDR_TAG); r = *stgCast(StgAddr*, Sp);
1538 Sp += sizeofW(StgAddr); return r;}
1539 static inline StgChar PopTaggedChar ( void )
1540 { StgChar r; PopTag(CHAR_TAG); r = stgCast(StgChar, *Sp);
1541 Sp += sizeofW(StgChar); return r;}
1542 static inline StgFloat PopTaggedFloat ( void )
1543 { StgFloat r; PopTag(FLOAT_TAG); r = PK_FLT(Sp);
1544 Sp += sizeofW(StgFloat); return r;}
1545 static inline StgDouble PopTaggedDouble ( void )
1546 { StgDouble r; PopTag(DOUBLE_TAG); r = PK_DBL(Sp);
1547 Sp += sizeofW(StgDouble); return r;}
1548 static inline StgStablePtr PopTaggedStablePtr ( void )
1549 { StgInt r; PopTag(STABLE_TAG); r = *stgCast(StgStablePtr*, Sp);
1550 Sp += sizeofW(StgStablePtr); return r;}
1554 static inline StgInt taggedStackInt ( StgStackOffset i )
1555 { checkTag(INT_TAG,Sp[i]); return *stgCast(StgInt*, Sp+1+i); }
1556 static inline StgWord taggedStackWord ( StgStackOffset i )
1557 { checkTag(WORD_TAG,Sp[i]); return *stgCast(StgWord*, Sp+1+i); }
1558 static inline StgAddr taggedStackAddr ( StgStackOffset i )
1559 { checkTag(ADDR_TAG,Sp[i]); return *stgCast(StgAddr*, Sp+1+i); }
1560 static inline StgChar taggedStackChar ( StgStackOffset i )
1561 { checkTag(CHAR_TAG,Sp[i]); return stgCast(StgChar, *(Sp+1+i)) ; }
1562 static inline StgFloat taggedStackFloat ( StgStackOffset i )
1563 { checkTag(FLOAT_TAG,Sp[i]); return PK_FLT(Sp+1+i); }
1564 static inline StgDouble taggedStackDouble ( StgStackOffset i )
1565 { checkTag(DOUBLE_TAG,Sp[i]); return PK_DBL(Sp+1+i); }
1566 static inline StgStablePtr taggedStackStable ( StgStackOffset i )
1567 { checkTag(STABLE_TAG,Sp[i]); return *stgCast(StgStablePtr*, Sp+1+i); }
1570 /* --------------------------------------------------------------------------
1573 * Should we allocate from a nursery or use the
1574 * doYouWantToGC/allocate interface? We'd already implemented a
1575 * nursery-style scheme when the doYouWantToGC/allocate interface
1577 * One reason to prefer the doYouWantToGC/allocate interface is to
1578 * support operations which allocate an unknown amount in the heap
1579 * (array ops, gmp ops, etc)
1580 * ------------------------------------------------------------------------*/
1582 static inline StgPtr grabHpUpd( nat size )
1584 ASSERT( size >= MIN_UPD_SIZE + sizeofW(StgHeader) );
1585 #ifdef CRUDE_PROFILING
1586 cp_bill_words ( size );
1588 return allocate(size);
1591 static inline StgPtr grabHpNonUpd( nat size )
1593 ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
1594 #ifdef CRUDE_PROFILING
1595 cp_bill_words ( size );
1597 return allocate(size);
1600 /* --------------------------------------------------------------------------
1601 * Manipulate "update frame" list:
1602 * o Update frames (based on stg_do_update and friends in Updates.hc)
1603 * o Error handling/catching (based on catchzh_fast and friends in Prims.hc)
1604 * o Seq frames (based on seq_frame_entry in Prims.hc)
1606 * ------------------------------------------------------------------------*/
1608 static inline void PopUpdateFrame( StgClosure* obj )
1610 /* NB: doesn't assume that Sp == Su */
1612 fprintf(stderr, "Updating ");
1613 printPtr(stgCast(StgPtr,Su->updatee));
1614 fprintf(stderr, " with ");
1616 fprintf(stderr,"Sp = %p\tSu = %p\n\n", Sp, Su);
1618 #ifdef EAGER_BLACKHOLING
1619 ASSERT(get_itbl(Su->updatee)->type == BLACKHOLE
1620 || get_itbl(Su->updatee)->type == SE_BLACKHOLE
1621 || get_itbl(Su->updatee)->type == CAF_BLACKHOLE
1622 || get_itbl(Su->updatee)->type == SE_CAF_BLACKHOLE
1624 #endif /* EAGER_BLACKHOLING */
1625 UPD_IND(Su->updatee,obj);
1626 Sp = stgCast(StgStackPtr,Su) + sizeofW(StgUpdateFrame);
1630 static inline void PopStopFrame( StgClosure* obj )
1632 /* Move Su just off the end of the stack, we're about to spam the
1633 * STOP_FRAME with the return value.
1635 Su = stgCast(StgUpdateFrame*,Sp+1);
1636 *stgCast(StgClosure**,Sp) = obj;
1639 static inline void PushCatchFrame( StgClosure* handler )
1642 /* ToDo: stack check! */
1643 Sp -= sizeofW(StgCatchFrame);
1644 fp = stgCast(StgCatchFrame*,Sp);
1645 SET_HDR(fp,&catch_frame_info,CCCS);
1646 fp->handler = handler;
1648 Su = stgCast(StgUpdateFrame*,fp);
1651 static inline void PopCatchFrame( void )
1653 /* NB: doesn't assume that Sp == Su */
1654 /* fprintf(stderr,"Popping catch frame\n"); */
1655 Sp = stgCast(StgStackPtr,Su) + sizeofW(StgCatchFrame);
1656 Su = stgCast(StgCatchFrame*,Su)->link;
1659 static inline void PushSeqFrame( void )
1662 /* ToDo: stack check! */
1663 Sp -= sizeofW(StgSeqFrame);
1664 fp = stgCast(StgSeqFrame*,Sp);
1665 SET_HDR(fp,&seq_frame_info,CCCS);
1667 Su = stgCast(StgUpdateFrame*,fp);
1670 static inline void PopSeqFrame( void )
1672 /* NB: doesn't assume that Sp == Su */
1673 Sp = stgCast(StgStackPtr,Su) + sizeofW(StgSeqFrame);
1674 Su = stgCast(StgSeqFrame*,Su)->link;
1677 static inline StgClosure* raiseAnError( StgClosure* errObj )
1679 StgClosure *raise_closure;
1681 /* This closure represents the expression 'raise# E' where E
1682 * is the exception raised. It is used to overwrite all the
1683 * thunks which are currently under evaluataion.
1685 raise_closure = (StgClosure *)allocate(sizeofW(StgClosure)+1);
1686 raise_closure->header.info = &raise_info;
1687 raise_closure->payload[0] = R1.cl;
1690 switch (get_itbl(Su)->type) {
1692 UPD_IND(Su->updatee,raise_closure);
1693 Sp = stgCast(StgStackPtr,Su) + sizeofW(StgUpdateFrame);
1699 case CATCH_FRAME: /* found it! */
1701 StgCatchFrame* fp = stgCast(StgCatchFrame*,Su);
1702 StgClosure *handler = fp->handler;
1704 Sp += sizeofW(StgCatchFrame); /* Pop */
1709 barf("raiseError: uncaught exception: STOP_FRAME");
1711 barf("raiseError: weird activation record");
1716 static StgClosure* raisePrim(char* msg)
1718 /* ToDo: figure out some way to turn the msg into a Haskell Exception
1719 * Hack: we don't know how to build an Exception but we do know how
1720 * to build a (recursive!) error object.
1721 * The result isn't pretty but it's (slightly) better than nothing.
1723 nat size = sizeof(StgClosure) + 1;
1724 StgClosure* errObj = stgCast(StgClosure*,grabHpNonUpd(size));
1725 SET_INFO(errObj,&raise_info);
1726 errObj->payload[0] = errObj;
1727 fprintf(stderr, "\n\n\nRAISE PRIM %s\n", msg);
1731 /* At the moment, I prefer to put it on stdout to make things as
1732 * close to Hugs' old behaviour as possible.
1734 fprintf(stdout, "Program error: %s", msg);
1737 return raiseAnError(stgCast(StgClosure*,errObj));
1740 #define raiseIndex(where) raisePrim("Array index out of range in " where)
1741 #define raiseDiv0(where) raisePrim("Division by 0 in " where)
1743 /* --------------------------------------------------------------------------
1745 * ------------------------------------------------------------------------*/
1747 #define OP_CC_B(e) \
1749 unsigned char x = PopTaggedChar(); \
1750 unsigned char y = PopTaggedChar(); \
1751 PushTaggedBool(e); \
1756 unsigned char x = PopTaggedChar(); \
1765 #define OP_IW_I(e) \
1767 StgInt x = PopTaggedInt(); \
1768 StgWord y = PopTaggedWord(); \
1772 #define OP_II_I(e) \
1774 StgInt x = PopTaggedInt(); \
1775 StgInt y = PopTaggedInt(); \
1779 #define OP_II_B(e) \
1781 StgInt x = PopTaggedInt(); \
1782 StgInt y = PopTaggedInt(); \
1783 PushTaggedBool(e); \
1788 PushTaggedAddr(e); \
1793 StgInt x = PopTaggedInt(); \
1794 PushTaggedAddr(e); \
1799 StgInt x = PopTaggedInt(); \
1805 PushTaggedChar(e); \
1810 StgInt x = PopTaggedInt(); \
1811 PushTaggedChar(e); \
1816 PushTaggedWord(e); \
1821 StgInt x = PopTaggedInt(); \
1822 PushTaggedWord(e); \
1827 PushTaggedFloat(e); \
1832 StgInt x = PopTaggedInt(); \
1833 PushTaggedFloat(e); \
1838 PushTaggedDouble(e); \
1843 StgInt x = PopTaggedInt(); \
1844 PushTaggedDouble(e); \
1847 #define OP_WW_B(e) \
1849 StgWord x = PopTaggedWord(); \
1850 StgWord y = PopTaggedWord(); \
1851 PushTaggedBool(e); \
1854 #define OP_WW_W(e) \
1856 StgWord x = PopTaggedWord(); \
1857 StgWord y = PopTaggedWord(); \
1858 PushTaggedWord(e); \
1863 StgWord x = PopTaggedWord(); \
1869 StgWord x = PopTaggedWord(); \
1870 PushTaggedWord(e); \
1873 #define OP_AA_B(e) \
1875 StgAddr x = PopTaggedAddr(); \
1876 StgAddr y = PopTaggedAddr(); \
1877 PushTaggedBool(e); \
1881 StgAddr x = PopTaggedAddr(); \
1884 #define OP_AI_C(s) \
1886 StgAddr x = PopTaggedAddr(); \
1887 int y = PopTaggedInt(); \
1890 PushTaggedChar(r); \
1892 #define OP_AI_I(s) \
1894 StgAddr x = PopTaggedAddr(); \
1895 int y = PopTaggedInt(); \
1900 #define OP_AI_A(s) \
1902 StgAddr x = PopTaggedAddr(); \
1903 int y = PopTaggedInt(); \
1906 PushTaggedAddr(s); \
1908 #define OP_AI_F(s) \
1910 StgAddr x = PopTaggedAddr(); \
1911 int y = PopTaggedInt(); \
1914 PushTaggedFloat(r); \
1916 #define OP_AI_D(s) \
1918 StgAddr x = PopTaggedAddr(); \
1919 int y = PopTaggedInt(); \
1922 PushTaggedDouble(r); \
1924 #define OP_AI_s(s) \
1926 StgAddr x = PopTaggedAddr(); \
1927 int y = PopTaggedInt(); \
1930 PushTaggedStablePtr(r); \
1932 #define OP_AIC_(s) \
1934 StgAddr x = PopTaggedAddr(); \
1935 int y = PopTaggedInt(); \
1936 StgChar z = PopTaggedChar(); \
1939 #define OP_AII_(s) \
1941 StgAddr x = PopTaggedAddr(); \
1942 int y = PopTaggedInt(); \
1943 StgInt z = PopTaggedInt(); \
1946 #define OP_AIA_(s) \
1948 StgAddr x = PopTaggedAddr(); \
1949 int y = PopTaggedInt(); \
1950 StgAddr z = PopTaggedAddr(); \
1953 #define OP_AIF_(s) \
1955 StgAddr x = PopTaggedAddr(); \
1956 int y = PopTaggedInt(); \
1957 StgFloat z = PopTaggedFloat(); \
1960 #define OP_AID_(s) \
1962 StgAddr x = PopTaggedAddr(); \
1963 int y = PopTaggedInt(); \
1964 StgDouble z = PopTaggedDouble(); \
1967 #define OP_AIs_(s) \
1969 StgAddr x = PopTaggedAddr(); \
1970 int y = PopTaggedInt(); \
1971 StgStablePtr z = PopTaggedStablePtr(); \
1976 #define OP_FF_B(e) \
1978 StgFloat x = PopTaggedFloat(); \
1979 StgFloat y = PopTaggedFloat(); \
1980 PushTaggedBool(e); \
1983 #define OP_FF_F(e) \
1985 StgFloat x = PopTaggedFloat(); \
1986 StgFloat y = PopTaggedFloat(); \
1987 PushTaggedFloat(e); \
1992 StgFloat x = PopTaggedFloat(); \
1993 PushTaggedFloat(e); \
1998 StgFloat x = PopTaggedFloat(); \
1999 PushTaggedBool(e); \
2004 StgFloat x = PopTaggedFloat(); \
2010 StgFloat x = PopTaggedFloat(); \
2011 PushTaggedDouble(e); \
2014 #define OP_DD_B(e) \
2016 StgDouble x = PopTaggedDouble(); \
2017 StgDouble y = PopTaggedDouble(); \
2018 PushTaggedBool(e); \
2021 #define OP_DD_D(e) \
2023 StgDouble x = PopTaggedDouble(); \
2024 StgDouble y = PopTaggedDouble(); \
2025 PushTaggedDouble(e); \
2030 StgDouble x = PopTaggedDouble(); \
2031 PushTaggedBool(e); \
2036 StgDouble x = PopTaggedDouble(); \
2037 PushTaggedDouble(e); \
2042 StgDouble x = PopTaggedDouble(); \
2048 StgDouble x = PopTaggedDouble(); \
2049 PushTaggedFloat(e); \
2053 #ifdef STANDALONE_INTEGER
2054 StgPtr CreateByteArrayToHoldInteger ( int nbytes )
2056 StgInt words = (nbytes+sizeof(W_)-1)/sizeof(W_);
2057 StgWord size = sizeofW(StgArrWords) + words;
2058 StgArrWords* arr = (StgArrWords*)allocate(size);
2059 SET_HDR(arr,&ARR_WORDS_info,CCCS);
2061 ASSERT(nbytes <= arr->words * sizeof(W_));
2064 for (i = 0; i < words; ++i) {
2065 arr->payload[i] = 0xdeadbeef;
2067 { B* b = (B*) &(arr->payload[0]);
2068 b->used = b->sign = 0;
2074 B* IntegerInsideByteArray ( StgPtr arr0 )
2077 StgArrWords* arr = (StgArrWords*)arr0;
2078 ASSERT(GET_INFO(arr) == &ARR_WORDS_info);
2079 b = (B*) &(arr->payload[0]);
2083 void SloppifyIntegerEnd ( StgPtr arr0 )
2085 StgArrWords* arr = (StgArrWords*)arr0;
2086 B* b = (B*) & (arr->payload[0]);
2087 I_ nwunused = arr->words - sizeofW(B) - (b->used+sizeof(W_)-1)/sizeof(W_);
2088 if (nwunused >= ((I_)sizeofW(StgArrWords))) {
2090 b->size -= nwunused * sizeof(W_);
2091 if (b->size < b->used) b->size = b->used;
2094 arr->words -= nwunused;
2095 slop = &(arr->payload[arr->words]);
2096 SET_HDR(slop,&ARR_WORDS_info,CCCS);
2097 slop->words = nwunused - sizeofW(StgArrWords);
2098 ASSERT( &(slop->payload[slop->words]) ==
2099 &(arr->payload[arr->words + nwunused]) );
2103 #define OP_Z_Z(op) \
2105 B* x = IntegerInsideByteArray(PopPtr()); \
2106 int n = mycat2(size_,op)(x); \
2107 StgPtr p = CreateByteArrayToHoldInteger(n); \
2108 mycat2(do_,op)(x,n,IntegerInsideByteArray(p)); \
2109 SloppifyIntegerEnd(p); \
2112 #define OP_ZZ_Z(op) \
2114 B* x = IntegerInsideByteArray(PopPtr()); \
2115 B* y = IntegerInsideByteArray(PopPtr()); \
2116 int n = mycat2(size_,op)(x,y); \
2117 StgPtr p = CreateByteArrayToHoldInteger(n); \
2118 mycat2(do_,op)(x,y,n,IntegerInsideByteArray(p)); \
2119 SloppifyIntegerEnd(p); \
2127 #define HEADER_mI(ty,where) \
2128 StgArrWords* x = stgCast(StgArrWords*,PopPtr()); \
2129 nat i = PopTaggedInt(); \
2130 if (i * sizeof(ty) + (sizeof(ty)) > sizeof(StgWord) * x->words) { \
2131 return (raiseIndex(where)); \
2133 #define OP_mI_ty(ty,where,s) \
2135 HEADER_mI(mycat2(Stg,ty),where) \
2136 { mycat2(Stg,ty) r; \
2138 mycat2(PushTagged,ty)(r); \
2141 #define OP_mIty_(ty,where,s) \
2143 HEADER_mI(mycat2(Stg,ty),where) \
2145 mycat2(Stg,ty) z = mycat2(PopTagged,ty)(); \
2151 void myStackCheck ( void )
2153 //StgPtr sp = (StgPtr)Sp;
2154 StgPtr su = (StgPtr)Su;
2155 //fprintf(stderr, "myStackCheck\n");
2156 if (!(SpLim <= Sp && Sp <= stgCast(StgPtr,Su))) {
2157 fprintf(stderr, "myStackCheck: invalid initial Sp/Su \n" );
2161 if (!(su >= CurrentTSO->stack && su <= CurrentTSO->stack + CurrentTSO->stack_size)) {
2162 fprintf ( stderr, "myStackCheck: su out of stack\n" );
2165 switch (get_itbl(stgCast(StgClosure*,su))->type) {
2167 su = (StgPtr) ((StgCatchFrame*)(su))->link;
2170 su = (StgPtr) ((StgUpdateFrame*)(su))->link;
2173 su = (StgPtr) ((StgSeqFrame*)(su))->link;
2178 fprintf(stderr, "myStackCheck: invalid activation record\n"); assert(0);
2185 /* --------------------------------------------------------------------------
2186 * Primop stuff for bytecode interpreter
2187 * ------------------------------------------------------------------------*/
2189 /* Returns & of the next thing to enter (if throwing an exception),
2190 or NULL in the normal case.
2192 static void* enterBCO_primop1 ( int primop1code )
2194 switch (primop1code) {
2195 case i_pushseqframe:
2197 StgClosure* c = PopCPtr();
2202 case i_pushcatchframe:
2204 StgClosure* e = PopCPtr();
2205 StgClosure* h = PopCPtr();
2211 case i_gtChar: OP_CC_B(x>y); break;
2212 case i_geChar: OP_CC_B(x>=y); break;
2213 case i_eqChar: OP_CC_B(x==y); break;
2214 case i_neChar: OP_CC_B(x!=y); break;
2215 case i_ltChar: OP_CC_B(x<y); break;
2216 case i_leChar: OP_CC_B(x<=y); break;
2217 case i_charToInt: OP_C_I(x); break;
2218 case i_intToChar: OP_I_C(x); break;
2220 case i_gtInt: OP_II_B(x>y); break;
2221 case i_geInt: OP_II_B(x>=y); break;
2222 case i_eqInt: OP_II_B(x==y); break;
2223 case i_neInt: OP_II_B(x!=y); break;
2224 case i_ltInt: OP_II_B(x<y); break;
2225 case i_leInt: OP_II_B(x<=y); break;
2226 case i_minInt: OP__I(INT_MIN); break;
2227 case i_maxInt: OP__I(INT_MAX); break;
2228 case i_plusInt: OP_II_I(x+y); break;
2229 case i_minusInt: OP_II_I(x-y); break;
2230 case i_timesInt: OP_II_I(x*y); break;
2233 int x = PopTaggedInt();
2234 int y = PopTaggedInt();
2236 return (raiseDiv0("quotInt"));
2238 /* ToDo: protect against minInt / -1 errors
2239 * (repeat for all other division primops)
2246 int x = PopTaggedInt();
2247 int y = PopTaggedInt();
2249 return (raiseDiv0("remInt"));
2256 StgInt x = PopTaggedInt();
2257 StgInt y = PopTaggedInt();
2259 return (raiseDiv0("quotRemInt"));
2261 PushTaggedInt(x%y); /* last result */
2262 PushTaggedInt(x/y); /* first result */
2265 case i_negateInt: OP_I_I(-x); break;
2267 case i_andInt: OP_II_I(x&y); break;
2268 case i_orInt: OP_II_I(x|y); break;
2269 case i_xorInt: OP_II_I(x^y); break;
2270 case i_notInt: OP_I_I(~x); break;
2271 case i_shiftLInt: OP_II_I(x<<y); break;
2272 case i_shiftRAInt: OP_II_I(x>>y); break; /* ToDo */
2273 case i_shiftRLInt: OP_II_I(x>>y); break; /* ToDo */
2275 case i_gtWord: OP_WW_B(x>y); break;
2276 case i_geWord: OP_WW_B(x>=y); break;
2277 case i_eqWord: OP_WW_B(x==y); break;
2278 case i_neWord: OP_WW_B(x!=y); break;
2279 case i_ltWord: OP_WW_B(x<y); break;
2280 case i_leWord: OP_WW_B(x<=y); break;
2281 case i_minWord: OP__W(0); break;
2282 case i_maxWord: OP__W(UINT_MAX); break;
2283 case i_plusWord: OP_WW_W(x+y); break;
2284 case i_minusWord: OP_WW_W(x-y); break;
2285 case i_timesWord: OP_WW_W(x*y); break;
2288 StgWord x = PopTaggedWord();
2289 StgWord y = PopTaggedWord();
2291 return (raiseDiv0("quotWord"));
2293 PushTaggedWord(x/y);
2298 StgWord x = PopTaggedWord();
2299 StgWord y = PopTaggedWord();
2301 return (raiseDiv0("remWord"));
2303 PushTaggedWord(x%y);
2308 StgWord x = PopTaggedWord();
2309 StgWord y = PopTaggedWord();
2311 return (raiseDiv0("quotRemWord"));
2313 PushTaggedWord(x%y); /* last result */
2314 PushTaggedWord(x/y); /* first result */
2317 case i_negateWord: OP_W_W(-x); break;
2318 case i_andWord: OP_WW_W(x&y); break;
2319 case i_orWord: OP_WW_W(x|y); break;
2320 case i_xorWord: OP_WW_W(x^y); break;
2321 case i_notWord: OP_W_W(~x); break;
2322 case i_shiftLWord: OP_WW_W(x<<y); break;
2323 case i_shiftRAWord: OP_WW_W(x>>y); break; /* ToDo */
2324 case i_shiftRLWord: OP_WW_W(x>>y); break; /* ToDo */
2325 case i_intToWord: OP_I_W(x); break;
2326 case i_wordToInt: OP_W_I(x); break;
2328 case i_gtAddr: OP_AA_B(x>y); break;
2329 case i_geAddr: OP_AA_B(x>=y); break;
2330 case i_eqAddr: OP_AA_B(x==y); break;
2331 case i_neAddr: OP_AA_B(x!=y); break;
2332 case i_ltAddr: OP_AA_B(x<y); break;
2333 case i_leAddr: OP_AA_B(x<=y); break;
2334 case i_intToAddr: OP_I_A((StgAddr)x); break; /* ToDo */
2335 case i_addrToInt: OP_A_I((StgInt)x); break; /* ToDo */
2337 case i_indexCharOffAddr: OP_AI_C(indexCharOffAddrzh(r,x,y)); break;
2338 case i_readCharOffAddr: OP_AI_C(indexCharOffAddrzh(r,x,y)); break;
2339 case i_writeCharOffAddr: OP_AIC_(writeCharOffAddrzh(x,y,z)); break;
2341 case i_indexIntOffAddr: OP_AI_I(indexIntOffAddrzh(r,x,y)); break;
2342 case i_readIntOffAddr: OP_AI_I(indexIntOffAddrzh(r,x,y)); break;
2343 case i_writeIntOffAddr: OP_AII_(writeIntOffAddrzh(x,y,z)); break;
2345 case i_indexAddrOffAddr: OP_AI_A(indexAddrOffAddrzh(r,x,y)); break;
2346 case i_readAddrOffAddr: OP_AI_A(indexAddrOffAddrzh(r,x,y)); break;
2347 case i_writeAddrOffAddr: OP_AIA_(writeAddrOffAddrzh(x,y,z)); break;
2349 case i_indexFloatOffAddr: OP_AI_F(indexFloatOffAddrzh(r,x,y)); break;
2350 case i_readFloatOffAddr: OP_AI_F(indexFloatOffAddrzh(r,x,y)); break;
2351 case i_writeFloatOffAddr: OP_AIF_(writeFloatOffAddrzh(x,y,z)); break;
2353 case i_indexDoubleOffAddr: OP_AI_D(indexDoubleOffAddrzh(r,x,y)); break;
2354 case i_readDoubleOffAddr: OP_AI_D(indexDoubleOffAddrzh(r,x,y)); break;
2355 case i_writeDoubleOffAddr: OP_AID_(writeDoubleOffAddrzh(x,y,z)); break;
2357 #ifdef PROVIDE_STABLE
2358 case i_indexStableOffAddr: OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break;
2359 case i_readStableOffAddr: OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break;
2360 case i_writeStableOffAddr: OP_AIs_(writeStablePtrOffAddrzh(x,y,z)); break;
2363 #ifdef STANDALONE_INTEGER
2364 case i_compareInteger:
2366 B* x = IntegerInsideByteArray(PopPtr());
2367 B* y = IntegerInsideByteArray(PopPtr());
2368 StgInt r = do_cmp(x,y);
2369 PushTaggedInt(r<0 ? -1 : (r>0 ? 1 : 0));
2372 case i_negateInteger: OP_Z_Z(neg); break;
2373 case i_plusInteger: OP_ZZ_Z(add); break;
2374 case i_minusInteger: OP_ZZ_Z(sub); break;
2375 case i_timesInteger: OP_ZZ_Z(mul); break;
2376 case i_quotRemInteger:
2378 B* x = IntegerInsideByteArray(PopPtr());
2379 B* y = IntegerInsideByteArray(PopPtr());
2380 int n = size_qrm(x,y);
2381 StgPtr q = CreateByteArrayToHoldInteger(n);
2382 StgPtr r = CreateByteArrayToHoldInteger(n);
2383 if (do_getsign(y)==0)
2384 return (raiseDiv0("quotRemInteger"));
2385 do_qrm(x,y,n,IntegerInsideByteArray(q),
2386 IntegerInsideByteArray(r));
2387 SloppifyIntegerEnd(q);
2388 SloppifyIntegerEnd(r);
2393 case i_intToInteger:
2395 int n = size_fromInt();
2396 StgPtr p = CreateByteArrayToHoldInteger(n);
2397 do_fromInt( PopTaggedInt(), n, IntegerInsideByteArray(p));
2401 case i_wordToInteger:
2403 int n = size_fromWord();
2404 StgPtr p = CreateByteArrayToHoldInteger(n);
2405 do_fromWord( PopTaggedWord(), n, IntegerInsideByteArray(p));
2409 case i_integerToInt: PushTaggedInt(do_toInt(
2410 IntegerInsideByteArray(PopPtr())
2414 case i_integerToWord: PushTaggedWord(do_toWord(
2415 IntegerInsideByteArray(PopPtr())
2419 case i_integerToFloat: PushTaggedFloat(do_toFloat(
2420 IntegerInsideByteArray(PopPtr())
2424 case i_integerToDouble: PushTaggedDouble(do_toDouble(
2425 IntegerInsideByteArray(PopPtr())
2429 #error Non-standalone integer not yet implemented
2430 #endif /* STANDALONE_INTEGER */
2432 case i_gtFloat: OP_FF_B(x>y); break;
2433 case i_geFloat: OP_FF_B(x>=y); break;
2434 case i_eqFloat: OP_FF_B(x==y); break;
2435 case i_neFloat: OP_FF_B(x!=y); break;
2436 case i_ltFloat: OP_FF_B(x<y); break;
2437 case i_leFloat: OP_FF_B(x<=y); break;
2438 case i_minFloat: OP__F(FLT_MIN); break;
2439 case i_maxFloat: OP__F(FLT_MAX); break;
2440 case i_radixFloat: OP__I(FLT_RADIX); break;
2441 case i_digitsFloat: OP__I(FLT_MANT_DIG); break;
2442 case i_minExpFloat: OP__I(FLT_MIN_EXP); break;
2443 case i_maxExpFloat: OP__I(FLT_MAX_EXP); break;
2444 case i_plusFloat: OP_FF_F(x+y); break;
2445 case i_minusFloat: OP_FF_F(x-y); break;
2446 case i_timesFloat: OP_FF_F(x*y); break;
2449 StgFloat x = PopTaggedFloat();
2450 StgFloat y = PopTaggedFloat();
2453 return (raiseDiv0("divideFloat"));
2456 PushTaggedFloat(x/y);
2459 case i_negateFloat: OP_F_F(-x); break;
2460 case i_floatToInt: OP_F_I(x); break;
2461 case i_intToFloat: OP_I_F(x); break;
2462 case i_expFloat: OP_F_F(exp(x)); break;
2463 case i_logFloat: OP_F_F(log(x)); break;
2464 case i_sqrtFloat: OP_F_F(sqrt(x)); break;
2465 case i_sinFloat: OP_F_F(sin(x)); break;
2466 case i_cosFloat: OP_F_F(cos(x)); break;
2467 case i_tanFloat: OP_F_F(tan(x)); break;
2468 case i_asinFloat: OP_F_F(asin(x)); break;
2469 case i_acosFloat: OP_F_F(acos(x)); break;
2470 case i_atanFloat: OP_F_F(atan(x)); break;
2471 case i_sinhFloat: OP_F_F(sinh(x)); break;
2472 case i_coshFloat: OP_F_F(cosh(x)); break;
2473 case i_tanhFloat: OP_F_F(tanh(x)); break;
2474 case i_powerFloat: OP_FF_F(pow(x,y)); break;
2476 #ifdef STANDALONE_INTEGER
2477 case i_encodeFloatZ:
2479 StgPtr sig = PopPtr();
2480 StgInt exp = PopTaggedInt();
2482 B__encodeFloat(IntegerInsideByteArray(sig), exp)
2486 case i_decodeFloatZ:
2488 StgFloat f = PopTaggedFloat();
2489 StgPtr sig = CreateByteArrayToHoldInteger(size_fltmantissa());
2491 B__decodeFloat(IntegerInsideByteArray(sig), &exp, f);
2497 #error encode/decodeFloatZ not yet implemented for GHC ints
2499 case i_isNaNFloat: OP_F_B(isFloatNaN(x)); break;
2500 case i_isInfiniteFloat: OP_F_B(isFloatInfinite(x)); break;
2501 case i_isNegativeZeroFloat: OP_F_B(isFloatNegativeZero(x)); break;
2502 case i_isDenormalizedFloat: OP_F_B(isFloatDenormalized(x)); break;
2503 case i_gtDouble: OP_DD_B(x>y); break;
2504 case i_geDouble: OP_DD_B(x>=y); break;
2505 case i_eqDouble: OP_DD_B(x==y); break;
2506 case i_neDouble: OP_DD_B(x!=y); break;
2507 case i_ltDouble: OP_DD_B(x<y); break;
2508 case i_leDouble: OP_DD_B(x<=y) break;
2509 case i_minDouble: OP__D(DBL_MIN); break;
2510 case i_maxDouble: OP__D(DBL_MAX); break;
2511 case i_radixDouble: OP__I(FLT_RADIX); break;
2512 case i_digitsDouble: OP__I(DBL_MANT_DIG); break;
2513 case i_minExpDouble: OP__I(DBL_MIN_EXP); break;
2514 case i_maxExpDouble: OP__I(DBL_MAX_EXP); break;
2515 case i_plusDouble: OP_DD_D(x+y); break;
2516 case i_minusDouble: OP_DD_D(x-y); break;
2517 case i_timesDouble: OP_DD_D(x*y); break;
2518 case i_divideDouble:
2520 StgDouble x = PopTaggedDouble();
2521 StgDouble y = PopTaggedDouble();
2524 return (raiseDiv0("divideDouble"));
2527 PushTaggedDouble(x/y);
2530 case i_negateDouble: OP_D_D(-x); break;
2531 case i_doubleToInt: OP_D_I(x); break;
2532 case i_intToDouble: OP_I_D(x); break;
2533 case i_doubleToFloat: OP_D_F(x); break;
2534 case i_floatToDouble: OP_F_F(x); break;
2535 case i_expDouble: OP_D_D(exp(x)); break;
2536 case i_logDouble: OP_D_D(log(x)); break;
2537 case i_sqrtDouble: OP_D_D(sqrt(x)); break;
2538 case i_sinDouble: OP_D_D(sin(x)); break;
2539 case i_cosDouble: OP_D_D(cos(x)); break;
2540 case i_tanDouble: OP_D_D(tan(x)); break;
2541 case i_asinDouble: OP_D_D(asin(x)); break;
2542 case i_acosDouble: OP_D_D(acos(x)); break;
2543 case i_atanDouble: OP_D_D(atan(x)); break;
2544 case i_sinhDouble: OP_D_D(sinh(x)); break;
2545 case i_coshDouble: OP_D_D(cosh(x)); break;
2546 case i_tanhDouble: OP_D_D(tanh(x)); break;
2547 case i_powerDouble: OP_DD_D(pow(x,y)); break;
2549 #ifdef STANDALONE_INTEGER
2550 case i_encodeDoubleZ:
2552 StgPtr sig = PopPtr();
2553 StgInt exp = PopTaggedInt();
2555 B__encodeDouble(IntegerInsideByteArray(sig), exp)
2559 case i_decodeDoubleZ:
2561 StgDouble d = PopTaggedDouble();
2562 StgPtr sig = CreateByteArrayToHoldInteger(size_dblmantissa());
2564 B__decodeDouble(IntegerInsideByteArray(sig), &exp, d);
2570 #error encode/decodeDoubleZ not yet implemented for GHC ints
2572 case i_isNaNDouble: OP_D_B(isDoubleNaN(x)); break;
2573 case i_isInfiniteDouble: OP_D_B(isDoubleInfinite(x)); break;
2574 case i_isNegativeZeroDouble: OP_D_B(isDoubleNegativeZero(x)); break;
2575 case i_isDenormalizedDouble: OP_D_B(isDoubleDenormalized(x)); break;
2576 case i_isIEEEDouble:
2578 PushTaggedBool(rtsTrue);
2582 barf("Unrecognised primop1");
2589 /* For normal cases, return NULL and leave *return2 unchanged.
2590 To return the address of the next thing to enter,
2591 return the address of it and leave *return2 unchanged.
2592 To return a StgThreadReturnCode to the scheduler,
2593 set *return2 to it and return a non-NULL value.
2595 static void* enterBCO_primop2 ( int primop2code,
2596 int* /*StgThreadReturnCode* */ return2 )
2598 switch (primop2code) {
2599 case i_raise: /* raise#{err} */
2601 StgClosure* err = PopCPtr();
2602 return (raiseAnError(err));
2607 StgClosure* init = PopCPtr();
2609 = stgCast(StgMutVar*,allocate(sizeofW(StgMutVar)));
2610 SET_HDR(mv,&MUT_VAR_info,CCCS);
2612 PushPtr(stgCast(StgPtr,mv));
2617 StgMutVar* mv = stgCast(StgMutVar*,PopPtr());
2623 StgMutVar* mv = stgCast(StgMutVar*,PopPtr());
2624 StgClosure* value = PopCPtr();
2630 nat n = PopTaggedInt(); /* or Word?? */
2631 StgClosure* init = PopCPtr();
2632 StgWord size = sizeofW(StgMutArrPtrs) + n;
2635 = stgCast(StgMutArrPtrs*,allocate(size));
2636 SET_HDR(arr,&MUT_ARR_PTRS_info,CCCS);
2638 for (i = 0; i < n; ++i) {
2639 arr->payload[i] = init;
2641 PushPtr(stgCast(StgPtr,arr));
2647 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2648 nat i = PopTaggedInt(); /* or Word?? */
2649 StgWord n = arr->ptrs;
2651 return (raiseIndex("{index,read}Array"));
2653 PushCPtr(arr->payload[i]);
2658 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2659 nat i = PopTaggedInt(); /* or Word? */
2660 StgClosure* v = PopCPtr();
2661 StgWord n = arr->ptrs;
2663 return (raiseIndex("{index,read}Array"));
2665 arr->payload[i] = v;
2669 case i_sizeMutableArray:
2671 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2672 PushTaggedInt(arr->ptrs);
2675 case i_unsafeFreezeArray:
2677 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2678 SET_INFO(arr,&MUT_ARR_PTRS_FROZEN_info);
2679 PushPtr(stgCast(StgPtr,arr));
2682 case i_unsafeFreezeByteArray:
2684 /* Delightfully simple :-) */
2688 case i_sameMutableArray:
2689 case i_sameMutableByteArray:
2691 StgPtr x = PopPtr();
2692 StgPtr y = PopPtr();
2693 PushTaggedBool(x==y);
2697 case i_newByteArray:
2699 nat n = PopTaggedInt(); /* or Word?? */
2700 StgInt words = (n+sizeof(W_)-1)/sizeof(W_);
2701 StgWord size = sizeofW(StgArrWords) + words;
2702 StgArrWords* arr = stgCast(StgArrWords*,allocate(size));
2703 SET_HDR(arr,&ARR_WORDS_info,CCCS);
2707 for (i = 0; i < n; ++i) {
2708 arr->payload[i] = 0xdeadbeef;
2711 PushPtr(stgCast(StgPtr,arr));
2715 /* Most of these generate alignment warnings on Sparcs and similar architectures.
2716 * These are harmless and are caused by the cast to C* in BYTE_ARR_CTS.
2718 case i_indexCharArray:
2719 OP_mI_ty(Char,"indexCharArray", indexCharArrayzh(r,x,i)); break;
2720 case i_readCharArray:
2721 OP_mI_ty(Char,"readCharArray", readCharArrayzh(r,x,i)); break;
2722 case i_writeCharArray:
2723 OP_mIty_(Char,"writeCharArray", writeCharArrayzh(x,i,z)); break;
2725 case i_indexIntArray:
2726 OP_mI_ty(Int,"indexIntArray", indexIntArrayzh(r,x,i)); break;
2727 case i_readIntArray:
2728 OP_mI_ty(Int,"readIntArray", readIntArrayzh(r,x,i)); break;
2729 case i_writeIntArray:
2730 OP_mIty_(Int,"writeIntArray", writeIntArrayzh(x,i,z)); break;
2732 case i_indexAddrArray:
2733 OP_mI_ty(Addr,"indexAddrArray", indexAddrArrayzh(r,x,i)); break;
2734 case i_readAddrArray:
2735 OP_mI_ty(Addr,"readAddrArray", readAddrArrayzh(r,x,i)); break;
2736 case i_writeAddrArray:
2737 OP_mIty_(Addr,"writeAddrArray", writeAddrArrayzh(x,i,z)); break;
2739 case i_indexFloatArray:
2740 OP_mI_ty(Float,"indexFloatArray", indexFloatArrayzh(r,x,i)); break;
2741 case i_readFloatArray:
2742 OP_mI_ty(Float,"readFloatArray", readFloatArrayzh(r,x,i)); break;
2743 case i_writeFloatArray:
2744 OP_mIty_(Float,"writeFloatArray", writeFloatArrayzh(x,i,z)); break;
2746 case i_indexDoubleArray:
2747 OP_mI_ty(Double,"indexDoubleArray", indexDoubleArrayzh(r,x,i)); break;
2748 case i_readDoubleArray:
2749 OP_mI_ty(Double,"readDoubleArray", readDoubleArrayzh(r,x,i)); break;
2750 case i_writeDoubleArray:
2751 OP_mIty_(Double,"writeDoubleArray", writeDoubleArrayzh(x,i,z)); break;
2753 #ifdef PROVIDE_STABLE
2754 case i_indexStableArray:
2755 OP_mI_ty(StablePtr,"indexStableArray", indexStablePtrArrayzh(r,x,i)); break;
2756 case i_readStableArray:
2757 OP_mI_ty(StablePtr,"readStableArray", readStablePtrArrayzh(r,x,i)); break;
2758 case i_writeStableArray:
2759 OP_mIty_(StablePtr,"writeStableArray", writeStablePtrArrayzh(x,i,z)); break;
2765 #ifdef PROVIDE_COERCE
2766 case i_unsafeCoerce:
2768 /* Another nullop */
2772 #ifdef PROVIDE_PTREQUALITY
2773 case i_reallyUnsafePtrEquality:
2774 { /* identical to i_sameRef */
2775 StgPtr x = PopPtr();
2776 StgPtr y = PopPtr();
2777 PushTaggedBool(x==y);
2781 #ifdef PROVIDE_FOREIGN
2782 /* ForeignObj# operations */
2783 case i_makeForeignObj:
2785 StgForeignObj *result
2786 = stgCast(StgForeignObj*,allocate(sizeofW(StgForeignObj)));
2787 SET_HDR(result,&FOREIGN_info,CCCS);
2788 result -> data = PopTaggedAddr();
2789 PushPtr(stgCast(StgPtr,result));
2792 #endif /* PROVIDE_FOREIGN */
2797 = stgCast(StgWeak*,allocate(sizeofW(StgWeak)));
2798 SET_HDR(w, &WEAK_info, CCCS);
2800 w->value = PopCPtr();
2801 w->finaliser = PopCPtr();
2802 w->link = weak_ptr_list;
2804 IF_DEBUG(weak, fprintf(stderr,"New weak pointer at %p\n",w));
2805 PushPtr(stgCast(StgPtr,w));
2810 StgWeak *w = stgCast(StgWeak*,PopPtr());
2811 if (w->header.info == &WEAK_info) {
2812 PushCPtr(w->value); /* last result */
2813 PushTaggedInt(1); /* first result */
2815 PushPtr(stgCast(StgPtr,w)); /* ToDo: error thunk would be better */
2820 #endif /* PROVIDE_WEAK */
2821 #ifdef PROVIDE_STABLE
2822 /* StablePtr# operations */
2823 case i_makeStablePtr:
2824 case i_deRefStablePtr:
2825 case i_freeStablePtr:
2826 { fprintf(stderr,"Evaluator.c:stablePtrOp unimp\n" );
2831 case i_makeStablePtr:
2833 StgStablePtr stable_ptr;
2834 if (stable_ptr_free == NULL) {
2835 enlargeStablePtrTable();
2838 stable_ptr = stable_ptr_free - stable_ptr_table;
2839 stable_ptr_free = (P_*)*stable_ptr_free;
2840 stable_ptr_table[stable_ptr] = PopPtr();
2842 PushTaggedStablePtr(stable_ptr);
2845 case i_deRefStablePtr:
2847 StgStablePtr stable_ptr = PopTaggedStablePtr();
2848 PushPtr(stable_ptr_table[stable_ptr]);
2852 case i_freeStablePtr:
2854 StgStablePtr stable_ptr = PopTaggedStablePtr();
2855 stable_ptr_table[stable_ptr] = (P_)stable_ptr_free;
2856 stable_ptr_free = stable_ptr_table + stable_ptr;
2862 #endif /* PROVIDE_STABLE */
2863 #ifdef PROVIDE_CONCURRENT
2866 StgClosure* c = PopCPtr();
2867 StgTSO* t = createGenThread(RtsFlags.GcFlags.initialStkSize,c);
2868 PushPtr(stgCast(StgPtr,t));
2870 /* switch at the earliest opportunity */
2872 /* but don't automatically switch to GHC - or you'll waste your
2873 * time slice switching back.
2875 * Actually, there's more to it than that: the default
2876 * (ThreadEnterGHC) causes the thread to crash - don't
2877 * understand why. - ADR
2879 t->whatNext = ThreadEnterHugs;
2884 StgTSO* tso = stgCast(StgTSO*,PopPtr());
2886 if (tso == CurrentTSO) { /* suicide */
2887 *return2 = ThreadFinished;
2888 return (void*)(1+(NULL));
2893 { /* identical to i_sameRef */
2894 StgPtr x = PopPtr();
2895 StgPtr y = PopPtr();
2896 PushTaggedBool(x==y);
2901 StgMVar *mvar = stgCast(StgMVar*,allocate(sizeofW(StgMVar)));
2902 SET_INFO(mvar,&EMPTY_MVAR_info);
2903 mvar->head = mvar->tail = EndTSOQueue;
2904 /* ToDo: this is a little strange */
2905 mvar->value = stgCast(StgClosure*,&END_TSO_QUEUE_closure);
2906 PushPtr(stgCast(StgPtr,mvar));
2911 ToDo: another way out of the problem might be to add an explicit
2912 continuation to primTakeMVar: takeMVar v = primTakeMVar v takeMVar.
2913 The problem with this plan is that now I dont know how much to chop
2918 StgMVar *mvar = stgCast(StgMVar*,PopPtr());
2919 /* If the MVar is empty, put ourselves
2920 * on its blocking queue, and wait
2921 * until we're woken up.
2923 if (GET_INFO(mvar) != &FULL_MVAR_info) {
2924 if (mvar->head == EndTSOQueue) {
2925 mvar->head = CurrentTSO;
2927 mvar->tail->link = CurrentTSO;
2929 CurrentTSO->link = EndTSOQueue;
2930 mvar->tail = CurrentTSO;
2932 /* Hack, hack, hack.
2933 * When we block, we push a restart closure
2934 * on the stack - but which closure?
2935 * We happen to know that the BCO we're
2936 * executing looks like this:
2945 * 14: ALLOC_CONSTR 0x8213a80
2955 * so we rearrange the stack to look the
2956 * way it did when we entered this BCO
2958 * What a disgusting hack!
2964 *return2 = ThreadBlocked;
2965 return (void*)(1+(NULL));
2968 PushCPtr(mvar->value);
2969 SET_INFO(mvar,&EMPTY_MVAR_info);
2970 /* ToDo: this is a little strange */
2971 mvar->value = (StgClosure*)&END_TSO_QUEUE_closure;
2978 StgMVar* mvar = stgCast(StgMVar*,PopPtr());
2979 StgClosure* value = PopCPtr();
2980 if (GET_INFO(mvar) == &FULL_MVAR_info) {
2981 return (raisePrim("putMVar {full MVar}"));
2983 /* wake up the first thread on the
2984 * queue, it will continue with the
2985 * takeMVar operation and mark the
2988 StgTSO* tso = mvar->head;
2989 SET_INFO(mvar,&FULL_MVAR_info);
2990 mvar->value = value;
2991 if (tso != EndTSOQueue) {
2992 PUSH_ON_RUN_QUEUE(tso);
2993 mvar->head = tso->link;
2994 tso->link = EndTSOQueue;
2995 if (mvar->head == EndTSOQueue) {
2996 mvar->tail = EndTSOQueue;
3000 /* yield for better communication performance */
3007 /* As PrimOps.h says: Hmm, I'll think about these later. */
3010 #endif /* PROVIDE_CONCURRENT */
3014 CFunDescriptor* descriptor = PopTaggedAddr();
3015 StgAddr funPtr = PopTaggedAddr();
3016 ccall(descriptor,funPtr);
3020 barf("Unrecognised primop2");
3026 /* -----------------------------------------------------------------------------
3027 * ccall support code:
3028 * marshall moves args from C stack to Haskell stack
3029 * unmarshall moves args from Haskell stack to C stack
3030 * argSize calculates how much space you need on the C stack
3031 * ---------------------------------------------------------------------------*/
3033 /* Pop arguments off the C stack and Push them onto the Hugs stack.
3034 * Used when preparing for C calling Haskell or in response to
3035 * Haskell calling C.
3037 nat marshall(char arg_ty, void* arg)
3041 PushTaggedInt(*((int*)arg));
3042 return ARG_SIZE(INT_TAG);
3043 #ifdef TODO_STANDALONE_INTEGER
3045 PushTaggedInteger(*((mpz_ptr*)arg));
3046 return ARG_SIZE(INTEGER_TAG);
3049 PushTaggedWord(*((unsigned int*)arg));
3050 return ARG_SIZE(WORD_TAG);
3052 PushTaggedChar(*((char*)arg));
3053 return ARG_SIZE(CHAR_TAG);
3055 PushTaggedFloat(*((float*)arg));
3056 return ARG_SIZE(FLOAT_TAG);
3058 PushTaggedDouble(*((double*)arg));
3059 return ARG_SIZE(DOUBLE_TAG);
3061 PushTaggedAddr(*((void**)arg));
3062 return ARG_SIZE(ADDR_TAG);
3063 #ifdef PROVIDE_STABLE
3065 PushTaggedStablePtr(*((StgStablePtr*)arg));
3066 return ARG_SIZE(STABLE_TAG);
3068 #ifdef PROVIDE_FOREIGN
3070 /* Not allowed in this direction - you have to
3071 * call makeForeignPtr explicitly
3073 barf("marshall: ForeignPtr#\n");
3078 /* Not allowed in this direction */
3079 barf("marshall: [Mutable]ByteArray#\n");
3082 barf("marshall: unrecognised arg type %d\n",arg_ty);
3087 /* Pop arguments off the Hugs stack and Push them onto the C stack.
3088 * Used when preparing for Haskell calling C or in response to
3089 * C calling Haskell.
3091 nat unmarshall(char res_ty, void* res)
3095 *((int*)res) = PopTaggedInt();
3096 return ARG_SIZE(INT_TAG);
3097 #ifdef TODO_STANDALONE_INTEGER
3099 *((mpz_ptr*)res) = PopTaggedInteger();
3100 return ARG_SIZE(INTEGER_TAG);
3103 *((unsigned int*)res) = PopTaggedWord();
3104 return ARG_SIZE(WORD_TAG);
3106 *((int*)res) = PopTaggedChar();
3107 return ARG_SIZE(CHAR_TAG);
3109 *((float*)res) = PopTaggedFloat();
3110 return ARG_SIZE(FLOAT_TAG);
3112 *((double*)res) = PopTaggedDouble();
3113 return ARG_SIZE(DOUBLE_TAG);
3115 *((void**)res) = PopTaggedAddr();
3116 return ARG_SIZE(ADDR_TAG);
3117 #ifdef PROVIDE_STABLE
3119 *((StgStablePtr*)res) = PopTaggedStablePtr();
3120 return ARG_SIZE(STABLE_TAG);
3122 #ifdef PROVIDE_FOREIGN
3125 StgForeignObj *result = stgCast(StgForeignObj*,PopPtr());
3126 *((void**)res) = result->data;
3127 return sizeofW(StgPtr);
3133 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
3134 *((void**)res) = stgCast(void*,&(arr->payload));
3135 return sizeofW(StgPtr);
3138 barf("unmarshall: unrecognised result type %d\n",res_ty);
3142 nat argSize( const char* ks )
3145 for( ; *ks != '\0'; ++ks) {
3148 sz += sizeof(StgWord) * ARG_SIZE(INT_TAG);
3150 #ifdef TODO_STANDALONE_INTEGER
3152 sz += sizeof(StgWord) * ARG_SIZE(INTEGER_TAG);
3156 sz += sizeof(StgWord) * ARG_SIZE(WORD_TAG);
3159 sz += sizeof(StgWord) * ARG_SIZE(CHAR_TAG);
3162 sz += sizeof(StgWord) * ARG_SIZE(FLOAT_TAG);
3165 sz += sizeof(StgWord) * ARG_SIZE(DOUBLE_TAG);
3168 sz += sizeof(StgWord) * ARG_SIZE(ADDR_TAG);
3170 #ifdef PROVIDE_STABLE
3172 sz += sizeof(StgWord) * ARG_SIZE(STABLE_TAG);
3175 #ifdef PROVIDE_FOREIGN
3180 sz += sizeof(StgPtr);
3183 barf("argSize: unrecognised result type %d\n",*ks);
3191 /* -----------------------------------------------------------------------------
3192 * encode/decode Float/Double code for standalone Hugs
3193 * Code based on the HBC code (lib/fltcode.c) and more recently GHC
3194 * (ghc/rts/StgPrimFloat.c)
3195 * ---------------------------------------------------------------------------*/
3197 #ifdef STANDALONE_INTEGER
3199 #if IEEE_FLOATING_POINT
3200 #define MY_DMINEXP ((DBL_MIN_EXP) - (DBL_MANT_DIG) - 1)
3201 /* DMINEXP is defined in values.h on Linux (for example) */
3202 #define DHIGHBIT 0x00100000
3203 #define DMSBIT 0x80000000
3205 #define MY_FMINEXP ((FLT_MIN_EXP) - (FLT_MANT_DIG) - 1)
3206 #define FHIGHBIT 0x00800000
3207 #define FMSBIT 0x80000000
3209 #error The following code doesnt work in a non-IEEE FP environment
3212 #ifdef WORDS_BIGENDIAN
3221 StgDouble B__encodeDouble (B* s, I_ e) /* result = s * 2^e */
3226 /* Convert a B to a double; knows a lot about internal rep! */
3227 for(r = 0.0, i = s->used-1; i >= 0; i--)
3228 r = (r * B_BASE_FLT) + s->stuff[i];
3230 /* Now raise to the exponent */
3231 if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
3234 /* handle the sign */
3235 if (s->sign < 0) r = -r;
3242 #if ! FLOATS_AS_DOUBLES
3243 StgFloat B__encodeFloat (B* s, I_ e) /* result = s * 2^e */
3248 /* Convert a B to a float; knows a lot about internal rep! */
3249 for(r = 0.0, i = s->used-1; i >= 0; i--)
3250 r = (r * B_BASE_FLT) + s->stuff[i];
3252 /* Now raise to the exponent */
3253 if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
3256 /* handle the sign */
3257 if (s->sign < 0) r = -r;
3261 #endif /* FLOATS_AS_DOUBLES */
3265 /* This only supports IEEE floating point */
3266 void B__decodeDouble (B* man, I_* exp, StgDouble dbl)
3268 /* Do some bit fiddling on IEEE */
3269 nat low, high; /* assuming 32 bit ints */
3271 union { double d; int i[2]; } u; /* assuming 32 bit ints, 64 bit double */
3273 u.d = dbl; /* grab chunks of the double */
3277 ASSERT(B_BASE == 256);
3279 /* Assume that the supplied B is the right size */
3282 if (low == 0 && (high & ~DMSBIT) == 0) {
3283 man->sign = man->used = 0;
3288 iexp = ((high >> 20) & 0x7ff) + MY_DMINEXP;
3292 if (iexp != MY_DMINEXP) /* don't add hidden bit to denorms */
3296 /* A denorm, normalize the mantissa */
3297 while (! (high & DHIGHBIT)) {
3307 man->stuff[7] = (((W_)high) >> 24) & 0xff;
3308 man->stuff[6] = (((W_)high) >> 16) & 0xff;
3309 man->stuff[5] = (((W_)high) >> 8) & 0xff;
3310 man->stuff[4] = (((W_)high) ) & 0xff;
3312 man->stuff[3] = (((W_)low) >> 24) & 0xff;
3313 man->stuff[2] = (((W_)low) >> 16) & 0xff;
3314 man->stuff[1] = (((W_)low) >> 8) & 0xff;
3315 man->stuff[0] = (((W_)low) ) & 0xff;
3317 if (sign < 0) man->sign = -1;
3319 do_renormalise(man);
3323 #if ! FLOATS_AS_DOUBLES
3324 void B__decodeFloat (B* man, I_* exp, StgFloat flt)
3326 /* Do some bit fiddling on IEEE */
3327 int high, sign; /* assuming 32 bit ints */
3328 union { float f; int i; } u; /* assuming 32 bit float and int */
3330 u.f = flt; /* grab the float */
3333 ASSERT(B_BASE == 256);
3335 /* Assume that the supplied B is the right size */
3338 if ((high & ~FMSBIT) == 0) {
3339 man->sign = man->used = 0;
3344 *exp = ((high >> 23) & 0xff) + MY_FMINEXP;
3348 if (*exp != MY_FMINEXP) /* don't add hidden bit to denorms */
3352 /* A denorm, normalize the mantissa */
3353 while (! (high & FHIGHBIT)) {
3358 man->stuff[3] = (((W_)high) >> 24) & 0xff;
3359 man->stuff[2] = (((W_)high) >> 16) & 0xff;
3360 man->stuff[1] = (((W_)high) >> 8) & 0xff;
3361 man->stuff[0] = (((W_)high) ) & 0xff;
3363 if (sign < 0) man->sign = -1;
3365 do_renormalise(man);
3368 #endif /* FLOATS_AS_DOUBLES */
3370 #endif /* STANDALONE_INTEGER */
3374 #endif /* INTERPRETER */