2 /* -----------------------------------------------------------------------------
5 * Copyright (c) 1994-1998.
7 * $RCSfile: Evaluator.c,v $
9 * $Date: 1999/04/28 12:59:51 $
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");
477 if (context_switch) {
478 xPushCPtr(obj); /* code to restart with */
479 RETURN(ThreadYielding);
483 switch ( get_itbl(obj)->type ) {
485 barf("Invalid object %p",obj);
489 /* ---------------------------------------------------- */
490 /* Start of the bytecode evaluator */
491 /* ---------------------------------------------------- */
494 # define Ins(x) &&l##x
495 static void *labs[] = { INSTRLIST };
497 # define LoopTopLabel
498 # define Case(x) l##x
499 # define Continue goto *labs[BCO_INSTR_8]
500 # define Dispatch Continue;
503 # define LoopTopLabel insnloop:
504 # define Case(x) case x
505 # define Continue goto insnloop
506 # define Dispatch switch (BCO_INSTR_8) {
507 # define EndDispatch }
510 register StgWord8* bciPtr; /* instruction pointer */
511 register StgBCO* bco = (StgBCO*)obj;
514 /* Don't need to SSS ... LLL around doYouWantToGC */
515 wantToGC = doYouWantToGC();
517 xPushCPtr((StgClosure*)bco); /* code to restart with */
518 RETURN(HeapOverflow);
526 bciPtr = &(bcoInstr(bco,0));
530 ASSERT(PC < bco->n_instrs);
532 fprintf(stderr,"Sp = %p\tSu = %p\tpc = %d\t", xSp, xSu, PC);
536 fprintf(stderr,"\n");
537 for (i = 8; i >= 0; i--)
538 fprintf(stderr, "%d %p\n", i, (StgPtr)(*(Sp+i)));
540 fprintf(stderr,"\n");
545 SSS; cp_bill_insns(1); LLL;
550 Case(i_INTERNAL_ERROR):
551 barf("INTERNAL_ERROR at %p:%d",bco,PC-1);
553 barf("PANIC at %p:%d",bco,PC-1);
557 if (xSp - n < xSpLim) {
558 xPushCPtr((StgClosure*)bco); /* code to restart with */
559 RETURN(StackOverflow);
566 if ((StgPtr*)(xSp + n) > (StgPtr*)xSu) {
567 StgWord words = (P_)xSu - xSp;
569 /* first build a PAP */
570 ASSERT((P_)xSu >= xSp); /* was (words >= 0) but that's always true */
571 if (words == 0) { /* optimisation */
572 /* Skip building the PAP and update with an indirection. */
575 /* In the evaluator, we avoid the need to do
576 * a heap check here by including the size of
577 * the PAP in the heap check we performed
578 * when we entered the BCO.
582 SSS; pap = (StgPAP*)grabHpNonUpd(PAP_sizeW(words)); LLL;
583 SET_HDR(pap,&PAP_info,CC_pap);
586 for (i = 0; i < (I_)words; ++i) {
587 payloadWord(pap,i) = xSp[i];
590 obj = stgCast(StgClosure*,pap);
593 /* now deal with "update frame" */
594 /* as an optimisation, we process all on top of stack */
595 /* instead of just the top one */
596 ASSERT(xSp==(P_)xSu);
598 switch (get_itbl(xSu)->type) {
600 /* Hit a catch frame during an arg satisfaction check,
601 * so the thing returning (1) has not thrown an
602 * exception, and (2) is of functional type. Just
603 * zap the catch frame and carry on down the stack
604 * (looking for more arguments, basically).
606 SSS; PopCatchFrame(); LLL;
609 xPopUpdateFrame(obj);
612 SSS; PopStopFrame(obj); LLL;
613 RETURN(ThreadFinished);
615 SSS; PopSeqFrame(); LLL;
616 ASSERT(xSp != (P_)xSu);
617 /* Hit a SEQ frame during an arg satisfaction check.
618 * So now return to bco_info which is under the
619 * SEQ frame. The following code is copied from a
620 * case RET_BCO further down. (The reason why we're
621 * here is that something of functional type has
622 * been seq-d on, and we're now returning to the
623 * algebraic-case-continuation which forced the
624 * evaluation in the first place.)
636 barf("Invalid update frame during argcheck");
638 } while (xSp==(P_)xSu);
646 int words = BCO_INSTR_8;
647 SSS; p = grabHpUpd(AP_sizeW(words)); LLL;
651 Case(i_ALLOC_CONSTR):
654 StgInfoTable* info = bcoConstAddr(bco,BCO_INSTR_8);
655 SSS; p = grabHpNonUpd(sizeW_fromITBL(info)); LLL;
656 SET_HDR((StgClosure*)p,info,??);
662 int x = BCO_INSTR_8; /* ToDo: Word not Int! */
664 StgAP_UPD* o = stgCast(StgAP_UPD*,xStackPtr(x));
665 SET_HDR(o,&AP_UPD_info,??);
667 o->fun = stgCast(StgClosure*,xPopPtr());
668 for(x=0; x < y; ++x) {
669 payloadWord(o,x) = xPopWord();
672 fprintf(stderr,"\tBuilt ");
674 printObj(stgCast(StgClosure*,o));
685 o = stgCast(StgAP_UPD*,xStackPtr(x));
686 SET_HDR(o,&AP_UPD_info,??);
688 o->fun = stgCast(StgClosure*,xPopPtr());
689 for(x=0; x < y; ++x) {
690 payloadWord(o,x) = xPopWord();
693 fprintf(stderr,"\tBuilt ");
695 printObj(stgCast(StgClosure*,o));
704 StgPAP* o = stgCast(StgPAP*,xStackPtr(x));
705 SET_HDR(o,&PAP_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));
721 int offset = BCO_INSTR_8;
722 StgClosure* o = stgCast(StgClosure*,xStackPtr(offset));
723 const StgInfoTable* info = get_itbl(o);
724 nat p = info->layout.payload.ptrs;
725 nat np = info->layout.payload.nptrs;
727 for(i=0; i < p; ++i) {
728 payloadCPtr(o,i) = xPopCPtr();
730 for(i=0; i < np; ++i) {
731 payloadWord(o,p+i) = 0xdeadbeef;
734 fprintf(stderr,"\tBuilt ");
736 printObj(stgCast(StgClosure*,o));
743 int offset = BCO_INSTR_16;
744 StgClosure* o = stgCast(StgClosure*,xStackPtr(offset));
745 const StgInfoTable* info = get_itbl(o);
746 nat p = info->layout.payload.ptrs;
747 nat np = info->layout.payload.nptrs;
749 for(i=0; i < p; ++i) {
750 payloadCPtr(o,i) = xPopCPtr();
752 for(i=0; i < np; ++i) {
753 payloadWord(o,p+i) = 0xdeadbeef;
756 fprintf(stderr,"\tBuilt ");
758 printObj(stgCast(StgClosure*,o));
767 ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
768 /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
770 xSetStackWord(x+y,xStackWord(x));
780 ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
781 /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
783 xSetStackWord(x+y,xStackWord(x));
795 xPushPtr(bcoConstPtr(bco,BCO_INSTR_8));
796 xPushPtr(stgCast(StgPtr,&ret_bco_info));
801 int tag = BCO_INSTR_8;
802 StgWord offset = BCO_INSTR_16;
803 if (constrTag(stgCast(StgClosure*,xStackPtr(0))) != tag) {
810 StgClosure* o = stgCast(StgClosure*,xStackPtr(0));
811 const StgInfoTable* itbl = get_itbl(o);
812 int i = itbl->layout.payload.ptrs;
813 ASSERT( itbl->type == CONSTR
814 || itbl->type == CONSTR_STATIC
815 || itbl->type == CONSTR_NOCAF_STATIC
818 xPushCPtr(payloadCPtr(o,i));
824 int n = BCO_INSTR_16;
825 StgPtr p = xStackPtr(n);
831 StgPtr p = xStackPtr(BCO_INSTR_8);
837 xPushPtr(stgCast(StgPtr,bcoConstPtr(bco,BCO_INSTR_8)));
842 int n = BCO_INSTR_16;
843 xPushPtr(stgCast(StgPtr,bcoConstPtr(bco,n)));
848 SSS; PushTaggedRealWorld(); LLL;
853 StgInt i = xTaggedStackInt(BCO_INSTR_8);
859 xPushTaggedInt(bcoConstInt(bco,BCO_INSTR_8));
865 SSS; o = (StgClosure*)grabHpNonUpd(Izh_sizeW); LLL;
866 SET_HDR(o,&Izh_con_info,??);
867 payloadWord(o,0) = xPopTaggedInt();
869 fprintf(stderr,"\tBuilt ");
871 printObj(stgCast(StgClosure*,o));
874 xPushPtr(stgCast(StgPtr,o));
879 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
880 /* ASSERT(isIntLike(con)); */
881 xPushTaggedInt(payloadWord(con,0));
886 StgWord offset = BCO_INSTR_16;
887 StgInt x = xPopTaggedInt();
888 StgInt y = xPopTaggedInt();
894 Case(i_CONST_INTEGER):
898 char* s = bcoConstAddr(bco,BCO_INSTR_8);
901 p = CreateByteArrayToHoldInteger(n);
902 do_fromStr ( s, n, IntegerInsideByteArray(p));
903 SloppifyIntegerEnd(p);
910 StgWord w = xTaggedStackWord(BCO_INSTR_8);
916 xPushTaggedWord(bcoConstWord(bco,BCO_INSTR_8));
922 SSS; o = (StgClosure*)grabHpNonUpd(Wzh_sizeW); LLL;
923 SET_HDR(o,&Wzh_con_info,??);
924 payloadWord(o,0) = xPopTaggedWord();
926 fprintf(stderr,"\tBuilt ");
928 printObj(stgCast(StgClosure*,o));
931 xPushPtr(stgCast(StgPtr,o));
936 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
937 /* ASSERT(isWordLike(con)); */
938 xPushTaggedWord(payloadWord(con,0));
943 StgAddr a = xTaggedStackAddr(BCO_INSTR_8);
949 xPushTaggedAddr(bcoConstAddr(bco,BCO_INSTR_8));
955 SSS; o = (StgClosure*)grabHpNonUpd(Azh_sizeW); LLL;
956 SET_HDR(o,&Azh_con_info,??);
957 payloadPtr(o,0) = xPopTaggedAddr();
959 fprintf(stderr,"\tBuilt ");
961 printObj(stgCast(StgClosure*,o));
964 xPushPtr(stgCast(StgPtr,o));
969 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
970 /* ASSERT(isAddrLike(con)); */
971 xPushTaggedAddr(payloadPtr(con,0));
976 StgChar c = xTaggedStackChar(BCO_INSTR_8);
982 xPushTaggedChar(bcoConstChar(bco,BCO_INSTR_8));
988 SSS; o = (StgClosure*)grabHpNonUpd(Czh_sizeW); LLL;
989 SET_HDR(o,&Czh_con_info,??);
990 payloadWord(o,0) = xPopTaggedChar();
991 xPushPtr(stgCast(StgPtr,o));
993 fprintf(stderr,"\tBuilt ");
995 printObj(stgCast(StgClosure*,o));
1000 Case(i_UNPACK_CHAR):
1002 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1003 /* ASSERT(isCharLike(con)); */
1004 xPushTaggedChar(payloadWord(con,0));
1009 StgFloat f = xTaggedStackFloat(BCO_INSTR_8);
1010 xPushTaggedFloat(f);
1013 Case(i_CONST_FLOAT):
1015 xPushTaggedFloat(bcoConstFloat(bco,BCO_INSTR_8));
1021 SSS; o = (StgClosure*)grabHpNonUpd(Fzh_sizeW); LLL;
1022 SET_HDR(o,&Fzh_con_info,??);
1023 ASSIGN_FLT(&payloadWord(o,0),xPopTaggedFloat());
1025 fprintf(stderr,"\tBuilt ");
1027 printObj(stgCast(StgClosure*,o));
1030 xPushPtr(stgCast(StgPtr,o));
1033 Case(i_UNPACK_FLOAT):
1035 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1036 /* ASSERT(isFloatLike(con)); */
1037 xPushTaggedFloat(PK_FLT(&payloadWord(con,0)));
1042 StgDouble d = xTaggedStackDouble(BCO_INSTR_8);
1043 xPushTaggedDouble(d);
1046 Case(i_CONST_DOUBLE):
1048 xPushTaggedDouble(bcoConstDouble(bco,BCO_INSTR_8));
1051 Case(i_CONST_DOUBLE_big):
1053 int n = BCO_INSTR_16;
1054 xPushTaggedDouble(bcoConstDouble(bco,n));
1057 Case(i_PACK_DOUBLE):
1060 SSS; o = (StgClosure*)grabHpNonUpd(Dzh_sizeW); LLL;
1061 SET_HDR(o,&Dzh_con_info,??);
1062 ASSIGN_DBL(&payloadWord(o,0),xPopTaggedDouble());
1064 fprintf(stderr,"\tBuilt ");
1065 printObj(stgCast(StgClosure*,o));
1067 xPushPtr(stgCast(StgPtr,o));
1070 Case(i_UNPACK_DOUBLE):
1072 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1073 /* ASSERT(isDoubleLike(con)); */
1074 xPushTaggedDouble(PK_DBL(&payloadWord(con,0)));
1079 fprintf(stderr, "unimp: i_VAR_STABLE\n" ); exit(0);
1080 /*fix side effects here ...*/
1082 xPushTaggedStablePtr(xTaggedStackStable(BCO_INSTR_8));
1086 Case(i_PACK_STABLE):
1089 fprintf(stderr, "unimp: i_PACK_STABLE\n" ); exit(0);
1091 SSS; o = (StgClosure*)grabHpNonUpd(Stablezh_sizeW); LLL;
1092 SET_HDR(o,&StablePtr_con_info,??);
1093 payloadWord(o,0) = xPopTaggedStablePtr();
1095 fprintf(stderr,"\tBuilt ");
1096 printObj(stgCast(StgClosure*,o));
1098 xPushPtr(stgCast(StgPtr,o));
1102 Case(i_UNPACK_STABLE):
1105 fprintf(stderr, "unimp: i_UNPACK_STABLE\n" ); exit(0);
1107 con = stgCast(StgClosure*,xStackPtr(0));
1108 ASSERT(isStableLike(con));
1109 xPushTaggedStablePtr(payloadWord(con,0));
1118 SSS; p = enterBCO_primop1 ( i ); LLL;
1119 if (p) { obj = p; goto enterLoop; };
1126 trc = 12345678; /* Hope that no StgThreadReturnCode has this value */
1128 SSS; p = enterBCO_primop2 ( i, &trc ); LLL;
1130 if (trc == 12345678) {
1131 /* we want to enter p */
1132 obj = p; goto enterLoop;
1134 /* p is the the StgThreadReturnCode for this thread */
1135 RETURN((StgThreadReturnCode)p);
1141 /* combined insns, created by peephole opt */
1144 int x = BCO_INSTR_8;
1145 int y = BCO_INSTR_8;
1146 ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
1147 /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
1154 xSetStackWord(x+y,xStackWord(x));
1164 p = xStackPtr(BCO_INSTR_8);
1166 p = xStackPtr(BCO_INSTR_8);
1173 xPushPtr(bcoConstPtr(bco,BCO_INSTR_8));
1174 xPushPtr(stgCast(StgPtr,&ret_bco_info));
1175 p = xStackPtr(BCO_INSTR_8);
1181 StgPtr retaddr = bcoConstPtr(bco,BCO_INSTR_8);
1182 StgPtr ptr = xStackPtr(BCO_INSTR_8);
1184 /* A shortcut. We're going to push the address of a
1185 return continuation, and then enter a variable, so
1186 that when the var is evaluated, we return to the
1187 continuation. The shortcut is: if the var is a
1188 constructor, don't bother to enter it. Instead,
1189 push the variable on the stack (since this is what
1190 the continuation expects) and jump directly to the
1193 if (get_itbl((StgClosure*)ptr)->type == CONSTR) {
1195 obj = (StgClosure*)retaddr;
1197 fprintf(stderr, "object to enter is a constructor -- "
1198 "jumping directly to return continuation\n" );
1203 /* This is the normal, non-short-cut route */
1205 xPushPtr(stgCast(StgPtr,&ret_bco_info));
1206 obj = (StgClosure*)ptr;
1211 Case(i_VAR_DOUBLE_big):
1212 Case(i_CONST_FLOAT_big):
1213 Case(i_VAR_FLOAT_big):
1214 Case(i_CONST_CHAR_big):
1215 Case(i_VAR_CHAR_big):
1216 Case(i_CONST_ADDR_big):
1217 Case(i_VAR_ADDR_big):
1218 Case(i_CONST_INTEGER_big):
1219 Case(i_CONST_INT_big):
1220 Case(i_VAR_INT_big):
1221 Case(i_VAR_WORD_big):
1222 Case(i_RETADDR_big):
1226 disInstr ( bco, PC );
1227 barf("\nUnrecognised instruction");
1231 barf("enterBCO: ran off end of loop");
1235 # undef LoopTopLabel
1241 /* ---------------------------------------------------- */
1242 /* End of the bytecode evaluator */
1243 /* ---------------------------------------------------- */
1247 StgBlockingQueue* bh;
1248 StgCAF* caf = (StgCAF*)obj;
1249 if (xSp - sizeofW(StgUpdateFrame) < xSpLim) {
1250 xPushCPtr(obj); /* code to restart with */
1251 RETURN(StackOverflow);
1253 /* ToDo: look for xSp==xSu && stackInt(0) == UPD_FRAME
1254 and insert an indirection immediately */
1255 SSS; bh = (StgBlockingQueue*)grabHpUpd(BLACKHOLE_sizeW()); LLL;
1256 SET_INFO(bh,&CAF_BLACKHOLE_info);
1257 bh->blocking_queue = EndTSOQueue;
1259 fprintf(stderr,"Created CAF_BLACKHOLE %p for CAF %p in evaluator\n",bh,caf));
1260 SET_INFO(caf,&CAF_ENTERED_info);
1261 caf->value = (StgClosure*)bh;
1262 if (caf->mut_link == NULL) {
1263 SSS; recordOldToNewPtrs((StgMutClosure*)caf); LLL;
1265 SSS; PUSH_UPD_FRAME(bh,0); LLL;
1266 xSp -= sizeofW(StgUpdateFrame);
1267 caf->link = enteredCAFs;
1274 StgCAF* caf = (StgCAF*)obj;
1275 obj = caf->value; /* it's just a fancy indirection */
1281 /*was StgBlackHole* */
1282 StgBlockingQueue* bh = (StgBlockingQueue*)obj;
1283 /* Put ourselves on the blocking queue for this black hole and block */
1284 CurrentTSO->link = bh->blocking_queue;
1285 bh->blocking_queue = CurrentTSO;
1286 xPushCPtr(obj); /* code to restart with */
1287 barf("enter: CAF_BLACKHOLE unexpected!");
1288 RETURN(ThreadBlocked);
1292 StgAP_UPD* ap = stgCast(StgAP_UPD*,obj);
1294 if (xSp - (i + 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; PUSH_UPD_FRAME(ap,0); LLL;
1301 xSp -= sizeofW(StgUpdateFrame);
1303 xPushWord(payloadWord(ap,i));
1306 #ifndef LAZY_BLACKHOLING
1309 /* superfluous - but makes debugging easier */
1310 StgBlackHole* bh = stgCast(StgBlackHole*,ap);
1311 SET_INFO(bh,&BLACKHOLE_info);
1312 bh->blocking_queue = EndTSOQueue;
1313 IF_DEBUG(gccafs,fprintf(stderr,"Eagerly blackholed AP_UPD %p in evaluator\n",bh));
1316 #endif /* LAZY_BLACKHOLING */
1321 StgPAP* pap = stgCast(StgPAP*,obj);
1322 int i = pap->n_args; /* ToDo: stack check */
1323 /* ToDo: if PAP is in whnf, we can update any update frames
1327 xPushWord(payloadWord(pap,i));
1334 obj = stgCast(StgInd*,obj)->indirectee;
1339 obj = stgCast(StgIndOldGen*,obj)->indirectee;
1343 case CONSTR_INTLIKE:
1344 case CONSTR_CHARLIKE:
1346 case CONSTR_NOCAF_STATIC:
1349 switch (get_itbl(stgCast(StgClosure*,xSp))->type) {
1351 SSS; PopCatchFrame(); LLL;
1354 xPopUpdateFrame(obj);
1357 SSS; PopSeqFrame(); LLL;
1361 ASSERT(xSp==(P_)xSu);
1365 /*fprintf(stderr,"xSp = %p\txSu = %p\n", xSp, xSu);*/
1366 /*printStack(xSp,CurrentTSO->stack+CurrentTSO->stack_size,xSu);*/
1369 SSS; PopStopFrame(obj); LLL;
1370 RETURN(ThreadFinished);
1380 /* was: goto enterLoop;
1381 But we know that obj must be a bco now, so jump directly.
1384 case RET_SMALL: /* return to GHC */
1388 barf("todo: RET_[VEC_]{BIG,SMALL}");
1390 belch("entered CONSTR with invalid continuation on stack");
1393 printObj(stgCast(StgClosure*,xSp));
1396 barf("bailing out");
1403 fprintf(stderr, "enterCountI = %d\n", enterCountI);
1404 fprintf(stderr, "panic: enter: entered unknown closure\n");
1406 fprintf(stderr, "what it points at is\n");
1407 printObj( ((StgEvacuated*)obj) ->evacuee);
1411 CurrentTSO->whatNext = ThreadEnterGHC;
1412 xPushCPtr(obj); /* code to restart with */
1413 RETURN(ThreadYielding);
1416 barf("Ran off the end of enter - yoiks");
1433 #undef xSetStackWord
1436 #undef xPushTaggedInt
1437 #undef xPopTaggedInt
1438 #undef xTaggedStackInt
1439 #undef xPushTaggedWord
1440 #undef xPopTaggedWord
1441 #undef xTaggedStackWord
1442 #undef xPushTaggedAddr
1443 #undef xTaggedStackAddr
1444 #undef xPopTaggedAddr
1445 #undef xPushTaggedChar
1446 #undef xTaggedStackChar
1447 #undef xPopTaggedChar
1448 #undef xPushTaggedFloat
1449 #undef xTaggedStackFloat
1450 #undef xPopTaggedFloat
1451 #undef xPushTaggedDouble
1452 #undef xTaggedStackDouble
1453 #undef xPopTaggedDouble
1457 /* --------------------------------------------------------------------------
1458 * Supporting routines for primops
1459 * ------------------------------------------------------------------------*/
1461 static inline void PushTag ( StackTag t )
1463 static inline void PushPtr ( StgPtr x )
1464 { *(--stgCast(StgPtr*,Sp)) = x; }
1465 static inline void PushCPtr ( StgClosure* x )
1466 { *(--stgCast(StgClosure**,Sp)) = x; }
1467 static inline void PushInt ( StgInt x )
1468 { *(--stgCast(StgInt*,Sp)) = x; }
1469 static inline void PushWord ( StgWord x )
1470 { *(--stgCast(StgWord*,Sp)) = x; }
1473 static inline void checkTag ( StackTag t1, StackTag t2 )
1474 { ASSERT(t1 == t2);}
1475 static inline void PopTag ( StackTag t )
1476 { checkTag(t,*(Sp++)); }
1477 static inline StgPtr PopPtr ( void )
1478 { return *stgCast(StgPtr*,Sp)++; }
1479 static inline StgClosure* PopCPtr ( void )
1480 { return *stgCast(StgClosure**,Sp)++; }
1481 static inline StgInt PopInt ( void )
1482 { return *stgCast(StgInt*,Sp)++; }
1483 static inline StgWord PopWord ( void )
1484 { return *stgCast(StgWord*,Sp)++; }
1486 static inline StgPtr stackPtr ( StgStackOffset i )
1487 { return *stgCast(StgPtr*, Sp+i); }
1488 static inline StgInt stackInt ( StgStackOffset i )
1489 { return *stgCast(StgInt*, Sp+i); }
1490 static inline StgWord stackWord ( StgStackOffset i )
1491 { return *stgCast(StgWord*,Sp+i); }
1493 static inline void setStackWord ( StgStackOffset i, StgWord w )
1496 static inline void PushTaggedRealWorld( void )
1497 { PushTag(REALWORLD_TAG); }
1498 inline void PushTaggedInt ( StgInt x )
1499 { Sp -= sizeofW(StgInt); *Sp = x; PushTag(INT_TAG); }
1500 static inline void PushTaggedWord ( StgWord x )
1501 { Sp -= sizeofW(StgWord); *Sp = x; PushTag(WORD_TAG); }
1502 static inline void PushTaggedAddr ( StgAddr x )
1503 { Sp -= sizeofW(StgAddr); *Sp = (W_)x; PushTag(ADDR_TAG); }
1504 static inline void PushTaggedChar ( StgChar x )
1505 { Sp -= sizeofW(StgChar); *Sp = stgCast(StgWord,x); PushTag(CHAR_TAG); }
1506 static inline void PushTaggedFloat ( StgFloat x )
1507 { Sp -= sizeofW(StgFloat); ASSIGN_FLT(Sp,x); PushTag(FLOAT_TAG); }
1508 static inline void PushTaggedDouble ( StgDouble x )
1509 { Sp -= sizeofW(StgDouble); ASSIGN_DBL(Sp,x); PushTag(DOUBLE_TAG); }
1510 static inline void PushTaggedStablePtr ( StgStablePtr x )
1511 { Sp -= sizeofW(StgStablePtr); *Sp = x; PushTag(STABLE_TAG); }
1512 static inline void PushTaggedBool ( int x )
1513 { PushTaggedInt(x); }
1517 static inline void PopTaggedRealWorld ( void )
1518 { PopTag(REALWORLD_TAG); }
1519 inline StgInt PopTaggedInt ( void )
1520 { StgInt r; PopTag(INT_TAG); r = *stgCast(StgInt*, Sp);
1521 Sp += sizeofW(StgInt); return r;}
1522 static inline StgWord PopTaggedWord ( void )
1523 { StgWord r; PopTag(WORD_TAG); r = *stgCast(StgWord*, Sp);
1524 Sp += sizeofW(StgWord); return r;}
1525 static inline StgAddr PopTaggedAddr ( void )
1526 { StgAddr r; PopTag(ADDR_TAG); r = *stgCast(StgAddr*, Sp);
1527 Sp += sizeofW(StgAddr); return r;}
1528 static inline StgChar PopTaggedChar ( void )
1529 { StgChar r; PopTag(CHAR_TAG); r = stgCast(StgChar, *Sp);
1530 Sp += sizeofW(StgChar); return r;}
1531 static inline StgFloat PopTaggedFloat ( void )
1532 { StgFloat r; PopTag(FLOAT_TAG); r = PK_FLT(Sp);
1533 Sp += sizeofW(StgFloat); return r;}
1534 static inline StgDouble PopTaggedDouble ( void )
1535 { StgDouble r; PopTag(DOUBLE_TAG); r = PK_DBL(Sp);
1536 Sp += sizeofW(StgDouble); return r;}
1537 static inline StgStablePtr PopTaggedStablePtr ( void )
1538 { StgInt r; PopTag(STABLE_TAG); r = *stgCast(StgStablePtr*, Sp);
1539 Sp += sizeofW(StgStablePtr); return r;}
1543 static inline StgInt taggedStackInt ( StgStackOffset i )
1544 { checkTag(INT_TAG,Sp[i]); return *stgCast(StgInt*, Sp+1+i); }
1545 static inline StgWord taggedStackWord ( StgStackOffset i )
1546 { checkTag(WORD_TAG,Sp[i]); return *stgCast(StgWord*, Sp+1+i); }
1547 static inline StgAddr taggedStackAddr ( StgStackOffset i )
1548 { checkTag(ADDR_TAG,Sp[i]); return *stgCast(StgAddr*, Sp+1+i); }
1549 static inline StgChar taggedStackChar ( StgStackOffset i )
1550 { checkTag(CHAR_TAG,Sp[i]); return stgCast(StgChar, *(Sp+1+i)) ; }
1551 static inline StgFloat taggedStackFloat ( StgStackOffset i )
1552 { checkTag(FLOAT_TAG,Sp[i]); return PK_FLT(Sp+1+i); }
1553 static inline StgDouble taggedStackDouble ( StgStackOffset i )
1554 { checkTag(DOUBLE_TAG,Sp[i]); return PK_DBL(Sp+1+i); }
1555 static inline StgStablePtr taggedStackStable ( StgStackOffset i )
1556 { checkTag(STABLE_TAG,Sp[i]); return *stgCast(StgStablePtr*, Sp+1+i); }
1559 /* --------------------------------------------------------------------------
1562 * Should we allocate from a nursery or use the
1563 * doYouWantToGC/allocate interface? We'd already implemented a
1564 * nursery-style scheme when the doYouWantToGC/allocate interface
1566 * One reason to prefer the doYouWantToGC/allocate interface is to
1567 * support operations which allocate an unknown amount in the heap
1568 * (array ops, gmp ops, etc)
1569 * ------------------------------------------------------------------------*/
1571 static inline StgPtr grabHpUpd( nat size )
1573 ASSERT( size >= MIN_UPD_SIZE + sizeofW(StgHeader) );
1574 #ifdef CRUDE_PROFILING
1575 cp_bill_words ( size );
1577 return allocate(size);
1580 static inline StgPtr grabHpNonUpd( nat size )
1582 ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
1583 #ifdef CRUDE_PROFILING
1584 cp_bill_words ( size );
1586 return allocate(size);
1589 /* --------------------------------------------------------------------------
1590 * Manipulate "update frame" list:
1591 * o Update frames (based on stg_do_update and friends in Updates.hc)
1592 * o Error handling/catching (based on catchzh_fast and friends in Prims.hc)
1593 * o Seq frames (based on seq_frame_entry in Prims.hc)
1595 * ------------------------------------------------------------------------*/
1597 static inline void PopUpdateFrame( StgClosure* obj )
1599 /* NB: doesn't assume that Sp == Su */
1601 fprintf(stderr, "Updating ");
1602 printPtr(stgCast(StgPtr,Su->updatee));
1603 fprintf(stderr, " with ");
1605 fprintf(stderr,"Sp = %p\tSu = %p\n\n", Sp, Su);
1607 #ifndef LAZY_BLACKHOLING
1608 ASSERT(get_itbl(Su->updatee)->type == BLACKHOLE
1609 || get_itbl(Su->updatee)->type == CAF_BLACKHOLE
1611 #endif /* LAZY_BLACKHOLING */
1612 UPD_IND(Su->updatee,obj);
1613 Sp = stgCast(StgStackPtr,Su) + sizeofW(StgUpdateFrame);
1617 static inline void PopStopFrame( StgClosure* obj )
1619 /* Move Su just off the end of the stack, we're about to spam the
1620 * STOP_FRAME with the return value.
1622 Su = stgCast(StgUpdateFrame*,Sp+1);
1623 *stgCast(StgClosure**,Sp) = obj;
1626 static inline void PushCatchFrame( StgClosure* handler )
1629 /* ToDo: stack check! */
1630 Sp -= sizeofW(StgCatchFrame);
1631 fp = stgCast(StgCatchFrame*,Sp);
1632 SET_HDR(fp,&catch_frame_info,CCCS);
1633 fp->handler = handler;
1635 Su = stgCast(StgUpdateFrame*,fp);
1638 static inline void PopCatchFrame( void )
1640 /* NB: doesn't assume that Sp == Su */
1641 /* fprintf(stderr,"Popping catch frame\n"); */
1642 Sp = stgCast(StgStackPtr,Su) + sizeofW(StgCatchFrame);
1643 Su = stgCast(StgCatchFrame*,Su)->link;
1646 static inline void PushSeqFrame( void )
1649 /* ToDo: stack check! */
1650 Sp -= sizeofW(StgSeqFrame);
1651 fp = stgCast(StgSeqFrame*,Sp);
1652 SET_HDR(fp,&seq_frame_info,CCCS);
1654 Su = stgCast(StgUpdateFrame*,fp);
1657 static inline void PopSeqFrame( void )
1659 /* NB: doesn't assume that Sp == Su */
1660 Sp = stgCast(StgStackPtr,Su) + sizeofW(StgSeqFrame);
1661 Su = stgCast(StgSeqFrame*,Su)->link;
1664 static inline StgClosure* raiseAnError( StgClosure* errObj )
1666 StgClosure *raise_closure;
1668 /* This closure represents the expression 'raise# E' where E
1669 * is the exception raised. It is used to overwrite all the
1670 * thunks which are currently under evaluataion.
1672 raise_closure = (StgClosure *)allocate(sizeofW(StgClosure)+1);
1673 raise_closure->header.info = &raise_info;
1674 raise_closure->payload[0] = R1.cl;
1677 switch (get_itbl(Su)->type) {
1679 UPD_IND(Su->updatee,raise_closure);
1680 Sp = stgCast(StgStackPtr,Su) + sizeofW(StgUpdateFrame);
1686 case CATCH_FRAME: /* found it! */
1688 StgCatchFrame* fp = stgCast(StgCatchFrame*,Su);
1689 StgClosure *handler = fp->handler;
1691 Sp += sizeofW(StgCatchFrame); /* Pop */
1696 barf("raiseError: uncaught exception: STOP_FRAME");
1698 barf("raiseError: weird activation record");
1703 static StgClosure* raisePrim(char* msg)
1705 /* ToDo: figure out some way to turn the msg into a Haskell Exception
1706 * Hack: we don't know how to build an Exception but we do know how
1707 * to build a (recursive!) error object.
1708 * The result isn't pretty but it's (slightly) better than nothing.
1710 nat size = sizeof(StgClosure) + 1;
1711 StgClosure* errObj = stgCast(StgClosure*,grabHpNonUpd(size));
1712 SET_INFO(errObj,&raise_info);
1713 errObj->payload[0] = errObj;
1714 fprintf(stderr, "\n\n\nRAISE PRIM %s\n", msg);
1718 /* At the moment, I prefer to put it on stdout to make things as
1719 * close to Hugs' old behaviour as possible.
1721 fprintf(stdout, "Program error: %s", msg);
1724 return raiseAnError(stgCast(StgClosure*,errObj));
1727 #define raiseIndex(where) raisePrim("Array index out of range in " where)
1728 #define raiseDiv0(where) raisePrim("Division by 0 in " where)
1730 /* --------------------------------------------------------------------------
1732 * ------------------------------------------------------------------------*/
1734 #define OP_CC_B(e) \
1736 unsigned char x = PopTaggedChar(); \
1737 unsigned char y = PopTaggedChar(); \
1738 PushTaggedBool(e); \
1743 unsigned char x = PopTaggedChar(); \
1752 #define OP_IW_I(e) \
1754 StgInt x = PopTaggedInt(); \
1755 StgWord y = PopTaggedWord(); \
1759 #define OP_II_I(e) \
1761 StgInt x = PopTaggedInt(); \
1762 StgInt y = PopTaggedInt(); \
1766 #define OP_II_B(e) \
1768 StgInt x = PopTaggedInt(); \
1769 StgInt y = PopTaggedInt(); \
1770 PushTaggedBool(e); \
1775 PushTaggedAddr(e); \
1780 StgInt x = PopTaggedInt(); \
1781 PushTaggedAddr(e); \
1786 StgInt x = PopTaggedInt(); \
1792 PushTaggedChar(e); \
1797 StgInt x = PopTaggedInt(); \
1798 PushTaggedChar(e); \
1803 PushTaggedWord(e); \
1808 StgInt x = PopTaggedInt(); \
1809 PushTaggedWord(e); \
1814 PushTaggedFloat(e); \
1819 StgInt x = PopTaggedInt(); \
1820 PushTaggedFloat(e); \
1825 PushTaggedDouble(e); \
1830 StgInt x = PopTaggedInt(); \
1831 PushTaggedDouble(e); \
1834 #define OP_WW_B(e) \
1836 StgWord x = PopTaggedWord(); \
1837 StgWord y = PopTaggedWord(); \
1838 PushTaggedBool(e); \
1841 #define OP_WW_W(e) \
1843 StgWord x = PopTaggedWord(); \
1844 StgWord y = PopTaggedWord(); \
1845 PushTaggedWord(e); \
1850 StgWord x = PopTaggedWord(); \
1856 StgWord x = PopTaggedWord(); \
1857 PushTaggedWord(e); \
1860 #define OP_AA_B(e) \
1862 StgAddr x = PopTaggedAddr(); \
1863 StgAddr y = PopTaggedAddr(); \
1864 PushTaggedBool(e); \
1868 StgAddr x = PopTaggedAddr(); \
1871 #define OP_AI_C(s) \
1873 StgAddr x = PopTaggedAddr(); \
1874 int y = PopTaggedInt(); \
1877 PushTaggedChar(r); \
1879 #define OP_AI_I(s) \
1881 StgAddr x = PopTaggedAddr(); \
1882 int y = PopTaggedInt(); \
1887 #define OP_AI_A(s) \
1889 StgAddr x = PopTaggedAddr(); \
1890 int y = PopTaggedInt(); \
1893 PushTaggedAddr(s); \
1895 #define OP_AI_F(s) \
1897 StgAddr x = PopTaggedAddr(); \
1898 int y = PopTaggedInt(); \
1901 PushTaggedFloat(r); \
1903 #define OP_AI_D(s) \
1905 StgAddr x = PopTaggedAddr(); \
1906 int y = PopTaggedInt(); \
1909 PushTaggedDouble(r); \
1911 #define OP_AI_s(s) \
1913 StgAddr x = PopTaggedAddr(); \
1914 int y = PopTaggedInt(); \
1917 PushTaggedStablePtr(r); \
1919 #define OP_AIC_(s) \
1921 StgAddr x = PopTaggedAddr(); \
1922 int y = PopTaggedInt(); \
1923 StgChar z = PopTaggedChar(); \
1926 #define OP_AII_(s) \
1928 StgAddr x = PopTaggedAddr(); \
1929 int y = PopTaggedInt(); \
1930 StgInt z = PopTaggedInt(); \
1933 #define OP_AIA_(s) \
1935 StgAddr x = PopTaggedAddr(); \
1936 int y = PopTaggedInt(); \
1937 StgAddr z = PopTaggedAddr(); \
1940 #define OP_AIF_(s) \
1942 StgAddr x = PopTaggedAddr(); \
1943 int y = PopTaggedInt(); \
1944 StgFloat z = PopTaggedFloat(); \
1947 #define OP_AID_(s) \
1949 StgAddr x = PopTaggedAddr(); \
1950 int y = PopTaggedInt(); \
1951 StgDouble z = PopTaggedDouble(); \
1954 #define OP_AIs_(s) \
1956 StgAddr x = PopTaggedAddr(); \
1957 int y = PopTaggedInt(); \
1958 StgStablePtr z = PopTaggedStablePtr(); \
1963 #define OP_FF_B(e) \
1965 StgFloat x = PopTaggedFloat(); \
1966 StgFloat y = PopTaggedFloat(); \
1967 PushTaggedBool(e); \
1970 #define OP_FF_F(e) \
1972 StgFloat x = PopTaggedFloat(); \
1973 StgFloat y = PopTaggedFloat(); \
1974 PushTaggedFloat(e); \
1979 StgFloat x = PopTaggedFloat(); \
1980 PushTaggedFloat(e); \
1985 StgFloat x = PopTaggedFloat(); \
1986 PushTaggedBool(e); \
1991 StgFloat x = PopTaggedFloat(); \
1997 StgFloat x = PopTaggedFloat(); \
1998 PushTaggedDouble(e); \
2001 #define OP_DD_B(e) \
2003 StgDouble x = PopTaggedDouble(); \
2004 StgDouble y = PopTaggedDouble(); \
2005 PushTaggedBool(e); \
2008 #define OP_DD_D(e) \
2010 StgDouble x = PopTaggedDouble(); \
2011 StgDouble y = PopTaggedDouble(); \
2012 PushTaggedDouble(e); \
2017 StgDouble x = PopTaggedDouble(); \
2018 PushTaggedBool(e); \
2023 StgDouble x = PopTaggedDouble(); \
2024 PushTaggedDouble(e); \
2029 StgDouble x = PopTaggedDouble(); \
2035 StgDouble x = PopTaggedDouble(); \
2036 PushTaggedFloat(e); \
2040 #ifdef STANDALONE_INTEGER
2041 StgPtr CreateByteArrayToHoldInteger ( int nbytes )
2043 StgInt words = (nbytes+sizeof(W_)-1)/sizeof(W_);
2044 StgWord size = sizeofW(StgArrWords) + words;
2045 StgArrWords* arr = (StgArrWords*)allocate(size);
2046 SET_HDR(arr,&ARR_WORDS_info,CCCS);
2048 ASSERT(nbytes <= arr->words * sizeof(W_));
2051 for (i = 0; i < words; ++i) {
2052 arr->payload[i] = 0xdeadbeef;
2054 { B* b = (B*) &(arr->payload[0]);
2055 b->used = b->sign = 0;
2061 B* IntegerInsideByteArray ( StgPtr arr0 )
2064 StgArrWords* arr = (StgArrWords*)arr0;
2065 ASSERT(GET_INFO(arr) == &ARR_WORDS_info);
2066 b = (B*) &(arr->payload[0]);
2070 void SloppifyIntegerEnd ( StgPtr arr0 )
2072 StgArrWords* arr = (StgArrWords*)arr0;
2073 B* b = (B*) & (arr->payload[0]);
2074 I_ nwunused = arr->words - sizeofW(B) - (b->used+sizeof(W_)-1)/sizeof(W_);
2075 if (nwunused >= ((I_)sizeofW(StgArrWords))) {
2077 b->size -= nwunused * sizeof(W_);
2078 if (b->size < b->used) b->size = b->used;
2081 arr->words -= nwunused;
2082 slop = &(arr->payload[arr->words]);
2083 SET_HDR(slop,&ARR_WORDS_info,CCCS);
2084 slop->words = nwunused - sizeofW(StgArrWords);
2085 ASSERT( &(slop->payload[slop->words]) ==
2086 &(arr->payload[arr->words + nwunused]) );
2090 #define OP_Z_Z(op) \
2092 B* x = IntegerInsideByteArray(PopPtr()); \
2093 int n = mycat2(size_,op)(x); \
2094 StgPtr p = CreateByteArrayToHoldInteger(n); \
2095 mycat2(do_,op)(x,n,IntegerInsideByteArray(p)); \
2096 SloppifyIntegerEnd(p); \
2099 #define OP_ZZ_Z(op) \
2101 B* x = IntegerInsideByteArray(PopPtr()); \
2102 B* y = IntegerInsideByteArray(PopPtr()); \
2103 int n = mycat2(size_,op)(x,y); \
2104 StgPtr p = CreateByteArrayToHoldInteger(n); \
2105 mycat2(do_,op)(x,y,n,IntegerInsideByteArray(p)); \
2106 SloppifyIntegerEnd(p); \
2114 #define HEADER_mI(ty,where) \
2115 StgArrWords* x = stgCast(StgArrWords*,PopPtr()); \
2116 nat i = PopTaggedInt(); \
2117 if (i * sizeof(ty) + (sizeof(ty)) > sizeof(StgWord) * x->words) { \
2118 return (raiseIndex(where)); \
2120 #define OP_mI_ty(ty,where,s) \
2122 HEADER_mI(mycat2(Stg,ty),where) \
2123 { mycat2(Stg,ty) r; \
2125 mycat2(PushTagged,ty)(r); \
2128 #define OP_mIty_(ty,where,s) \
2130 HEADER_mI(mycat2(Stg,ty),where) \
2132 mycat2(Stg,ty) z = mycat2(PopTagged,ty)(); \
2138 void myStackCheck ( void )
2140 //StgPtr sp = (StgPtr)Sp;
2141 StgPtr su = (StgPtr)Su;
2142 //fprintf(stderr, "myStackCheck\n");
2143 if (!(SpLim <= Sp && Sp <= stgCast(StgPtr,Su))) {
2144 fprintf(stderr, "myStackCheck: invalid initial Sp/Su \n" );
2148 if (!(su >= CurrentTSO->stack && su <= CurrentTSO->stack + CurrentTSO->stack_size)) {
2149 fprintf ( stderr, "myStackCheck: su out of stack\n" );
2152 switch (get_itbl(stgCast(StgClosure*,su))->type) {
2154 su = (StgPtr) ((StgCatchFrame*)(su))->link;
2157 su = (StgPtr) ((StgUpdateFrame*)(su))->link;
2160 su = (StgPtr) ((StgSeqFrame*)(su))->link;
2165 fprintf(stderr, "myStackCheck: invalid activation record\n"); assert(0);
2172 /* --------------------------------------------------------------------------
2173 * Primop stuff for bytecode interpreter
2174 * ------------------------------------------------------------------------*/
2176 /* Returns & of the next thing to enter (if throwing an exception),
2177 or NULL in the normal case.
2179 static void* enterBCO_primop1 ( int primop1code )
2181 switch (primop1code) {
2182 case i_pushseqframe:
2184 StgClosure* c = PopCPtr();
2189 case i_pushcatchframe:
2191 StgClosure* e = PopCPtr();
2192 StgClosure* h = PopCPtr();
2198 case i_gtChar: OP_CC_B(x>y); break;
2199 case i_geChar: OP_CC_B(x>=y); break;
2200 case i_eqChar: OP_CC_B(x==y); break;
2201 case i_neChar: OP_CC_B(x!=y); break;
2202 case i_ltChar: OP_CC_B(x<y); break;
2203 case i_leChar: OP_CC_B(x<=y); break;
2204 case i_charToInt: OP_C_I(x); break;
2205 case i_intToChar: OP_I_C(x); break;
2207 case i_gtInt: OP_II_B(x>y); break;
2208 case i_geInt: OP_II_B(x>=y); break;
2209 case i_eqInt: OP_II_B(x==y); break;
2210 case i_neInt: OP_II_B(x!=y); break;
2211 case i_ltInt: OP_II_B(x<y); break;
2212 case i_leInt: OP_II_B(x<=y); break;
2213 case i_minInt: OP__I(INT_MIN); break;
2214 case i_maxInt: OP__I(INT_MAX); break;
2215 case i_plusInt: OP_II_I(x+y); break;
2216 case i_minusInt: OP_II_I(x-y); break;
2217 case i_timesInt: OP_II_I(x*y); break;
2220 int x = PopTaggedInt();
2221 int y = PopTaggedInt();
2223 return (raiseDiv0("quotInt"));
2225 /* ToDo: protect against minInt / -1 errors
2226 * (repeat for all other division primops)
2233 int x = PopTaggedInt();
2234 int y = PopTaggedInt();
2236 return (raiseDiv0("remInt"));
2243 StgInt x = PopTaggedInt();
2244 StgInt y = PopTaggedInt();
2246 return (raiseDiv0("quotRemInt"));
2248 PushTaggedInt(x%y); /* last result */
2249 PushTaggedInt(x/y); /* first result */
2252 case i_negateInt: OP_I_I(-x); break;
2254 case i_andInt: OP_II_I(x&y); break;
2255 case i_orInt: OP_II_I(x|y); break;
2256 case i_xorInt: OP_II_I(x^y); break;
2257 case i_notInt: OP_I_I(~x); break;
2258 case i_shiftLInt: OP_II_I(x<<y); break;
2259 case i_shiftRAInt: OP_II_I(x>>y); break; /* ToDo */
2260 case i_shiftRLInt: OP_II_I(x>>y); break; /* ToDo */
2262 case i_gtWord: OP_WW_B(x>y); break;
2263 case i_geWord: OP_WW_B(x>=y); break;
2264 case i_eqWord: OP_WW_B(x==y); break;
2265 case i_neWord: OP_WW_B(x!=y); break;
2266 case i_ltWord: OP_WW_B(x<y); break;
2267 case i_leWord: OP_WW_B(x<=y); break;
2268 case i_minWord: OP__W(0); break;
2269 case i_maxWord: OP__W(UINT_MAX); break;
2270 case i_plusWord: OP_WW_W(x+y); break;
2271 case i_minusWord: OP_WW_W(x-y); break;
2272 case i_timesWord: OP_WW_W(x*y); break;
2275 StgWord x = PopTaggedWord();
2276 StgWord y = PopTaggedWord();
2278 return (raiseDiv0("quotWord"));
2280 PushTaggedWord(x/y);
2285 StgWord x = PopTaggedWord();
2286 StgWord y = PopTaggedWord();
2288 return (raiseDiv0("remWord"));
2290 PushTaggedWord(x%y);
2295 StgWord x = PopTaggedWord();
2296 StgWord y = PopTaggedWord();
2298 return (raiseDiv0("quotRemWord"));
2300 PushTaggedWord(x%y); /* last result */
2301 PushTaggedWord(x/y); /* first result */
2304 case i_negateWord: OP_W_W(-x); break;
2305 case i_andWord: OP_WW_W(x&y); break;
2306 case i_orWord: OP_WW_W(x|y); break;
2307 case i_xorWord: OP_WW_W(x^y); break;
2308 case i_notWord: OP_W_W(~x); break;
2309 case i_shiftLWord: OP_WW_W(x<<y); break;
2310 case i_shiftRAWord: OP_WW_W(x>>y); break; /* ToDo */
2311 case i_shiftRLWord: OP_WW_W(x>>y); break; /* ToDo */
2312 case i_intToWord: OP_I_W(x); break;
2313 case i_wordToInt: OP_W_I(x); break;
2315 case i_gtAddr: OP_AA_B(x>y); break;
2316 case i_geAddr: OP_AA_B(x>=y); break;
2317 case i_eqAddr: OP_AA_B(x==y); break;
2318 case i_neAddr: OP_AA_B(x!=y); break;
2319 case i_ltAddr: OP_AA_B(x<y); break;
2320 case i_leAddr: OP_AA_B(x<=y); break;
2321 case i_intToAddr: OP_I_A((StgAddr)x); break; /* ToDo */
2322 case i_addrToInt: OP_A_I((StgInt)x); break; /* ToDo */
2324 case i_indexCharOffAddr: OP_AI_C(indexCharOffAddrzh(r,x,y)); break;
2325 case i_readCharOffAddr: OP_AI_C(indexCharOffAddrzh(r,x,y)); break;
2326 case i_writeCharOffAddr: OP_AIC_(writeCharOffAddrzh(x,y,z)); break;
2328 case i_indexIntOffAddr: OP_AI_I(indexIntOffAddrzh(r,x,y)); break;
2329 case i_readIntOffAddr: OP_AI_I(indexIntOffAddrzh(r,x,y)); break;
2330 case i_writeIntOffAddr: OP_AII_(writeIntOffAddrzh(x,y,z)); break;
2332 case i_indexAddrOffAddr: OP_AI_A(indexAddrOffAddrzh(r,x,y)); break;
2333 case i_readAddrOffAddr: OP_AI_A(indexAddrOffAddrzh(r,x,y)); break;
2334 case i_writeAddrOffAddr: OP_AIA_(writeAddrOffAddrzh(x,y,z)); break;
2336 case i_indexFloatOffAddr: OP_AI_F(indexFloatOffAddrzh(r,x,y)); break;
2337 case i_readFloatOffAddr: OP_AI_F(indexFloatOffAddrzh(r,x,y)); break;
2338 case i_writeFloatOffAddr: OP_AIF_(writeFloatOffAddrzh(x,y,z)); break;
2340 case i_indexDoubleOffAddr: OP_AI_D(indexDoubleOffAddrzh(r,x,y)); break;
2341 case i_readDoubleOffAddr: OP_AI_D(indexDoubleOffAddrzh(r,x,y)); break;
2342 case i_writeDoubleOffAddr: OP_AID_(writeDoubleOffAddrzh(x,y,z)); break;
2344 #ifdef PROVIDE_STABLE
2345 case i_indexStableOffAddr: OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break;
2346 case i_readStableOffAddr: OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break;
2347 case i_writeStableOffAddr: OP_AIs_(writeStablePtrOffAddrzh(x,y,z)); break;
2350 #ifdef STANDALONE_INTEGER
2351 case i_compareInteger:
2353 B* x = IntegerInsideByteArray(PopPtr());
2354 B* y = IntegerInsideByteArray(PopPtr());
2355 StgInt r = do_cmp(x,y);
2356 PushTaggedInt(r<0 ? -1 : (r>0 ? 1 : 0));
2359 case i_negateInteger: OP_Z_Z(neg); break;
2360 case i_plusInteger: OP_ZZ_Z(add); break;
2361 case i_minusInteger: OP_ZZ_Z(sub); break;
2362 case i_timesInteger: OP_ZZ_Z(mul); break;
2363 case i_quotRemInteger:
2365 B* x = IntegerInsideByteArray(PopPtr());
2366 B* y = IntegerInsideByteArray(PopPtr());
2367 int n = size_qrm(x,y);
2368 StgPtr q = CreateByteArrayToHoldInteger(n);
2369 StgPtr r = CreateByteArrayToHoldInteger(n);
2370 if (do_getsign(y)==0)
2371 return (raiseDiv0("quotRemInteger"));
2372 do_qrm(x,y,n,IntegerInsideByteArray(q),
2373 IntegerInsideByteArray(r));
2374 SloppifyIntegerEnd(q);
2375 SloppifyIntegerEnd(r);
2380 case i_intToInteger:
2382 int n = size_fromInt();
2383 StgPtr p = CreateByteArrayToHoldInteger(n);
2384 do_fromInt( PopTaggedInt(), n, IntegerInsideByteArray(p));
2388 case i_wordToInteger:
2390 int n = size_fromWord();
2391 StgPtr p = CreateByteArrayToHoldInteger(n);
2392 do_fromWord( PopTaggedWord(), n, IntegerInsideByteArray(p));
2396 case i_integerToInt: PushTaggedInt(do_toInt(
2397 IntegerInsideByteArray(PopPtr())
2401 case i_integerToWord: PushTaggedWord(do_toWord(
2402 IntegerInsideByteArray(PopPtr())
2406 case i_integerToFloat: PushTaggedFloat(do_toFloat(
2407 IntegerInsideByteArray(PopPtr())
2411 case i_integerToDouble: PushTaggedDouble(do_toDouble(
2412 IntegerInsideByteArray(PopPtr())
2416 #error Non-standalone integer not yet implemented
2417 #endif /* STANDALONE_INTEGER */
2419 case i_gtFloat: OP_FF_B(x>y); break;
2420 case i_geFloat: OP_FF_B(x>=y); break;
2421 case i_eqFloat: OP_FF_B(x==y); break;
2422 case i_neFloat: OP_FF_B(x!=y); break;
2423 case i_ltFloat: OP_FF_B(x<y); break;
2424 case i_leFloat: OP_FF_B(x<=y); break;
2425 case i_minFloat: OP__F(FLT_MIN); break;
2426 case i_maxFloat: OP__F(FLT_MAX); break;
2427 case i_radixFloat: OP__I(FLT_RADIX); break;
2428 case i_digitsFloat: OP__I(FLT_MANT_DIG); break;
2429 case i_minExpFloat: OP__I(FLT_MIN_EXP); break;
2430 case i_maxExpFloat: OP__I(FLT_MAX_EXP); break;
2431 case i_plusFloat: OP_FF_F(x+y); break;
2432 case i_minusFloat: OP_FF_F(x-y); break;
2433 case i_timesFloat: OP_FF_F(x*y); break;
2436 StgFloat x = PopTaggedFloat();
2437 StgFloat y = PopTaggedFloat();
2440 return (raiseDiv0("divideFloat"));
2443 PushTaggedFloat(x/y);
2446 case i_negateFloat: OP_F_F(-x); break;
2447 case i_floatToInt: OP_F_I(x); break;
2448 case i_intToFloat: OP_I_F(x); break;
2449 case i_expFloat: OP_F_F(exp(x)); break;
2450 case i_logFloat: OP_F_F(log(x)); break;
2451 case i_sqrtFloat: OP_F_F(sqrt(x)); break;
2452 case i_sinFloat: OP_F_F(sin(x)); break;
2453 case i_cosFloat: OP_F_F(cos(x)); break;
2454 case i_tanFloat: OP_F_F(tan(x)); break;
2455 case i_asinFloat: OP_F_F(asin(x)); break;
2456 case i_acosFloat: OP_F_F(acos(x)); break;
2457 case i_atanFloat: OP_F_F(atan(x)); break;
2458 case i_sinhFloat: OP_F_F(sinh(x)); break;
2459 case i_coshFloat: OP_F_F(cosh(x)); break;
2460 case i_tanhFloat: OP_F_F(tanh(x)); break;
2461 case i_powerFloat: OP_FF_F(pow(x,y)); break;
2463 #ifdef STANDALONE_INTEGER
2464 case i_encodeFloatZ:
2466 StgPtr sig = PopPtr();
2467 StgInt exp = PopTaggedInt();
2469 B__encodeFloat(IntegerInsideByteArray(sig), exp)
2473 case i_decodeFloatZ:
2475 StgFloat f = PopTaggedFloat();
2476 StgPtr sig = CreateByteArrayToHoldInteger(size_fltmantissa());
2478 B__decodeFloat(IntegerInsideByteArray(sig), &exp, f);
2484 #error encode/decodeFloatZ not yet implemented for GHC ints
2486 case i_isNaNFloat: OP_F_B(isFloatNaN(x)); break;
2487 case i_isInfiniteFloat: OP_F_B(isFloatInfinite(x)); break;
2488 case i_isNegativeZeroFloat: OP_F_B(isFloatNegativeZero(x)); break;
2489 case i_isDenormalizedFloat: OP_F_B(isFloatDenormalized(x)); break;
2490 case i_gtDouble: OP_DD_B(x>y); break;
2491 case i_geDouble: OP_DD_B(x>=y); break;
2492 case i_eqDouble: OP_DD_B(x==y); break;
2493 case i_neDouble: OP_DD_B(x!=y); break;
2494 case i_ltDouble: OP_DD_B(x<y); break;
2495 case i_leDouble: OP_DD_B(x<=y) break;
2496 case i_minDouble: OP__D(DBL_MIN); break;
2497 case i_maxDouble: OP__D(DBL_MAX); break;
2498 case i_radixDouble: OP__I(FLT_RADIX); break;
2499 case i_digitsDouble: OP__I(DBL_MANT_DIG); break;
2500 case i_minExpDouble: OP__I(DBL_MIN_EXP); break;
2501 case i_maxExpDouble: OP__I(DBL_MAX_EXP); break;
2502 case i_plusDouble: OP_DD_D(x+y); break;
2503 case i_minusDouble: OP_DD_D(x-y); break;
2504 case i_timesDouble: OP_DD_D(x*y); break;
2505 case i_divideDouble:
2507 StgDouble x = PopTaggedDouble();
2508 StgDouble y = PopTaggedDouble();
2511 return (raiseDiv0("divideDouble"));
2514 PushTaggedDouble(x/y);
2517 case i_negateDouble: OP_D_D(-x); break;
2518 case i_doubleToInt: OP_D_I(x); break;
2519 case i_intToDouble: OP_I_D(x); break;
2520 case i_doubleToFloat: OP_D_F(x); break;
2521 case i_floatToDouble: OP_F_F(x); break;
2522 case i_expDouble: OP_D_D(exp(x)); break;
2523 case i_logDouble: OP_D_D(log(x)); break;
2524 case i_sqrtDouble: OP_D_D(sqrt(x)); break;
2525 case i_sinDouble: OP_D_D(sin(x)); break;
2526 case i_cosDouble: OP_D_D(cos(x)); break;
2527 case i_tanDouble: OP_D_D(tan(x)); break;
2528 case i_asinDouble: OP_D_D(asin(x)); break;
2529 case i_acosDouble: OP_D_D(acos(x)); break;
2530 case i_atanDouble: OP_D_D(atan(x)); break;
2531 case i_sinhDouble: OP_D_D(sinh(x)); break;
2532 case i_coshDouble: OP_D_D(cosh(x)); break;
2533 case i_tanhDouble: OP_D_D(tanh(x)); break;
2534 case i_powerDouble: OP_DD_D(pow(x,y)); break;
2536 #ifdef STANDALONE_INTEGER
2537 case i_encodeDoubleZ:
2539 StgPtr sig = PopPtr();
2540 StgInt exp = PopTaggedInt();
2542 B__encodeDouble(IntegerInsideByteArray(sig), exp)
2546 case i_decodeDoubleZ:
2548 StgDouble d = PopTaggedDouble();
2549 StgPtr sig = CreateByteArrayToHoldInteger(size_dblmantissa());
2551 B__decodeDouble(IntegerInsideByteArray(sig), &exp, d);
2557 #error encode/decodeDoubleZ not yet implemented for GHC ints
2559 case i_isNaNDouble: OP_D_B(isDoubleNaN(x)); break;
2560 case i_isInfiniteDouble: OP_D_B(isDoubleInfinite(x)); break;
2561 case i_isNegativeZeroDouble: OP_D_B(isDoubleNegativeZero(x)); break;
2562 case i_isDenormalizedDouble: OP_D_B(isDoubleDenormalized(x)); break;
2563 case i_isIEEEDouble:
2565 PushTaggedBool(rtsTrue);
2569 barf("Unrecognised primop1");
2576 /* For normal cases, return NULL and leave *return2 unchanged.
2577 To return the address of the next thing to enter,
2578 return the address of it and leave *return2 unchanged.
2579 To return a StgThreadReturnCode to the scheduler,
2580 set *return2 to it and return a non-NULL value.
2582 static void* enterBCO_primop2 ( int primop2code,
2583 int* /*StgThreadReturnCode* */ return2 )
2585 switch (primop2code) {
2586 case i_raise: /* raise#{err} */
2588 StgClosure* err = PopCPtr();
2589 return (raiseAnError(err));
2594 StgClosure* init = PopCPtr();
2596 = stgCast(StgMutVar*,allocate(sizeofW(StgMutVar)));
2597 SET_HDR(mv,&MUT_VAR_info,CCCS);
2599 PushPtr(stgCast(StgPtr,mv));
2604 StgMutVar* mv = stgCast(StgMutVar*,PopPtr());
2610 StgMutVar* mv = stgCast(StgMutVar*,PopPtr());
2611 StgClosure* value = PopCPtr();
2617 nat n = PopTaggedInt(); /* or Word?? */
2618 StgClosure* init = PopCPtr();
2619 StgWord size = sizeofW(StgMutArrPtrs) + n;
2622 = stgCast(StgMutArrPtrs*,allocate(size));
2623 SET_HDR(arr,&MUT_ARR_PTRS_info,CCCS);
2625 for (i = 0; i < n; ++i) {
2626 arr->payload[i] = init;
2628 PushPtr(stgCast(StgPtr,arr));
2634 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2635 nat i = PopTaggedInt(); /* or Word?? */
2636 StgWord n = arr->ptrs;
2638 return (raiseIndex("{index,read}Array"));
2640 PushCPtr(arr->payload[i]);
2645 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2646 nat i = PopTaggedInt(); /* or Word? */
2647 StgClosure* v = PopCPtr();
2648 StgWord n = arr->ptrs;
2650 return (raiseIndex("{index,read}Array"));
2652 arr->payload[i] = v;
2656 case i_sizeMutableArray:
2658 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2659 PushTaggedInt(arr->ptrs);
2662 case i_unsafeFreezeArray:
2664 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2665 SET_INFO(arr,&MUT_ARR_PTRS_FROZEN_info);
2666 PushPtr(stgCast(StgPtr,arr));
2669 case i_unsafeFreezeByteArray:
2671 /* Delightfully simple :-) */
2675 case i_sameMutableArray:
2676 case i_sameMutableByteArray:
2678 StgPtr x = PopPtr();
2679 StgPtr y = PopPtr();
2680 PushTaggedBool(x==y);
2684 case i_newByteArray:
2686 nat n = PopTaggedInt(); /* or Word?? */
2687 StgInt words = (n+sizeof(W_)-1)/sizeof(W_);
2688 StgWord size = sizeofW(StgArrWords) + words;
2689 StgArrWords* arr = stgCast(StgArrWords*,allocate(size));
2690 SET_HDR(arr,&ARR_WORDS_info,CCCS);
2694 for (i = 0; i < n; ++i) {
2695 arr->payload[i] = 0xdeadbeef;
2698 PushPtr(stgCast(StgPtr,arr));
2702 /* Most of these generate alignment warnings on Sparcs and similar architectures.
2703 * These are harmless and are caused by the cast to C* in BYTE_ARR_CTS.
2705 case i_indexCharArray:
2706 OP_mI_ty(Char,"indexCharArray", indexCharArrayzh(r,x,i)); break;
2707 case i_readCharArray:
2708 OP_mI_ty(Char,"readCharArray", readCharArrayzh(r,x,i)); break;
2709 case i_writeCharArray:
2710 OP_mIty_(Char,"writeCharArray", writeCharArrayzh(x,i,z)); break;
2712 case i_indexIntArray:
2713 OP_mI_ty(Int,"indexIntArray", indexIntArrayzh(r,x,i)); break;
2714 case i_readIntArray:
2715 OP_mI_ty(Int,"readIntArray", readIntArrayzh(r,x,i)); break;
2716 case i_writeIntArray:
2717 OP_mIty_(Int,"writeIntArray", writeIntArrayzh(x,i,z)); break;
2719 case i_indexAddrArray:
2720 OP_mI_ty(Addr,"indexAddrArray", indexAddrArrayzh(r,x,i)); break;
2721 case i_readAddrArray:
2722 OP_mI_ty(Addr,"readAddrArray", readAddrArrayzh(r,x,i)); break;
2723 case i_writeAddrArray:
2724 OP_mIty_(Addr,"writeAddrArray", writeAddrArrayzh(x,i,z)); break;
2726 case i_indexFloatArray:
2727 OP_mI_ty(Float,"indexFloatArray", indexFloatArrayzh(r,x,i)); break;
2728 case i_readFloatArray:
2729 OP_mI_ty(Float,"readFloatArray", readFloatArrayzh(r,x,i)); break;
2730 case i_writeFloatArray:
2731 OP_mIty_(Float,"writeFloatArray", writeFloatArrayzh(x,i,z)); break;
2733 case i_indexDoubleArray:
2734 OP_mI_ty(Double,"indexDoubleArray", indexDoubleArrayzh(r,x,i)); break;
2735 case i_readDoubleArray:
2736 OP_mI_ty(Double,"readDoubleArray", readDoubleArrayzh(r,x,i)); break;
2737 case i_writeDoubleArray:
2738 OP_mIty_(Double,"writeDoubleArray", writeDoubleArrayzh(x,i,z)); break;
2740 #ifdef PROVIDE_STABLE
2741 case i_indexStableArray:
2742 OP_mI_ty(StablePtr,"indexStableArray", indexStablePtrArrayzh(r,x,i)); break;
2743 case i_readStableArray:
2744 OP_mI_ty(StablePtr,"readStableArray", readStablePtrArrayzh(r,x,i)); break;
2745 case i_writeStableArray:
2746 OP_mIty_(StablePtr,"writeStableArray", writeStablePtrArrayzh(x,i,z)); break;
2752 #ifdef PROVIDE_COERCE
2753 case i_unsafeCoerce:
2755 /* Another nullop */
2759 #ifdef PROVIDE_PTREQUALITY
2760 case i_reallyUnsafePtrEquality:
2761 { /* identical to i_sameRef */
2762 StgPtr x = PopPtr();
2763 StgPtr y = PopPtr();
2764 PushTaggedBool(x==y);
2768 #ifdef PROVIDE_FOREIGN
2769 /* ForeignObj# operations */
2770 case i_makeForeignObj:
2772 StgForeignObj *result
2773 = stgCast(StgForeignObj*,allocate(sizeofW(StgForeignObj)));
2774 SET_HDR(result,&FOREIGN_info,CCCS);
2775 result -> data = PopTaggedAddr();
2776 PushPtr(stgCast(StgPtr,result));
2779 #endif /* PROVIDE_FOREIGN */
2784 = stgCast(StgWeak*,allocate(sizeofW(StgWeak)));
2785 SET_HDR(w, &WEAK_info, CCCS);
2787 w->value = PopCPtr();
2788 w->finaliser = PopCPtr();
2789 w->link = weak_ptr_list;
2791 IF_DEBUG(weak, fprintf(stderr,"New weak pointer at %p\n",w));
2792 PushPtr(stgCast(StgPtr,w));
2797 StgWeak *w = stgCast(StgWeak*,PopPtr());
2798 if (w->header.info == &WEAK_info) {
2799 PushCPtr(w->value); /* last result */
2800 PushTaggedInt(1); /* first result */
2802 PushPtr(stgCast(StgPtr,w)); /* ToDo: error thunk would be better */
2807 #endif /* PROVIDE_WEAK */
2808 #ifdef PROVIDE_STABLE
2809 /* StablePtr# operations */
2810 case i_makeStablePtr:
2811 case i_deRefStablePtr:
2812 case i_freeStablePtr:
2813 { fprintf(stderr,"Evaluator.c:stablePtrOp unimp\n" );
2818 case i_makeStablePtr:
2820 StgStablePtr stable_ptr;
2821 if (stable_ptr_free == NULL) {
2822 enlargeStablePtrTable();
2825 stable_ptr = stable_ptr_free - stable_ptr_table;
2826 stable_ptr_free = (P_*)*stable_ptr_free;
2827 stable_ptr_table[stable_ptr] = PopPtr();
2829 PushTaggedStablePtr(stable_ptr);
2832 case i_deRefStablePtr:
2834 StgStablePtr stable_ptr = PopTaggedStablePtr();
2835 PushPtr(stable_ptr_table[stable_ptr]);
2839 case i_freeStablePtr:
2841 StgStablePtr stable_ptr = PopTaggedStablePtr();
2842 stable_ptr_table[stable_ptr] = (P_)stable_ptr_free;
2843 stable_ptr_free = stable_ptr_table + stable_ptr;
2849 #endif /* PROVIDE_STABLE */
2850 #ifdef PROVIDE_CONCURRENT
2853 StgClosure* c = PopCPtr();
2854 StgTSO* t = createGenThread(RtsFlags.GcFlags.initialStkSize,c);
2855 PushPtr(stgCast(StgPtr,t));
2857 /* switch at the earliest opportunity */
2859 /* but don't automatically switch to GHC - or you'll waste your
2860 * time slice switching back.
2862 * Actually, there's more to it than that: the default
2863 * (ThreadEnterGHC) causes the thread to crash - don't
2864 * understand why. - ADR
2866 t->whatNext = ThreadEnterHugs;
2871 StgTSO* tso = stgCast(StgTSO*,PopPtr());
2873 if (tso == CurrentTSO) { /* suicide */
2874 *return2 = ThreadFinished;
2875 return (void*)(1+(NULL));
2880 { /* identical to i_sameRef */
2881 StgPtr x = PopPtr();
2882 StgPtr y = PopPtr();
2883 PushTaggedBool(x==y);
2888 StgMVar *mvar = stgCast(StgMVar*,allocate(sizeofW(StgMVar)));
2889 SET_INFO(mvar,&EMPTY_MVAR_info);
2890 mvar->head = mvar->tail = EndTSOQueue;
2891 /* ToDo: this is a little strange */
2892 mvar->value = stgCast(StgClosure*,&END_TSO_QUEUE_closure);
2893 PushPtr(stgCast(StgPtr,mvar));
2898 ToDo: another way out of the problem might be to add an explicit
2899 continuation to primTakeMVar: takeMVar v = primTakeMVar v takeMVar.
2900 The problem with this plan is that now I dont know how much to chop
2905 StgMVar *mvar = stgCast(StgMVar*,PopPtr());
2906 /* If the MVar is empty, put ourselves
2907 * on its blocking queue, and wait
2908 * until we're woken up.
2910 if (GET_INFO(mvar) != &FULL_MVAR_info) {
2911 if (mvar->head == EndTSOQueue) {
2912 mvar->head = CurrentTSO;
2914 mvar->tail->link = CurrentTSO;
2916 CurrentTSO->link = EndTSOQueue;
2917 mvar->tail = CurrentTSO;
2919 /* Hack, hack, hack.
2920 * When we block, we push a restart closure
2921 * on the stack - but which closure?
2922 * We happen to know that the BCO we're
2923 * executing looks like this:
2932 * 14: ALLOC_CONSTR 0x8213a80
2942 * so we rearrange the stack to look the
2943 * way it did when we entered this BCO
2945 * What a disgusting hack!
2951 *return2 = ThreadBlocked;
2952 return (void*)(1+(NULL));
2955 PushCPtr(mvar->value);
2956 SET_INFO(mvar,&EMPTY_MVAR_info);
2957 /* ToDo: this is a little strange */
2958 mvar->value = (StgClosure*)&END_TSO_QUEUE_closure;
2965 StgMVar* mvar = stgCast(StgMVar*,PopPtr());
2966 StgClosure* value = PopCPtr();
2967 if (GET_INFO(mvar) == &FULL_MVAR_info) {
2968 return (raisePrim("putMVar {full MVar}"));
2970 /* wake up the first thread on the
2971 * queue, it will continue with the
2972 * takeMVar operation and mark the
2975 StgTSO* tso = mvar->head;
2976 SET_INFO(mvar,&FULL_MVAR_info);
2977 mvar->value = value;
2978 if (tso != EndTSOQueue) {
2979 PUSH_ON_RUN_QUEUE(tso);
2980 mvar->head = tso->link;
2981 tso->link = EndTSOQueue;
2982 if (mvar->head == EndTSOQueue) {
2983 mvar->tail = EndTSOQueue;
2987 /* yield for better communication performance */
2994 /* As PrimOps.h says: Hmm, I'll think about these later. */
2997 #endif /* PROVIDE_CONCURRENT */
3001 CFunDescriptor* descriptor = PopTaggedAddr();
3002 StgAddr funPtr = PopTaggedAddr();
3003 ccall(descriptor,funPtr);
3007 barf("Unrecognised primop2");
3013 /* -----------------------------------------------------------------------------
3014 * ccall support code:
3015 * marshall moves args from C stack to Haskell stack
3016 * unmarshall moves args from Haskell stack to C stack
3017 * argSize calculates how much space you need on the C stack
3018 * ---------------------------------------------------------------------------*/
3020 /* Pop arguments off the C stack and Push them onto the Hugs stack.
3021 * Used when preparing for C calling Haskell or in response to
3022 * Haskell calling C.
3024 nat marshall(char arg_ty, void* arg)
3028 PushTaggedInt(*((int*)arg));
3029 return ARG_SIZE(INT_TAG);
3030 #ifdef TODO_STANDALONE_INTEGER
3032 PushTaggedInteger(*((mpz_ptr*)arg));
3033 return ARG_SIZE(INTEGER_TAG);
3036 PushTaggedWord(*((unsigned int*)arg));
3037 return ARG_SIZE(WORD_TAG);
3039 PushTaggedChar(*((char*)arg));
3040 return ARG_SIZE(CHAR_TAG);
3042 PushTaggedFloat(*((float*)arg));
3043 return ARG_SIZE(FLOAT_TAG);
3045 PushTaggedDouble(*((double*)arg));
3046 return ARG_SIZE(DOUBLE_TAG);
3048 PushTaggedAddr(*((void**)arg));
3049 return ARG_SIZE(ADDR_TAG);
3050 #ifdef PROVIDE_STABLE
3052 PushTaggedStablePtr(*((StgStablePtr*)arg));
3053 return ARG_SIZE(STABLE_TAG);
3055 #ifdef PROVIDE_FOREIGN
3057 /* Not allowed in this direction - you have to
3058 * call makeForeignPtr explicitly
3060 barf("marshall: ForeignPtr#\n");
3065 /* Not allowed in this direction */
3066 barf("marshall: [Mutable]ByteArray#\n");
3069 barf("marshall: unrecognised arg type %d\n",arg_ty);
3074 /* Pop arguments off the Hugs stack and Push them onto the C stack.
3075 * Used when preparing for Haskell calling C or in response to
3076 * C calling Haskell.
3078 nat unmarshall(char res_ty, void* res)
3082 *((int*)res) = PopTaggedInt();
3083 return ARG_SIZE(INT_TAG);
3084 #ifdef TODO_STANDALONE_INTEGER
3086 *((mpz_ptr*)res) = PopTaggedInteger();
3087 return ARG_SIZE(INTEGER_TAG);
3090 *((unsigned int*)res) = PopTaggedWord();
3091 return ARG_SIZE(WORD_TAG);
3093 *((int*)res) = PopTaggedChar();
3094 return ARG_SIZE(CHAR_TAG);
3096 *((float*)res) = PopTaggedFloat();
3097 return ARG_SIZE(FLOAT_TAG);
3099 *((double*)res) = PopTaggedDouble();
3100 return ARG_SIZE(DOUBLE_TAG);
3102 *((void**)res) = PopTaggedAddr();
3103 return ARG_SIZE(ADDR_TAG);
3104 #ifdef PROVIDE_STABLE
3106 *((StgStablePtr*)res) = PopTaggedStablePtr();
3107 return ARG_SIZE(STABLE_TAG);
3109 #ifdef PROVIDE_FOREIGN
3112 StgForeignObj *result = stgCast(StgForeignObj*,PopPtr());
3113 *((void**)res) = result->data;
3114 return sizeofW(StgPtr);
3120 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
3121 *((void**)res) = stgCast(void*,&(arr->payload));
3122 return sizeofW(StgPtr);
3125 barf("unmarshall: unrecognised result type %d\n",res_ty);
3129 nat argSize( const char* ks )
3132 for( ; *ks != '\0'; ++ks) {
3135 sz += sizeof(StgWord) * ARG_SIZE(INT_TAG);
3137 #ifdef TODO_STANDALONE_INTEGER
3139 sz += sizeof(StgWord) * ARG_SIZE(INTEGER_TAG);
3143 sz += sizeof(StgWord) * ARG_SIZE(WORD_TAG);
3146 sz += sizeof(StgWord) * ARG_SIZE(CHAR_TAG);
3149 sz += sizeof(StgWord) * ARG_SIZE(FLOAT_TAG);
3152 sz += sizeof(StgWord) * ARG_SIZE(DOUBLE_TAG);
3155 sz += sizeof(StgWord) * ARG_SIZE(ADDR_TAG);
3157 #ifdef PROVIDE_STABLE
3159 sz += sizeof(StgWord) * ARG_SIZE(STABLE_TAG);
3162 #ifdef PROVIDE_FOREIGN
3167 sz += sizeof(StgPtr);
3170 barf("argSize: unrecognised result type %d\n",*ks);
3178 /* -----------------------------------------------------------------------------
3179 * encode/decode Float/Double code for standalone Hugs
3180 * Code based on the HBC code (lib/fltcode.c) and more recently GHC
3181 * (ghc/rts/StgPrimFloat.c)
3182 * ---------------------------------------------------------------------------*/
3184 #ifdef STANDALONE_INTEGER
3186 #if IEEE_FLOATING_POINT
3187 #define MY_DMINEXP ((DBL_MIN_EXP) - (DBL_MANT_DIG) - 1)
3188 /* DMINEXP is defined in values.h on Linux (for example) */
3189 #define DHIGHBIT 0x00100000
3190 #define DMSBIT 0x80000000
3192 #define MY_FMINEXP ((FLT_MIN_EXP) - (FLT_MANT_DIG) - 1)
3193 #define FHIGHBIT 0x00800000
3194 #define FMSBIT 0x80000000
3196 #error The following code doesnt work in a non-IEEE FP environment
3199 #ifdef WORDS_BIGENDIAN
3208 StgDouble B__encodeDouble (B* s, I_ e) /* result = s * 2^e */
3213 /* Convert a B to a double; knows a lot about internal rep! */
3214 for(r = 0.0, i = s->used-1; i >= 0; i--)
3215 r = (r * B_BASE_FLT) + s->stuff[i];
3217 /* Now raise to the exponent */
3218 if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
3221 /* handle the sign */
3222 if (s->sign < 0) r = -r;
3229 #if ! FLOATS_AS_DOUBLES
3230 StgFloat B__encodeFloat (B* s, I_ e) /* result = s * 2^e */
3235 /* Convert a B to a float; knows a lot about internal rep! */
3236 for(r = 0.0, i = s->used-1; i >= 0; i--)
3237 r = (r * B_BASE_FLT) + s->stuff[i];
3239 /* Now raise to the exponent */
3240 if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
3243 /* handle the sign */
3244 if (s->sign < 0) r = -r;
3248 #endif /* FLOATS_AS_DOUBLES */
3252 /* This only supports IEEE floating point */
3253 void B__decodeDouble (B* man, I_* exp, StgDouble dbl)
3255 /* Do some bit fiddling on IEEE */
3256 nat low, high; /* assuming 32 bit ints */
3258 union { double d; int i[2]; } u; /* assuming 32 bit ints, 64 bit double */
3260 u.d = dbl; /* grab chunks of the double */
3264 ASSERT(B_BASE == 256);
3266 /* Assume that the supplied B is the right size */
3269 if (low == 0 && (high & ~DMSBIT) == 0) {
3270 man->sign = man->used = 0;
3275 iexp = ((high >> 20) & 0x7ff) + MY_DMINEXP;
3279 if (iexp != MY_DMINEXP) /* don't add hidden bit to denorms */
3283 /* A denorm, normalize the mantissa */
3284 while (! (high & DHIGHBIT)) {
3294 man->stuff[7] = (((W_)high) >> 24) & 0xff;
3295 man->stuff[6] = (((W_)high) >> 16) & 0xff;
3296 man->stuff[5] = (((W_)high) >> 8) & 0xff;
3297 man->stuff[4] = (((W_)high) ) & 0xff;
3299 man->stuff[3] = (((W_)low) >> 24) & 0xff;
3300 man->stuff[2] = (((W_)low) >> 16) & 0xff;
3301 man->stuff[1] = (((W_)low) >> 8) & 0xff;
3302 man->stuff[0] = (((W_)low) ) & 0xff;
3304 if (sign < 0) man->sign = -1;
3306 do_renormalise(man);
3310 #if ! FLOATS_AS_DOUBLES
3311 void B__decodeFloat (B* man, I_* exp, StgFloat flt)
3313 /* Do some bit fiddling on IEEE */
3314 int high, sign; /* assuming 32 bit ints */
3315 union { float f; int i; } u; /* assuming 32 bit float and int */
3317 u.f = flt; /* grab the float */
3320 ASSERT(B_BASE == 256);
3322 /* Assume that the supplied B is the right size */
3325 if ((high & ~FMSBIT) == 0) {
3326 man->sign = man->used = 0;
3331 *exp = ((high >> 23) & 0xff) + MY_FMINEXP;
3335 if (*exp != MY_FMINEXP) /* don't add hidden bit to denorms */
3339 /* A denorm, normalize the mantissa */
3340 while (! (high & FHIGHBIT)) {
3345 man->stuff[3] = (((W_)high) >> 24) & 0xff;
3346 man->stuff[2] = (((W_)high) >> 16) & 0xff;
3347 man->stuff[1] = (((W_)high) >> 8) & 0xff;
3348 man->stuff[0] = (((W_)high) ) & 0xff;
3350 if (sign < 0) man->sign = -1;
3352 do_renormalise(man);
3355 #endif /* FLOATS_AS_DOUBLES */
3357 #endif /* STANDALONE_INTEGER */
3361 #endif /* INTERPRETER */