2 /* -----------------------------------------------------------------------------
5 * Copyright (c) 1994-1998.
7 * $RCSfile: Evaluator.c,v $
9 * $Date: 1999/10/29 13:41:29 $
10 * ---------------------------------------------------------------------------*/
20 #include "SchedAPI.h" /* for createGenThread */
21 #include "Schedule.h" /* for context_switch */
22 #include "Bytecodes.h"
23 #include "Assembler.h" /* for CFun stuff */
24 #include "ForeignCall.h"
25 #include "PrimOps.h" /* for __{encode,decode}{Float,Double} */
26 #include "Evaluator.h"
30 #include "Disassembler.h"
35 #include <math.h> /* These are for primops */
36 #include <limits.h> /* These are for primops */
37 #include <float.h> /* These are for primops */
39 #include <ieee754.h> /* These are for primops */
42 #ifdef STANDALONE_INTEGER
43 #include "sainteger.h"
45 #error Non-standalone integer not yet supported
48 /* An incredibly useful abbreviation.
49 * Interestingly, there are some uses of END_TSO_QUEUE_closure that
50 * can't use it because they use the closure at type StgClosure* or
51 * even StgPtr*. I suspect they should be changed. -- ADR
53 #define EndTSOQueue stgCast(StgTSO*,(void*)&END_TSO_QUEUE_closure)
55 /* These macros are rather delicate - read a good ANSI C book carefully
59 #define mycat(x,y) x##y
60 #define mycat2(x,y) mycat(x,y)
61 #define mycat3(x,y,z) mycat2(x,mycat2(y,z))
63 #if defined(__GNUC__) && !defined(DEBUG)
64 #define USE_GCC_LABELS 1
66 #define USE_GCC_LABELS 0
69 /* Make it possible for the evaluator to get hold of bytecode
70 for a given function by name. Useful but a hack. Sigh.
72 extern void* getHugs_AsmObject_for ( char* s );
75 /* --------------------------------------------------------------------------
76 * Crude profiling stuff (mainly to assess effect of optimiser)
77 * ------------------------------------------------------------------------*/
79 #ifdef CRUDE_PROFILING
88 struct { int /*StgVar*/ who;
96 CPRecord cpTab[M_CPTAB];
103 for (i = 0; i < M_CPTAB; i++)
104 cpTab[i].who = CP_NIL;
108 void cp_enter ( StgBCO* b )
112 int /*StgVar*/ v = b->stgexpr;
113 if ((void*)v == NULL) return;
122 h = (-v) % M_CPTAB; else
125 assert (h >= 0 && h < M_CPTAB);
126 while (cpTab[h].who != v && cpTab[h].who != CP_NIL) {
127 h++; if (h == M_CPTAB) h = 0;
130 if (cpTab[cpCurr].who == CP_NIL) {
131 cpTab[cpCurr].who = v;
132 if (!is_ret_cont) cpTab[cpCurr].enters = 1;
133 cpTab[cpCurr].bytes = cpTab[cpCurr].insns = 0;
135 if (cpInUse * 2 > M_CPTAB) {
136 fprintf(stderr, "\nCRUDE_PROFILING hash table is too full\n" );
140 if (!is_ret_cont) cpTab[cpCurr].enters++;
146 void cp_bill_words ( int nw )
148 if (cpCurr == CP_NIL) return;
149 cpTab[cpCurr].bytes += sizeof(StgWord)*nw;
153 void cp_bill_insns ( int ni )
155 if (cpCurr == CP_NIL) return;
156 cpTab[cpCurr].insns += ni;
160 static double percent ( double a, double b )
162 return (100.0 * a) / b;
166 void cp_show ( void )
168 int i, j, max, maxN, totE, totB, totI, cumE, cumB, cumI;
171 if (cpInUse == -1) return;
173 fflush(stdout);fflush(stderr);
176 totE = totB = totI = 0;
177 for (i = 0; i < M_CPTAB; i++) {
178 cpTab[i].twho = cpTab[i].who;
179 if (cpTab[i].who != CP_NIL) {
180 totE += cpTab[i].enters;
181 totB += cpTab[i].bytes;
182 totI += cpTab[i].insns;
187 "%6d (%7.3f M) enters, "
188 "%6d (%7.3f M) insns, "
189 "%6d (%7.3f M) bytes\n\n",
190 totE, totE/1000000.0, totI, totI/1000000.0, totB, totB/1000000.0 );
192 cumE = cumB = cumI = 0;
193 for (j = 0; j < 32; j++) {
196 for (i = 0; i < M_CPTAB; i++)
197 if (cpTab[i].who != CP_NIL &&
198 cpTab[i].enters > maxN) {
199 maxN = cpTab[i].enters;
202 if (max == -1) break;
204 cumE += cpTab[max].enters;
205 cumB += cpTab[max].bytes;
206 cumI += cpTab[max].insns;
208 strcpy(nm, maybeName(cpTab[max].who));
209 if (strcmp(nm, "(unknown)")==0)
210 sprintf ( nm, "id%d", -cpTab[max].who);
212 printf ( "%20s %7d es (%4.1f%%, %4.1f%% c) "
213 "%7d bs (%4.1f%%, %4.1f%% c) "
214 "%7d is (%4.1f%%, %4.1f%% c)\n",
216 cpTab[max].enters, percent(cpTab[max].enters,totE), percent(cumE,totE),
217 cpTab[max].bytes, percent(cpTab[max].bytes,totB), percent(cumB,totB),
218 cpTab[max].insns, percent(cpTab[max].insns,totI), percent(cumI,totI)
221 cpTab[max].twho = cpTab[max].who;
222 cpTab[max].who = CP_NIL;
225 for (i = 0; i < M_CPTAB; i++)
226 cpTab[i].who = cpTab[i].twho;
234 /* --------------------------------------------------------------------------
235 * Hugs Hooks - a bit of a hack
236 * ------------------------------------------------------------------------*/
238 void setRtsFlags( int x );
239 void setRtsFlags( int x )
241 unsigned int w = 0x12345678;
242 unsigned char* pw = (unsigned char *)&w;
245 *(int*)(&(RtsFlags.DebugFlags)) = x;
250 w2 |= (w1 && 0xFF); w2 <<= 8; w1 >>= 8;
251 w2 |= (w1 && 0xFF); w2 <<= 8; w1 >>= 8;
252 w2 |= (w1 && 0xFF); w2 <<= 8; w1 >>= 8;
253 w2 |= (w1 && 0xFF); w2 <<= 8; w1 >>= 8;
254 *(int*)(&(RtsFlags.DebugFlags)) = (int)w2;
258 /* --------------------------------------------------------------------------
261 * ToDo: figure out why these are being used and crush them!
262 * ------------------------------------------------------------------------*/
264 void OnExitHook (void)
267 void StackOverflowHook (unsigned long stack_size)
269 fprintf(stderr,"Stack Overflow\n");
272 void OutOfHeapHook (unsigned long request_size, unsigned long heap_size)
274 fprintf(stderr,"Out Of Heap\n");
277 void MallocFailHook (unsigned long request_size /* in bytes */, char *msg)
279 fprintf(stderr,"Malloc Fail\n");
282 void defaultsHook (void)
288 /* --------------------------------------------------------------------------
289 * Entering-objects and bytecode interpreter part of evaluator
290 * ------------------------------------------------------------------------*/
292 /* The primop (and all other) parts of this evaluator operate upon the
293 machine state which lives in MainRegTable. enter is different:
294 to make its closure- and bytecode-interpreting loops go fast, some of that
295 state is pulled out into local vars (viz, registers, if we are lucky).
296 That means that we need to save(load) the local state at every exit(reentry)
297 into enter. That is, around every procedure call it makes. Blargh!
298 If you modify this code, __be warned__ it will fail in mysterious ways if
299 you fail to preserve this property.
301 Currently the pulled-out state is Sp in xSp, Su in xSu and SpLim in xSpLim.
302 The SSS macros saves the state back in MainRegTable, and LLL loads it from
303 MainRegTable. RETURN(v) does SSS and then returns v; all exits should
304 be via RETURN and not plain return.
306 Since xSp, xSu and xSpLim are local vars in enter, they are not visible
307 in procedures called from enter. To fix this, either (1) turn the
308 procedures into macros, so they get copied inline, or (2) bracket
309 the procedure call with SSS and LLL so that the local and global
310 machine states are synchronised for the duration of the call.
314 /* Forward decls ... */
315 static void* enterBCO_primop1 ( int );
316 static void* enterBCO_primop2 ( int , int* /*StgThreadReturnCode* */, StgBCO** );
317 static inline void PopUpdateFrame ( StgClosure* obj );
318 static inline void PopCatchFrame ( void );
319 static inline void PopSeqFrame ( void );
320 static inline void PopStopFrame( StgClosure* obj );
321 static inline void PushTaggedRealWorld( void );
322 static inline void PushTaggedInteger ( mpz_ptr );
323 static inline StgPtr grabHpUpd( nat size );
324 static inline StgPtr grabHpNonUpd( nat size );
325 static StgClosure* raiseAnError ( StgClosure* errObj );
327 static int enterCountI = 0;
329 #ifdef STANDALONE_INTEGER
330 StgDouble B__encodeDouble (B* s, I_ e);
331 void B__decodeDouble (B* man, I_* exp, StgDouble dbl);
332 #if ! FLOATS_AS_DOUBLES
333 StgFloat B__encodeFloat (B* s, I_ e);
334 void B__decodeFloat (B* man, I_* exp, StgFloat flt);
335 StgPtr CreateByteArrayToHoldInteger ( int );
336 B* IntegerInsideByteArray ( StgPtr );
337 void SloppifyIntegerEnd ( StgPtr );
344 /* Macros to save/load local state. */
346 #define SSS { tSp=Sp = xSp; tSu=Su = xSu; tSpLim=SpLim = xSpLim; }
347 #define LLL { tSp=xSp = Sp; tSu=xSu = Su; tSpLim=xSpLim = SpLim; }
349 #define SSS { Sp = xSp; Su = xSu; SpLim = xSpLim; }
350 #define LLL { xSp = Sp; xSu = Su; xSpLim = SpLim; }
353 #define RETURN(vvv) { \
354 StgThreadReturnCode retVal=(vvv); SSS; \
355 /* SaveThreadState() is done by the scheduler. */ \
360 /* Macros to operate directly on the pulled-out machine state.
361 These mirror some of the small procedures used in the primop code
362 below, except you have to be careful about side effects,
363 ie xPushPtr(xStackPtr(n)) won't work! It certainly isn't the
364 same as PushPtr(StackPtr(n)). Also note that (1) some of
365 the macros, in particular xPopTagged*, do not make the tag
366 sanity checks that their non-x cousins do, and (2) some of
367 the macros depend critically on the semantics of C comma
368 expressions to work properly
370 #define xPushPtr(ppp) { xSp--; *xSp=(StgWord)(ppp); }
371 #define xPopPtr() ((StgPtr)(*xSp++))
373 #define xPushCPtr(ppp) { xSp--; *xSp=(StgWord)(ppp); }
374 #define xPopCPtr() ((StgClosure*)(*xSp++))
376 #define xPushWord(ppp) { xSp--; *xSp=(StgWord)(ppp); }
377 #define xPopWord() ((StgWord)(*xSp++))
379 #define xStackPtr(nnn) ((StgPtr)(*(xSp+(nnn))))
380 #define xStackWord(nnn) ((StgWord)(*(xSp+(nnn))))
381 #define xSetStackWord(iii,www) xSp[iii]=(StgWord)(www)
383 #define xPushTag(ttt) { xSp--; *xSp=(StgWord)(ttt); }
384 #define xPopTag(ttt) { StackTag t = (StackTag)(*xSp++); \
387 #define xPushTaggedInt(xxx) { xSp -= sizeofW(StgInt); \
388 *xSp = (xxx); xPushTag(INT_TAG); }
389 #define xTaggedStackInt(iii) ((StgInt)(*(xSp+1+(iii))))
390 #define xPopTaggedInt() ((xSp++,xSp+=sizeofW(StgInt), \
391 (StgInt)(*(xSp-sizeofW(StgInt)))))
393 #define xPushTaggedWord(xxx) { xSp -= sizeofW(StgWord); \
394 *xSp = (xxx); xPushTag(WORD_TAG); }
395 #define xTaggedStackWord(iii) ((StgWord)(*(xSp+1+(iii))))
396 #define xPopTaggedWord() ((xSp++,xSp+=sizeofW(StgWord), \
397 (StgWord)(*(xSp-sizeofW(StgWord)))))
399 #define xPushTaggedAddr(xxx) { xSp -= sizeofW(StgAddr); \
400 *xSp = (StgWord)(xxx); xPushTag(ADDR_TAG); }
401 #define xTaggedStackAddr(iii) ((StgAddr)(*(xSp+1+(iii))))
402 #define xPopTaggedAddr() ((xSp++,xSp+=sizeofW(StgAddr), \
403 (StgAddr)(*(xSp-sizeofW(StgAddr)))))
405 #define xPushTaggedStable(xxx) { xSp -= sizeofW(StgStablePtr); \
406 *xSp = (StgWord)(xxx); xPushTag(STABLE_TAG); }
407 #define xTaggedStackStable(iii) ((StgStablePtr)(*(xSp+1+(iii))))
408 #define xPopTaggedStable() ((xSp++,xSp+=sizeofW(StgStablePtr), \
409 (StgStablePtr)(*(xSp-sizeofW(StgStablePtr)))))
411 #define xPushTaggedChar(xxx) { xSp -= sizeofW(StgChar); \
412 *xSp = (StgWord)(xxx); xPushTag(CHAR_TAG); }
413 #define xTaggedStackChar(iii) ((StgChar)(*(xSp+1+(iii))))
414 #define xPopTaggedChar() ((xSp++,xSp+=sizeofW(StgChar), \
415 (StgChar)(*(xSp-sizeofW(StgChar)))))
417 #define xPushTaggedFloat(xxx) { xSp -= sizeofW(StgFloat); \
418 ASSIGN_FLT(xSp,xxx); xPushTag(FLOAT_TAG); }
419 #define xTaggedStackFloat(iii) PK_FLT(xSp+1+(iii))
420 #define xPopTaggedFloat() ((xSp++,xSp+=sizeofW(StgFloat), \
421 PK_FLT(xSp-sizeofW(StgFloat))))
423 #define xPushTaggedDouble(xxx) { xSp -= sizeofW(StgDouble); \
424 ASSIGN_DBL(xSp,xxx); xPushTag(DOUBLE_TAG); }
425 #define xTaggedStackDouble(iii) PK_DBL(xSp+1+(iii))
426 #define xPopTaggedDouble() ((xSp++,xSp+=sizeofW(StgDouble), \
427 PK_DBL(xSp-sizeofW(StgDouble))))
430 #define xPopUpdateFrame(ooo) \
432 /* NB: doesn't assume that Sp == Su */ \
433 IF_DEBUG(evaluator, \
434 fprintf(stderr, "Updating "); \
435 printPtr(stgCast(StgPtr,xSu->updatee)); \
436 fprintf(stderr, " with "); \
438 fprintf(stderr,"xSp = %p\txSu = %p\n\n", xSp, xSu); \
440 UPD_IND(xSu->updatee,ooo); \
441 xSp = stgCast(StgStackPtr,xSu) + sizeofW(StgUpdateFrame); \
447 /* Instruction stream macros */
448 #define BCO_INSTR_8 *bciPtr++
449 #define BCO_INSTR_16 ((bciPtr += 2, (*(bciPtr-2) << 8) + *(bciPtr-1)))
450 #define PC (bciPtr - &(bcoInstr(bco,0)))
453 StgThreadReturnCode enter( StgClosure* obj0 )
455 /* use of register here is primarily to make it clear to compilers
456 that these entities are non-aliasable.
458 register StgPtr xSp; /* local state -- stack pointer */
459 register StgUpdateFrame* xSu; /* local state -- frame pointer */
460 register StgPtr xSpLim; /* local state -- stack lim pointer */
461 register StgClosure* obj; /* object currently under evaluation */
462 char eCount; /* enter counter, for context switching */
465 /* use the t values to check that Su/Sp/SpLim do not change unexpectedly */
466 StgPtr tSp; StgUpdateFrame* tSu; StgPtr tSpLim;
468 /* LoadThreadState() is done by the scheduler. */
470 tSp = Sp; tSu = Su; tSpLim = SpLim;
476 /* Load the local state from global state, and Party On, Dudes! */
477 /* From here onwards, we operate with the local state and
478 save/reload it as necessary.
487 assert(SpLim == tSpLim);
491 ASSERT(xSpLim <= xSp && xSp <= stgCast(StgPtr,xSu));
493 "\n---------------------------------------------------------------\n");
494 fprintf(stderr,"(%d) Entering: ",enterCountI); printObj(obj);
495 fprintf(stderr,"xSp = %p\txSu = %p\n", xSp, xSu);
496 fprintf(stderr, "\n" );
497 printStack(xSp,CurrentTSO->stack+CurrentTSO->stack_size,xSu);
498 fprintf(stderr, "\n\n");
508 if (context_switch) {
509 xPushCPtr(obj); /* code to restart with */
510 RETURN(ThreadYielding);
514 switch ( get_itbl(obj)->type ) {
516 barf("Invalid object %p",obj);
520 /* ---------------------------------------------------- */
521 /* Start of the bytecode evaluator */
522 /* ---------------------------------------------------- */
525 # define Ins(x) &&l##x
526 static void *labs[] = { INSTRLIST };
528 # define LoopTopLabel
529 # define Case(x) l##x
530 # define Continue goto *labs[BCO_INSTR_8]
531 # define Dispatch Continue;
534 # define LoopTopLabel insnloop:
535 # define Case(x) case x
536 # define Continue goto insnloop
537 # define Dispatch switch (BCO_INSTR_8) {
538 # define EndDispatch }
541 register StgWord8* bciPtr; /* instruction pointer */
542 register StgBCO* bco = (StgBCO*)obj;
545 /* Don't need to SSS ... LLL around doYouWantToGC */
546 wantToGC = doYouWantToGC();
548 xPushCPtr((StgClosure*)bco); /* code to restart with */
549 RETURN(HeapOverflow);
557 bciPtr = &(bcoInstr(bco,0));
561 ASSERT(PC < bco->n_instrs);
563 fprintf(stderr,"Sp = %p\tSu = %p\tpc = %d\t", xSp, xSu, PC);
567 fprintf(stderr,"\n");
568 for (i = 8; i >= 0; i--)
569 fprintf(stderr, "%d %p\n", i, (StgPtr)(*(Sp+i)));
571 fprintf(stderr,"\n");
576 SSS; cp_bill_insns(1); LLL;
581 Case(i_INTERNAL_ERROR):
582 barf("INTERNAL_ERROR at %p:%d",bco,PC-1);
584 barf("PANIC at %p:%d",bco,PC-1);
588 if (xSp - n < xSpLim) {
589 xPushCPtr((StgClosure*)bco); /* code to restart with */
590 RETURN(StackOverflow);
597 if ((StgPtr*)(xSp + n) > (StgPtr*)xSu) {
598 StgWord words = (P_)xSu - xSp;
600 /* first build a PAP */
601 ASSERT((P_)xSu >= xSp); /* was (words >= 0) but that's always true */
602 if (words == 0) { /* optimisation */
603 /* Skip building the PAP and update with an indirection. */
606 /* In the evaluator, we avoid the need to do
607 * a heap check here by including the size of
608 * the PAP in the heap check we performed
609 * when we entered the BCO.
613 SSS; pap = (StgPAP*)grabHpNonUpd(PAP_sizeW(words)); LLL;
614 SET_HDR(pap,&PAP_info,CC_pap);
617 for (i = 0; i < (I_)words; ++i) {
618 payloadWord(pap,i) = xSp[i];
621 obj = stgCast(StgClosure*,pap);
624 /* now deal with "update frame" */
625 /* as an optimisation, we process all on top of stack */
626 /* instead of just the top one */
627 ASSERT(xSp==(P_)xSu);
629 switch (get_itbl(xSu)->type) {
631 /* Hit a catch frame during an arg satisfaction check,
632 * so the thing returning (1) has not thrown an
633 * exception, and (2) is of functional type. Just
634 * zap the catch frame and carry on down the stack
635 * (looking for more arguments, basically).
637 SSS; PopCatchFrame(); LLL;
640 xPopUpdateFrame(obj);
643 SSS; PopStopFrame(obj); LLL;
644 RETURN(ThreadFinished);
646 SSS; PopSeqFrame(); LLL;
647 ASSERT(xSp != (P_)xSu);
648 /* Hit a SEQ frame during an arg satisfaction check.
649 * So now return to bco_info which is under the
650 * SEQ frame. The following code is copied from a
651 * case RET_BCO further down. (The reason why we're
652 * here is that something of functional type has
653 * been seq-d on, and we're now returning to the
654 * algebraic-case-continuation which forced the
655 * evaluation in the first place.)
667 barf("Invalid update frame during argcheck");
669 } while (xSp==(P_)xSu);
677 int words = BCO_INSTR_8;
678 SSS; p = grabHpUpd(AP_sizeW(words)); LLL;
682 Case(i_ALLOC_CONSTR):
685 StgInfoTable* info = bcoConstAddr(bco,BCO_INSTR_8);
686 SSS; p = grabHpNonUpd(sizeW_fromITBL(info)); LLL;
687 SET_HDR((StgClosure*)p,info,??);
693 int x = BCO_INSTR_8; /* ToDo: Word not Int! */
695 StgAP_UPD* o = stgCast(StgAP_UPD*,xStackPtr(x));
696 SET_HDR(o,&AP_UPD_info,??);
698 o->fun = stgCast(StgClosure*,xPopPtr());
699 for(x=0; x < y; ++x) {
700 payloadWord(o,x) = xPopWord();
703 fprintf(stderr,"\tBuilt ");
705 printObj(stgCast(StgClosure*,o));
716 o = stgCast(StgAP_UPD*,xStackPtr(x));
717 SET_HDR(o,&AP_UPD_info,??);
719 o->fun = stgCast(StgClosure*,xPopPtr());
720 for(x=0; x < y; ++x) {
721 payloadWord(o,x) = xPopWord();
724 fprintf(stderr,"\tBuilt ");
726 printObj(stgCast(StgClosure*,o));
735 StgPAP* o = stgCast(StgPAP*,xStackPtr(x));
736 SET_HDR(o,&PAP_info,??);
738 o->fun = stgCast(StgClosure*,xPopPtr());
739 for(x=0; x < y; ++x) {
740 payloadWord(o,x) = xPopWord();
743 fprintf(stderr,"\tBuilt ");
745 printObj(stgCast(StgClosure*,o));
752 int offset = BCO_INSTR_8;
753 StgClosure* o = stgCast(StgClosure*,xStackPtr(offset));
754 const StgInfoTable* info = get_itbl(o);
755 nat p = info->layout.payload.ptrs;
756 nat np = info->layout.payload.nptrs;
758 for(i=0; i < p; ++i) {
759 payloadCPtr(o,i) = xPopCPtr();
761 for(i=0; i < np; ++i) {
762 payloadWord(o,p+i) = 0xdeadbeef;
765 fprintf(stderr,"\tBuilt ");
767 printObj(stgCast(StgClosure*,o));
774 int offset = BCO_INSTR_16;
775 StgClosure* o = stgCast(StgClosure*,xStackPtr(offset));
776 const StgInfoTable* info = get_itbl(o);
777 nat p = info->layout.payload.ptrs;
778 nat np = info->layout.payload.nptrs;
780 for(i=0; i < p; ++i) {
781 payloadCPtr(o,i) = xPopCPtr();
783 for(i=0; i < np; ++i) {
784 payloadWord(o,p+i) = 0xdeadbeef;
787 fprintf(stderr,"\tBuilt ");
789 printObj(stgCast(StgClosure*,o));
798 ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
799 /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
801 xSetStackWord(x+y,xStackWord(x));
811 ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
812 /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
814 xSetStackWord(x+y,xStackWord(x));
826 xPushPtr(bcoConstPtr(bco,BCO_INSTR_8));
827 xPushPtr(stgCast(StgPtr,&ret_bco_info));
832 int tag = BCO_INSTR_8;
833 StgWord offset = BCO_INSTR_16;
834 if (constrTag(stgCast(StgClosure*,xStackPtr(0))) != tag) {
841 StgClosure* o = stgCast(StgClosure*,xStackPtr(0));
842 const StgInfoTable* itbl = get_itbl(o);
843 int i = itbl->layout.payload.ptrs;
844 ASSERT( itbl->type == CONSTR
845 || itbl->type == CONSTR_STATIC
846 || itbl->type == CONSTR_NOCAF_STATIC
847 || itbl->type == CONSTR_1_0
848 || itbl->type == CONSTR_0_1
849 || itbl->type == CONSTR_2_0
850 || itbl->type == CONSTR_1_1
851 || itbl->type == CONSTR_0_2
854 xPushCPtr(payloadCPtr(o,i));
860 int n = BCO_INSTR_16;
861 StgPtr p = xStackPtr(n);
867 StgPtr p = xStackPtr(BCO_INSTR_8);
873 xPushPtr(stgCast(StgPtr,bcoConstPtr(bco,BCO_INSTR_8)));
878 int n = BCO_INSTR_16;
879 xPushPtr(stgCast(StgPtr,bcoConstPtr(bco,n)));
884 SSS; PushTaggedRealWorld(); LLL;
889 StgInt i = xTaggedStackInt(BCO_INSTR_8);
895 xPushTaggedInt(bcoConstInt(bco,BCO_INSTR_8));
901 SSS; o = (StgClosure*)grabHpNonUpd(Izh_sizeW); LLL;
902 SET_HDR(o,&Izh_con_info,??);
903 payloadWord(o,0) = xPopTaggedInt();
905 fprintf(stderr,"\tBuilt ");
907 printObj(stgCast(StgClosure*,o));
910 xPushPtr(stgCast(StgPtr,o));
915 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
916 /* ASSERT(isIntLike(con)); */
917 xPushTaggedInt(payloadWord(con,0));
922 StgWord offset = BCO_INSTR_16;
923 StgInt x = xPopTaggedInt();
924 StgInt y = xPopTaggedInt();
930 Case(i_CONST_INTEGER):
934 char* s = bcoConstAddr(bco,BCO_INSTR_8);
937 p = CreateByteArrayToHoldInteger(n);
938 do_fromStr ( s, n, IntegerInsideByteArray(p));
939 SloppifyIntegerEnd(p);
946 StgWord w = xTaggedStackWord(BCO_INSTR_8);
952 xPushTaggedWord(bcoConstWord(bco,BCO_INSTR_8));
958 SSS; o = (StgClosure*)grabHpNonUpd(Wzh_sizeW); LLL;
959 SET_HDR(o,&Wzh_con_info,??);
960 payloadWord(o,0) = xPopTaggedWord();
962 fprintf(stderr,"\tBuilt ");
964 printObj(stgCast(StgClosure*,o));
967 xPushPtr(stgCast(StgPtr,o));
972 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
973 /* ASSERT(isWordLike(con)); */
974 xPushTaggedWord(payloadWord(con,0));
979 StgAddr a = xTaggedStackAddr(BCO_INSTR_8);
985 xPushTaggedAddr(bcoConstAddr(bco,BCO_INSTR_8));
991 SSS; o = (StgClosure*)grabHpNonUpd(Azh_sizeW); LLL;
992 SET_HDR(o,&Azh_con_info,??);
993 payloadPtr(o,0) = xPopTaggedAddr();
995 fprintf(stderr,"\tBuilt ");
997 printObj(stgCast(StgClosure*,o));
1000 xPushPtr(stgCast(StgPtr,o));
1003 Case(i_UNPACK_ADDR):
1005 StgClosure* con = (StgClosure*)xStackPtr(0);
1006 /* ASSERT(isAddrLike(con)); */
1007 xPushTaggedAddr(payloadPtr(con,0));
1012 StgChar c = xTaggedStackChar(BCO_INSTR_8);
1018 xPushTaggedChar(bcoConstChar(bco,BCO_INSTR_8));
1024 SSS; o = (StgClosure*)grabHpNonUpd(Czh_sizeW); LLL;
1025 SET_HDR(o,&Czh_con_info,??);
1026 payloadWord(o,0) = xPopTaggedChar();
1027 xPushPtr(stgCast(StgPtr,o));
1029 fprintf(stderr,"\tBuilt ");
1031 printObj(stgCast(StgClosure*,o));
1036 Case(i_UNPACK_CHAR):
1038 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1039 /* ASSERT(isCharLike(con)); */
1040 xPushTaggedChar(payloadWord(con,0));
1045 StgFloat f = xTaggedStackFloat(BCO_INSTR_8);
1046 xPushTaggedFloat(f);
1049 Case(i_CONST_FLOAT):
1051 xPushTaggedFloat(bcoConstFloat(bco,BCO_INSTR_8));
1057 SSS; o = (StgClosure*)grabHpNonUpd(Fzh_sizeW); LLL;
1058 SET_HDR(o,&Fzh_con_info,??);
1059 ASSIGN_FLT(&payloadWord(o,0),xPopTaggedFloat());
1061 fprintf(stderr,"\tBuilt ");
1063 printObj(stgCast(StgClosure*,o));
1066 xPushPtr(stgCast(StgPtr,o));
1069 Case(i_UNPACK_FLOAT):
1071 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1072 /* ASSERT(isFloatLike(con)); */
1073 xPushTaggedFloat(PK_FLT(&payloadWord(con,0)));
1078 StgDouble d = xTaggedStackDouble(BCO_INSTR_8);
1079 xPushTaggedDouble(d);
1082 Case(i_CONST_DOUBLE):
1084 xPushTaggedDouble(bcoConstDouble(bco,BCO_INSTR_8));
1087 Case(i_CONST_DOUBLE_big):
1089 int n = BCO_INSTR_16;
1090 xPushTaggedDouble(bcoConstDouble(bco,n));
1093 Case(i_PACK_DOUBLE):
1096 SSS; o = (StgClosure*)grabHpNonUpd(Dzh_sizeW); LLL;
1097 SET_HDR(o,&Dzh_con_info,??);
1098 ASSIGN_DBL(&payloadWord(o,0),xPopTaggedDouble());
1100 fprintf(stderr,"\tBuilt ");
1101 printObj(stgCast(StgClosure*,o));
1103 xPushPtr(stgCast(StgPtr,o));
1106 Case(i_UNPACK_DOUBLE):
1108 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1109 /* ASSERT(isDoubleLike(con)); */
1110 xPushTaggedDouble(PK_DBL(&payloadWord(con,0)));
1115 StgStablePtr s = xTaggedStackStable(BCO_INSTR_8);
1116 xPushTaggedStable(s);
1119 Case(i_PACK_STABLE):
1122 SSS; o = (StgClosure*)grabHpNonUpd(Stablezh_sizeW); LLL;
1123 SET_HDR(o,&StablePtr_con_info,??);
1124 payloadWord(o,0) = xPopTaggedStable();
1126 fprintf(stderr,"\tBuilt ");
1128 printObj(stgCast(StgClosure*,o));
1131 xPushPtr(stgCast(StgPtr,o));
1134 Case(i_UNPACK_STABLE):
1136 StgClosure* con = (StgClosure*)xStackPtr(0);
1137 /* ASSERT(isStableLike(con)); */
1138 xPushTaggedStable(payloadWord(con,0));
1146 SSS; p = enterBCO_primop1 ( i ); LLL;
1147 if (p) { obj = p; goto enterLoop; };
1152 /* Remember to save */
1153 int i, trc, pc_saved;
1156 trc = 12345678; /* Assume != any StgThreadReturnCode */
1161 p = enterBCO_primop2 ( i, &trc, &bco_tmp );
1164 bciPtr = &(bcoInstr(bco,pc_saved));
1166 if (trc == 12345678) {
1167 /* we want to enter p */
1168 obj = p; goto enterLoop;
1170 /* p is the the StgThreadReturnCode for this thread */
1171 RETURN((StgThreadReturnCode)p);
1177 /* combined insns, created by peephole opt */
1180 int x = BCO_INSTR_8;
1181 int y = BCO_INSTR_8;
1182 ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
1183 /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
1190 xSetStackWord(x+y,xStackWord(x));
1200 p = xStackPtr(BCO_INSTR_8);
1202 p = xStackPtr(BCO_INSTR_8);
1209 xPushPtr(bcoConstPtr(bco,BCO_INSTR_8));
1210 xPushPtr(stgCast(StgPtr,&ret_bco_info));
1211 p = xStackPtr(BCO_INSTR_8);
1217 StgPtr retaddr = bcoConstPtr(bco,BCO_INSTR_8);
1218 StgPtr ptr = xStackPtr(BCO_INSTR_8);
1220 /* A shortcut. We're going to push the address of a
1221 return continuation, and then enter a variable, so
1222 that when the var is evaluated, we return to the
1223 continuation. The shortcut is: if the var is a
1224 constructor, don't bother to enter it. Instead,
1225 push the variable on the stack (since this is what
1226 the continuation expects) and jump directly to the
1229 if (get_itbl((StgClosure*)ptr)->type == CONSTR) {
1231 obj = (StgClosure*)retaddr;
1233 fprintf(stderr, "object to enter is a constructor -- "
1234 "jumping directly to return continuation\n" );
1239 /* This is the normal, non-short-cut route */
1241 xPushPtr(stgCast(StgPtr,&ret_bco_info));
1242 obj = (StgClosure*)ptr;
1247 Case(i_VAR_DOUBLE_big):
1248 Case(i_CONST_FLOAT_big):
1249 Case(i_VAR_FLOAT_big):
1250 Case(i_CONST_CHAR_big):
1251 Case(i_VAR_CHAR_big):
1252 Case(i_CONST_ADDR_big):
1253 Case(i_VAR_ADDR_big):
1254 Case(i_CONST_INTEGER_big):
1255 Case(i_CONST_INT_big):
1256 Case(i_VAR_INT_big):
1257 Case(i_VAR_WORD_big):
1258 Case(i_RETADDR_big):
1262 disInstr ( bco, PC );
1263 barf("\nUnrecognised instruction");
1267 barf("enterBCO: ran off end of loop");
1271 # undef LoopTopLabel
1277 /* ---------------------------------------------------- */
1278 /* End of the bytecode evaluator */
1279 /* ---------------------------------------------------- */
1283 StgBlockingQueue* bh;
1284 StgCAF* caf = (StgCAF*)obj;
1285 if (xSp - sizeofW(StgUpdateFrame) < xSpLim) {
1286 xPushCPtr(obj); /* code to restart with */
1287 RETURN(StackOverflow);
1289 /* ToDo: look for xSp==xSu && stackInt(0) == UPD_FRAME
1290 and insert an indirection immediately */
1291 SSS; bh = (StgBlockingQueue*)grabHpUpd(BLACKHOLE_sizeW()); LLL;
1292 SET_INFO(bh,&CAF_BLACKHOLE_info);
1293 bh->blocking_queue = EndTSOQueue;
1295 fprintf(stderr,"Created CAF_BLACKHOLE %p for CAF %p in evaluator\n",bh,caf));
1296 SET_INFO(caf,&CAF_ENTERED_info);
1297 caf->value = (StgClosure*)bh;
1298 if (caf->mut_link == NULL) {
1299 SSS; recordOldToNewPtrs((StgMutClosure*)caf); LLL;
1301 SSS; PUSH_UPD_FRAME(bh,0); LLL;
1302 xSp -= sizeofW(StgUpdateFrame);
1303 caf->link = enteredCAFs;
1310 StgCAF* caf = (StgCAF*)obj;
1311 obj = caf->value; /* it's just a fancy indirection */
1317 case SE_CAF_BLACKHOLE:
1319 /*was StgBlackHole* */
1320 StgBlockingQueue* bh = (StgBlockingQueue*)obj;
1321 /* Put ourselves on the blocking queue for this black hole and block */
1322 CurrentTSO->link = bh->blocking_queue;
1323 bh->blocking_queue = CurrentTSO;
1324 xPushCPtr(obj); /* code to restart with */
1325 barf("enter: CAF_BLACKHOLE unexpected!");
1326 RETURN(ThreadBlocked);
1330 StgAP_UPD* ap = stgCast(StgAP_UPD*,obj);
1332 if (xSp - (i + sizeofW(StgUpdateFrame)) < xSpLim) {
1333 xPushCPtr(obj); /* code to restart with */
1334 RETURN(StackOverflow);
1336 /* ToDo: look for xSp==xSu && stackInt(0) == UPD_FRAME
1337 and insert an indirection immediately */
1338 SSS; PUSH_UPD_FRAME(ap,0); LLL;
1339 xSp -= sizeofW(StgUpdateFrame);
1341 xPushWord(payloadWord(ap,i));
1344 #ifdef EAGER_BLACKHOLING
1345 #warn LAZY_BLACKHOLING is default for StgHugs
1346 #error Dont know if EAGER_BLACKHOLING works in StgHugs
1348 /* superfluous - but makes debugging easier */
1349 StgBlackHole* bh = stgCast(StgBlackHole*,ap);
1350 SET_INFO(bh,&BLACKHOLE_info);
1351 bh->blocking_queue = EndTSOQueue;
1353 fprintf(stderr,"Eagerly blackholed AP_UPD %p in evaluator\n",bh));
1356 #endif /* EAGER_BLACKHOLING */
1361 StgPAP* pap = stgCast(StgPAP*,obj);
1362 int i = pap->n_args; /* ToDo: stack check */
1363 /* ToDo: if PAP is in whnf, we can update any update frames
1367 xPushWord(payloadWord(pap,i));
1374 obj = stgCast(StgInd*,obj)->indirectee;
1379 obj = stgCast(StgIndOldGen*,obj)->indirectee;
1388 case CONSTR_INTLIKE:
1389 case CONSTR_CHARLIKE:
1391 case CONSTR_NOCAF_STATIC:
1394 switch (get_itbl(stgCast(StgClosure*,xSp))->type) {
1396 SSS; PopCatchFrame(); LLL;
1399 xPopUpdateFrame(obj);
1402 SSS; PopSeqFrame(); LLL;
1406 ASSERT(xSp==(P_)xSu);
1409 fprintf(stderr, "hit a STOP_FRAME\n");
1411 fprintf(stderr,"xSp = %p\txSu = %p\n", xSp, xSu);
1412 printStack(xSp,CurrentTSO->stack+CurrentTSO->stack_size,xSu);
1415 SSS; PopStopFrame(obj); LLL;
1416 RETURN(ThreadFinished);
1426 /* was: goto enterLoop;
1427 But we know that obj must be a bco now, so jump directly.
1430 case RET_SMALL: /* return to GHC */
1434 // barf("todo: RET_[VEC_]{BIG,SMALL}");
1436 belch("entered CONSTR with invalid continuation on stack");
1439 printObj(stgCast(StgClosure*,xSp));
1442 barf("bailing out");
1449 //fprintf(stderr, "enterCountI = %d\n", enterCountI);
1450 //fprintf(stderr, "entering unknown closure -- yielding to sched\n");
1453 CurrentTSO->whatNext = ThreadEnterGHC;
1454 xPushCPtr(obj); /* code to restart with */
1455 RETURN(ThreadYielding);
1458 barf("Ran off the end of enter - yoiks");
1475 #undef xSetStackWord
1478 #undef xPushTaggedInt
1479 #undef xPopTaggedInt
1480 #undef xTaggedStackInt
1481 #undef xPushTaggedWord
1482 #undef xPopTaggedWord
1483 #undef xTaggedStackWord
1484 #undef xPushTaggedAddr
1485 #undef xTaggedStackAddr
1486 #undef xPopTaggedAddr
1487 #undef xPushTaggedStable
1488 #undef xTaggedStackStable
1489 #undef xPopTaggedStable
1490 #undef xPushTaggedChar
1491 #undef xTaggedStackChar
1492 #undef xPopTaggedChar
1493 #undef xPushTaggedFloat
1494 #undef xTaggedStackFloat
1495 #undef xPopTaggedFloat
1496 #undef xPushTaggedDouble
1497 #undef xTaggedStackDouble
1498 #undef xPopTaggedDouble
1502 /* --------------------------------------------------------------------------
1503 * Supporting routines for primops
1504 * ------------------------------------------------------------------------*/
1506 static inline void PushTag ( StackTag t )
1508 inline void PushPtr ( StgPtr x )
1509 { *(--stgCast(StgPtr*,Sp)) = x; }
1510 static inline void PushCPtr ( StgClosure* x )
1511 { *(--stgCast(StgClosure**,Sp)) = x; }
1512 static inline void PushInt ( StgInt x )
1513 { *(--stgCast(StgInt*,Sp)) = x; }
1514 static inline void PushWord ( StgWord x )
1515 { *(--stgCast(StgWord*,Sp)) = x; }
1518 static inline void checkTag ( StackTag t1, StackTag t2 )
1519 { ASSERT(t1 == t2);}
1520 static inline void PopTag ( StackTag t )
1521 { checkTag(t,*(Sp++)); }
1522 inline StgPtr PopPtr ( void )
1523 { return *stgCast(StgPtr*,Sp)++; }
1524 static inline StgClosure* PopCPtr ( void )
1525 { return *stgCast(StgClosure**,Sp)++; }
1526 static inline StgInt PopInt ( void )
1527 { return *stgCast(StgInt*,Sp)++; }
1528 static inline StgWord PopWord ( void )
1529 { return *stgCast(StgWord*,Sp)++; }
1531 static inline StgPtr stackPtr ( StgStackOffset i )
1532 { return *stgCast(StgPtr*, Sp+i); }
1533 static inline StgInt stackInt ( StgStackOffset i )
1534 { return *stgCast(StgInt*, Sp+i); }
1535 static inline StgWord stackWord ( StgStackOffset i )
1536 { return *stgCast(StgWord*,Sp+i); }
1538 static inline void setStackWord ( StgStackOffset i, StgWord w )
1541 static inline void PushTaggedRealWorld( void )
1542 { PushTag(REALWORLD_TAG); }
1543 inline void PushTaggedInt ( StgInt x )
1544 { Sp -= sizeofW(StgInt); *Sp = x; PushTag(INT_TAG); }
1545 inline void PushTaggedWord ( StgWord x )
1546 { Sp -= sizeofW(StgWord); *Sp = x; PushTag(WORD_TAG); }
1547 inline void PushTaggedAddr ( StgAddr x )
1548 { Sp -= sizeofW(StgAddr); *Sp = (W_)x; PushTag(ADDR_TAG); }
1549 inline void PushTaggedChar ( StgChar x )
1550 { Sp -= sizeofW(StgChar); *Sp = stgCast(StgWord,x); PushTag(CHAR_TAG); }
1551 inline void PushTaggedFloat ( StgFloat x )
1552 { Sp -= sizeofW(StgFloat); ASSIGN_FLT(Sp,x); PushTag(FLOAT_TAG); }
1553 inline void PushTaggedDouble ( StgDouble x )
1554 { Sp -= sizeofW(StgDouble); ASSIGN_DBL(Sp,x); PushTag(DOUBLE_TAG); }
1555 inline void PushTaggedStablePtr ( StgStablePtr x )
1556 { Sp -= sizeofW(StgStablePtr); *Sp = x; PushTag(STABLE_TAG); }
1557 static inline void PushTaggedBool ( int x )
1558 { PushTaggedInt(x); }
1562 static inline void PopTaggedRealWorld ( void )
1563 { PopTag(REALWORLD_TAG); }
1564 inline StgInt PopTaggedInt ( void )
1565 { StgInt r; PopTag(INT_TAG); r = *stgCast(StgInt*, Sp);
1566 Sp += sizeofW(StgInt); return r;}
1567 inline StgWord PopTaggedWord ( void )
1568 { StgWord r; PopTag(WORD_TAG); r = *stgCast(StgWord*, Sp);
1569 Sp += sizeofW(StgWord); return r;}
1570 inline StgAddr PopTaggedAddr ( void )
1571 { StgAddr r; PopTag(ADDR_TAG); r = *stgCast(StgAddr*, Sp);
1572 Sp += sizeofW(StgAddr); return r;}
1573 inline StgChar PopTaggedChar ( void )
1574 { StgChar r; PopTag(CHAR_TAG); r = stgCast(StgChar, *Sp);
1575 Sp += sizeofW(StgChar); return r;}
1576 inline StgFloat PopTaggedFloat ( void )
1577 { StgFloat r; PopTag(FLOAT_TAG); r = PK_FLT(Sp);
1578 Sp += sizeofW(StgFloat); return r;}
1579 inline StgDouble PopTaggedDouble ( void )
1580 { StgDouble r; PopTag(DOUBLE_TAG); r = PK_DBL(Sp);
1581 Sp += sizeofW(StgDouble); return r;}
1582 inline StgStablePtr PopTaggedStablePtr ( void )
1583 { StgInt r; PopTag(STABLE_TAG); r = *stgCast(StgStablePtr*, Sp);
1584 Sp += sizeofW(StgStablePtr); return r;}
1588 static inline StgInt taggedStackInt ( StgStackOffset i )
1589 { checkTag(INT_TAG,Sp[i]); return *stgCast(StgInt*, Sp+1+i); }
1590 static inline StgWord taggedStackWord ( StgStackOffset i )
1591 { checkTag(WORD_TAG,Sp[i]); return *stgCast(StgWord*, Sp+1+i); }
1592 static inline StgAddr taggedStackAddr ( StgStackOffset i )
1593 { checkTag(ADDR_TAG,Sp[i]); return *stgCast(StgAddr*, Sp+1+i); }
1594 static inline StgChar taggedStackChar ( StgStackOffset i )
1595 { checkTag(CHAR_TAG,Sp[i]); return stgCast(StgChar, *(Sp+1+i)) ; }
1596 static inline StgFloat taggedStackFloat ( StgStackOffset i )
1597 { checkTag(FLOAT_TAG,Sp[i]); return PK_FLT(Sp+1+i); }
1598 static inline StgDouble taggedStackDouble ( StgStackOffset i )
1599 { checkTag(DOUBLE_TAG,Sp[i]); return PK_DBL(Sp+1+i); }
1600 static inline StgStablePtr taggedStackStable ( StgStackOffset i )
1601 { checkTag(STABLE_TAG,Sp[i]); return *stgCast(StgStablePtr*, Sp+1+i); }
1604 /* --------------------------------------------------------------------------
1607 * Should we allocate from a nursery or use the
1608 * doYouWantToGC/allocate interface? We'd already implemented a
1609 * nursery-style scheme when the doYouWantToGC/allocate interface
1611 * One reason to prefer the doYouWantToGC/allocate interface is to
1612 * support operations which allocate an unknown amount in the heap
1613 * (array ops, gmp ops, etc)
1614 * ------------------------------------------------------------------------*/
1616 static inline StgPtr grabHpUpd( nat size )
1618 ASSERT( size >= MIN_UPD_SIZE + sizeofW(StgHeader) );
1619 #ifdef CRUDE_PROFILING
1620 cp_bill_words ( size );
1622 return allocate(size);
1625 static inline StgPtr grabHpNonUpd( nat size )
1627 ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
1628 #ifdef CRUDE_PROFILING
1629 cp_bill_words ( size );
1631 return allocate(size);
1634 /* --------------------------------------------------------------------------
1635 * Manipulate "update frame" list:
1636 * o Update frames (based on stg_do_update and friends in Updates.hc)
1637 * o Error handling/catching (based on catchzh_fast and friends in Prims.hc)
1638 * o Seq frames (based on seq_frame_entry in Prims.hc)
1640 * ------------------------------------------------------------------------*/
1642 static inline void PopUpdateFrame( StgClosure* obj )
1644 /* NB: doesn't assume that Sp == Su */
1646 fprintf(stderr, "Updating ");
1647 printPtr(stgCast(StgPtr,Su->updatee));
1648 fprintf(stderr, " with ");
1650 fprintf(stderr,"Sp = %p\tSu = %p\n\n", Sp, Su);
1652 #ifdef EAGER_BLACKHOLING
1653 #warn LAZY_BLACKHOLING is default for StgHugs
1654 #error Dont know if EAGER_BLACKHOLING works in StgHugs
1655 ASSERT(get_itbl(Su->updatee)->type == BLACKHOLE
1656 || get_itbl(Su->updatee)->type == SE_BLACKHOLE
1657 || get_itbl(Su->updatee)->type == CAF_BLACKHOLE
1658 || get_itbl(Su->updatee)->type == SE_CAF_BLACKHOLE
1660 #endif /* EAGER_BLACKHOLING */
1661 UPD_IND(Su->updatee,obj);
1662 Sp = stgCast(StgStackPtr,Su) + sizeofW(StgUpdateFrame);
1666 static inline void PopStopFrame( StgClosure* obj )
1668 /* Move Su just off the end of the stack, we're about to spam the
1669 * STOP_FRAME with the return value.
1671 Su = stgCast(StgUpdateFrame*,Sp+1);
1672 *stgCast(StgClosure**,Sp) = obj;
1675 static inline void PushCatchFrame( StgClosure* handler )
1678 /* ToDo: stack check! */
1679 Sp -= sizeofW(StgCatchFrame);
1680 fp = stgCast(StgCatchFrame*,Sp);
1681 SET_HDR(fp,(StgInfoTable*)&catch_frame_info,CCCS);
1682 fp->handler = handler;
1684 Su = stgCast(StgUpdateFrame*,fp);
1687 static inline void PopCatchFrame( void )
1689 /* NB: doesn't assume that Sp == Su */
1690 /* fprintf(stderr,"Popping catch frame\n"); */
1691 Sp = stgCast(StgStackPtr,Su) + sizeofW(StgCatchFrame);
1692 Su = stgCast(StgCatchFrame*,Su)->link;
1695 static inline void PushSeqFrame( void )
1698 /* ToDo: stack check! */
1699 Sp -= sizeofW(StgSeqFrame);
1700 fp = stgCast(StgSeqFrame*,Sp);
1701 SET_HDR(fp,(StgInfoTable*)&seq_frame_info,CCCS);
1703 Su = stgCast(StgUpdateFrame*,fp);
1706 static inline void PopSeqFrame( void )
1708 /* NB: doesn't assume that Sp == Su */
1709 Sp = stgCast(StgStackPtr,Su) + sizeofW(StgSeqFrame);
1710 Su = stgCast(StgSeqFrame*,Su)->link;
1713 static inline StgClosure* raiseAnError( StgClosure* errObj )
1715 StgClosure *raise_closure;
1717 /* This closure represents the expression 'raise# E' where E
1718 * is the exception raised. It is used to overwrite all the
1719 * thunks which are currently under evaluataion.
1721 raise_closure = (StgClosure *)allocate(sizeofW(StgClosure)+1);
1722 raise_closure->header.info = &raise_info;
1723 raise_closure->payload[0] = R1.cl;
1726 switch (get_itbl(Su)->type) {
1728 UPD_IND(Su->updatee,raise_closure);
1729 Sp = stgCast(StgStackPtr,Su) + sizeofW(StgUpdateFrame);
1735 case CATCH_FRAME: /* found it! */
1737 StgCatchFrame* fp = stgCast(StgCatchFrame*,Su);
1738 StgClosure *handler = fp->handler;
1740 Sp += sizeofW(StgCatchFrame); /* Pop */
1745 barf("raiseError: uncaught exception: STOP_FRAME");
1747 barf("raiseError: weird activation record");
1753 static StgClosure* makeErrorCall ( const char* msg )
1755 /* Note! the msg string should be allocated in a
1756 place which will not get freed -- preferably
1757 read-only data of the program. That's because
1758 the thunk we build here may linger indefinitely.
1759 (thinks: probably not so, but anyway ...)
1762 = asmClosureOfObject(getHugs_AsmObject_for("error"));
1764 = asmClosureOfObject(getHugs_AsmObject_for("primUnpackString"));
1766 = rts_apply ( unpack, rts_mkAddr ( (void*)msg ) );
1768 = rts_apply ( error, thunk );
1770 (StgClosure*) thunk;
1773 #define raiseIndex(where) makeErrorCall("Array index out of range in " where)
1774 #define raiseDiv0(where) makeErrorCall("Division by zero in " where)
1776 /* --------------------------------------------------------------------------
1778 * ------------------------------------------------------------------------*/
1780 #define OP_CC_B(e) \
1782 unsigned char x = PopTaggedChar(); \
1783 unsigned char y = PopTaggedChar(); \
1784 PushTaggedBool(e); \
1789 unsigned char x = PopTaggedChar(); \
1798 #define OP_IW_I(e) \
1800 StgInt x = PopTaggedInt(); \
1801 StgWord y = PopTaggedWord(); \
1805 #define OP_II_I(e) \
1807 StgInt x = PopTaggedInt(); \
1808 StgInt y = PopTaggedInt(); \
1812 #define OP_II_B(e) \
1814 StgInt x = PopTaggedInt(); \
1815 StgInt y = PopTaggedInt(); \
1816 PushTaggedBool(e); \
1821 PushTaggedAddr(e); \
1826 StgInt x = PopTaggedInt(); \
1827 PushTaggedAddr(e); \
1832 StgInt x = PopTaggedInt(); \
1838 PushTaggedChar(e); \
1843 StgInt x = PopTaggedInt(); \
1844 PushTaggedChar(e); \
1849 PushTaggedWord(e); \
1854 StgInt x = PopTaggedInt(); \
1855 PushTaggedWord(e); \
1860 StgInt x = PopTaggedInt(); \
1861 PushTaggedStablePtr(e); \
1866 PushTaggedFloat(e); \
1871 StgInt x = PopTaggedInt(); \
1872 PushTaggedFloat(e); \
1877 PushTaggedDouble(e); \
1882 StgInt x = PopTaggedInt(); \
1883 PushTaggedDouble(e); \
1886 #define OP_WW_B(e) \
1888 StgWord x = PopTaggedWord(); \
1889 StgWord y = PopTaggedWord(); \
1890 PushTaggedBool(e); \
1893 #define OP_WW_W(e) \
1895 StgWord x = PopTaggedWord(); \
1896 StgWord y = PopTaggedWord(); \
1897 PushTaggedWord(e); \
1902 StgWord x = PopTaggedWord(); \
1908 StgStablePtr x = PopTaggedStablePtr(); \
1914 StgWord x = PopTaggedWord(); \
1915 PushTaggedWord(e); \
1918 #define OP_AA_B(e) \
1920 StgAddr x = PopTaggedAddr(); \
1921 StgAddr y = PopTaggedAddr(); \
1922 PushTaggedBool(e); \
1926 StgAddr x = PopTaggedAddr(); \
1929 #define OP_AI_C(s) \
1931 StgAddr x = PopTaggedAddr(); \
1932 int y = PopTaggedInt(); \
1935 PushTaggedChar(r); \
1937 #define OP_AI_I(s) \
1939 StgAddr x = PopTaggedAddr(); \
1940 int y = PopTaggedInt(); \
1945 #define OP_AI_A(s) \
1947 StgAddr x = PopTaggedAddr(); \
1948 int y = PopTaggedInt(); \
1951 PushTaggedAddr(s); \
1953 #define OP_AI_F(s) \
1955 StgAddr x = PopTaggedAddr(); \
1956 int y = PopTaggedInt(); \
1959 PushTaggedFloat(r); \
1961 #define OP_AI_D(s) \
1963 StgAddr x = PopTaggedAddr(); \
1964 int y = PopTaggedInt(); \
1967 PushTaggedDouble(r); \
1969 #define OP_AI_s(s) \
1971 StgAddr x = PopTaggedAddr(); \
1972 int y = PopTaggedInt(); \
1975 PushTaggedStablePtr(r); \
1977 #define OP_AIC_(s) \
1979 StgAddr x = PopTaggedAddr(); \
1980 int y = PopTaggedInt(); \
1981 StgChar z = PopTaggedChar(); \
1984 #define OP_AII_(s) \
1986 StgAddr x = PopTaggedAddr(); \
1987 int y = PopTaggedInt(); \
1988 StgInt z = PopTaggedInt(); \
1991 #define OP_AIA_(s) \
1993 StgAddr x = PopTaggedAddr(); \
1994 int y = PopTaggedInt(); \
1995 StgAddr z = PopTaggedAddr(); \
1998 #define OP_AIF_(s) \
2000 StgAddr x = PopTaggedAddr(); \
2001 int y = PopTaggedInt(); \
2002 StgFloat z = PopTaggedFloat(); \
2005 #define OP_AID_(s) \
2007 StgAddr x = PopTaggedAddr(); \
2008 int y = PopTaggedInt(); \
2009 StgDouble z = PopTaggedDouble(); \
2012 #define OP_AIs_(s) \
2014 StgAddr x = PopTaggedAddr(); \
2015 int y = PopTaggedInt(); \
2016 StgStablePtr z = PopTaggedStablePtr(); \
2021 #define OP_FF_B(e) \
2023 StgFloat x = PopTaggedFloat(); \
2024 StgFloat y = PopTaggedFloat(); \
2025 PushTaggedBool(e); \
2028 #define OP_FF_F(e) \
2030 StgFloat x = PopTaggedFloat(); \
2031 StgFloat y = PopTaggedFloat(); \
2032 PushTaggedFloat(e); \
2037 StgFloat x = PopTaggedFloat(); \
2038 PushTaggedFloat(e); \
2043 StgFloat x = PopTaggedFloat(); \
2044 PushTaggedBool(e); \
2049 StgFloat x = PopTaggedFloat(); \
2055 StgFloat x = PopTaggedFloat(); \
2056 PushTaggedDouble(e); \
2059 #define OP_DD_B(e) \
2061 StgDouble x = PopTaggedDouble(); \
2062 StgDouble y = PopTaggedDouble(); \
2063 PushTaggedBool(e); \
2066 #define OP_DD_D(e) \
2068 StgDouble x = PopTaggedDouble(); \
2069 StgDouble y = PopTaggedDouble(); \
2070 PushTaggedDouble(e); \
2075 StgDouble x = PopTaggedDouble(); \
2076 PushTaggedBool(e); \
2081 StgDouble x = PopTaggedDouble(); \
2082 PushTaggedDouble(e); \
2087 StgDouble x = PopTaggedDouble(); \
2093 StgDouble x = PopTaggedDouble(); \
2094 PushTaggedFloat(e); \
2098 #ifdef STANDALONE_INTEGER
2099 StgPtr CreateByteArrayToHoldInteger ( int nbytes )
2101 StgInt words = (nbytes+sizeof(W_)-1)/sizeof(W_);
2102 StgWord size = sizeofW(StgArrWords) + words;
2103 StgArrWords* arr = (StgArrWords*)allocate(size);
2104 SET_HDR(arr,&ARR_WORDS_info,CCCS);
2106 ASSERT(nbytes <= arr->words * sizeof(W_));
2109 for (i = 0; i < words; ++i) {
2110 arr->payload[i] = 0xdeadbeef;
2112 { B* b = (B*) &(arr->payload[0]);
2113 b->used = b->sign = 0;
2119 B* IntegerInsideByteArray ( StgPtr arr0 )
2122 StgArrWords* arr = (StgArrWords*)arr0;
2123 ASSERT(GET_INFO(arr) == &ARR_WORDS_info);
2124 b = (B*) &(arr->payload[0]);
2128 void SloppifyIntegerEnd ( StgPtr arr0 )
2130 StgArrWords* arr = (StgArrWords*)arr0;
2131 B* b = (B*) & (arr->payload[0]);
2132 I_ nwunused = arr->words - sizeofW(B) - (b->used+sizeof(W_)-1)/sizeof(W_);
2133 if (nwunused >= ((I_)sizeofW(StgArrWords))) {
2135 b->size -= nwunused * sizeof(W_);
2136 if (b->size < b->used) b->size = b->used;
2139 arr->words -= nwunused;
2140 slop = (StgArrWords*)&(arr->payload[arr->words]);
2141 SET_HDR(slop,&ARR_WORDS_info,CCCS);
2142 slop->words = nwunused - sizeofW(StgArrWords);
2143 ASSERT( &(slop->payload[slop->words]) ==
2144 &(arr->payload[arr->words + nwunused]) );
2148 #define OP_Z_Z(op) \
2150 B* x = IntegerInsideByteArray(PopPtr()); \
2151 int n = mycat2(size_,op)(x); \
2152 StgPtr p = CreateByteArrayToHoldInteger(n); \
2153 mycat2(do_,op)(x,n,IntegerInsideByteArray(p)); \
2154 SloppifyIntegerEnd(p); \
2157 #define OP_ZZ_Z(op) \
2159 B* x = IntegerInsideByteArray(PopPtr()); \
2160 B* y = IntegerInsideByteArray(PopPtr()); \
2161 int n = mycat2(size_,op)(x,y); \
2162 StgPtr p = CreateByteArrayToHoldInteger(n); \
2163 mycat2(do_,op)(x,y,n,IntegerInsideByteArray(p)); \
2164 SloppifyIntegerEnd(p); \
2172 #define HEADER_mI(ty,where) \
2173 StgArrWords* x = stgCast(StgArrWords*,PopPtr()); \
2174 nat i = PopTaggedInt(); \
2175 if (i * sizeof(ty) + (sizeof(ty)) > sizeof(StgWord) * x->words) { \
2176 return (raiseIndex(where)); \
2178 #define OP_mI_ty(ty,where,s) \
2180 HEADER_mI(mycat2(Stg,ty),where) \
2181 { mycat2(Stg,ty) r; \
2183 mycat2(PushTagged,ty)(r); \
2186 #define OP_mIty_(ty,where,s) \
2188 HEADER_mI(mycat2(Stg,ty),where) \
2190 mycat2(Stg,ty) z = mycat2(PopTagged,ty)(); \
2196 void myStackCheck ( void )
2198 //StgPtr sp = (StgPtr)Sp;
2199 StgPtr su = (StgPtr)Su;
2200 //fprintf(stderr, "myStackCheck\n");
2201 if (!(SpLim <= Sp && Sp <= stgCast(StgPtr,Su))) {
2202 fprintf(stderr, "myStackCheck: invalid initial Sp/Su \n" );
2206 if (!(su >= CurrentTSO->stack && su <= CurrentTSO->stack + CurrentTSO->stack_size)) {
2207 fprintf ( stderr, "myStackCheck: su out of stack\n" );
2210 switch (get_itbl(stgCast(StgClosure*,su))->type) {
2212 su = (StgPtr) ((StgCatchFrame*)(su))->link;
2215 su = (StgPtr) ((StgUpdateFrame*)(su))->link;
2218 su = (StgPtr) ((StgSeqFrame*)(su))->link;
2223 fprintf(stderr, "myStackCheck: invalid activation record\n"); assert(0);
2230 /* --------------------------------------------------------------------------
2231 * Primop stuff for bytecode interpreter
2232 * ------------------------------------------------------------------------*/
2234 /* Returns & of the next thing to enter (if throwing an exception),
2235 or NULL in the normal case.
2237 static void* enterBCO_primop1 ( int primop1code )
2239 switch (primop1code) {
2240 case i_pushseqframe:
2242 StgClosure* c = PopCPtr();
2247 case i_pushcatchframe:
2249 StgClosure* e = PopCPtr();
2250 StgClosure* h = PopCPtr();
2256 case i_gtChar: OP_CC_B(x>y); break;
2257 case i_geChar: OP_CC_B(x>=y); break;
2258 case i_eqChar: OP_CC_B(x==y); break;
2259 case i_neChar: OP_CC_B(x!=y); break;
2260 case i_ltChar: OP_CC_B(x<y); break;
2261 case i_leChar: OP_CC_B(x<=y); break;
2262 case i_charToInt: OP_C_I(x); break;
2263 case i_intToChar: OP_I_C(x); break;
2265 case i_gtInt: OP_II_B(x>y); break;
2266 case i_geInt: OP_II_B(x>=y); break;
2267 case i_eqInt: OP_II_B(x==y); break;
2268 case i_neInt: OP_II_B(x!=y); break;
2269 case i_ltInt: OP_II_B(x<y); break;
2270 case i_leInt: OP_II_B(x<=y); break;
2271 case i_minInt: OP__I(INT_MIN); break;
2272 case i_maxInt: OP__I(INT_MAX); break;
2273 case i_plusInt: OP_II_I(x+y); break;
2274 case i_minusInt: OP_II_I(x-y); break;
2275 case i_timesInt: OP_II_I(x*y); break;
2278 int x = PopTaggedInt();
2279 int y = PopTaggedInt();
2281 return (raiseDiv0("quotInt"));
2283 /* ToDo: protect against minInt / -1 errors
2284 * (repeat for all other division primops) */
2290 int x = PopTaggedInt();
2291 int y = PopTaggedInt();
2293 return (raiseDiv0("remInt"));
2300 StgInt x = PopTaggedInt();
2301 StgInt y = PopTaggedInt();
2303 return (raiseDiv0("quotRemInt"));
2305 PushTaggedInt(x%y); /* last result */
2306 PushTaggedInt(x/y); /* first result */
2309 case i_negateInt: OP_I_I(-x); break;
2311 case i_andInt: OP_II_I(x&y); break;
2312 case i_orInt: OP_II_I(x|y); break;
2313 case i_xorInt: OP_II_I(x^y); break;
2314 case i_notInt: OP_I_I(~x); break;
2315 case i_shiftLInt: OP_II_I(x<<y); break;
2316 case i_shiftRAInt: OP_II_I(x>>y); break; /* ToDo */
2317 case i_shiftRLInt: OP_II_I(x>>y); break; /* ToDo */
2319 case i_gtWord: OP_WW_B(x>y); break;
2320 case i_geWord: OP_WW_B(x>=y); break;
2321 case i_eqWord: OP_WW_B(x==y); break;
2322 case i_neWord: OP_WW_B(x!=y); break;
2323 case i_ltWord: OP_WW_B(x<y); break;
2324 case i_leWord: OP_WW_B(x<=y); break;
2325 case i_minWord: OP__W(0); break;
2326 case i_maxWord: OP__W(UINT_MAX); break;
2327 case i_plusWord: OP_WW_W(x+y); break;
2328 case i_minusWord: OP_WW_W(x-y); break;
2329 case i_timesWord: OP_WW_W(x*y); break;
2332 StgWord x = PopTaggedWord();
2333 StgWord y = PopTaggedWord();
2335 return (raiseDiv0("quotWord"));
2337 PushTaggedWord(x/y);
2342 StgWord x = PopTaggedWord();
2343 StgWord y = PopTaggedWord();
2345 return (raiseDiv0("remWord"));
2347 PushTaggedWord(x%y);
2352 StgWord x = PopTaggedWord();
2353 StgWord y = PopTaggedWord();
2355 return (raiseDiv0("quotRemWord"));
2357 PushTaggedWord(x%y); /* last result */
2358 PushTaggedWord(x/y); /* first result */
2361 case i_negateWord: OP_W_W(-x); break;
2362 case i_andWord: OP_WW_W(x&y); break;
2363 case i_orWord: OP_WW_W(x|y); break;
2364 case i_xorWord: OP_WW_W(x^y); break;
2365 case i_notWord: OP_W_W(~x); break;
2366 case i_shiftLWord: OP_WW_W(x<<y); break;
2367 case i_shiftRAWord: OP_WW_W(x>>y); break; /* ToDo */
2368 case i_shiftRLWord: OP_WW_W(x>>y); break; /* ToDo */
2369 case i_intToWord: OP_I_W(x); break;
2370 case i_wordToInt: OP_W_I(x); break;
2372 case i_gtAddr: OP_AA_B(x>y); break;
2373 case i_geAddr: OP_AA_B(x>=y); break;
2374 case i_eqAddr: OP_AA_B(x==y); break;
2375 case i_neAddr: OP_AA_B(x!=y); break;
2376 case i_ltAddr: OP_AA_B(x<y); break;
2377 case i_leAddr: OP_AA_B(x<=y); break;
2378 case i_intToAddr: OP_I_A((StgAddr)x); break; /* ToDo */
2379 case i_addrToInt: OP_A_I((StgInt)x); break; /* ToDo */
2381 case i_intToStable: OP_I_s(x); break;
2382 case i_stableToInt: OP_s_I(x); break;
2384 case i_indexCharOffAddr: OP_AI_C(indexCharOffAddrzh(r,x,y)); break;
2385 case i_readCharOffAddr: OP_AI_C(indexCharOffAddrzh(r,x,y)); break;
2386 case i_writeCharOffAddr: OP_AIC_(writeCharOffAddrzh(x,y,z)); break;
2388 case i_indexIntOffAddr: OP_AI_I(indexIntOffAddrzh(r,x,y)); break;
2389 case i_readIntOffAddr: OP_AI_I(indexIntOffAddrzh(r,x,y)); break;
2390 case i_writeIntOffAddr: OP_AII_(writeIntOffAddrzh(x,y,z)); break;
2392 case i_indexAddrOffAddr: OP_AI_A(indexAddrOffAddrzh(r,x,y)); break;
2393 case i_readAddrOffAddr: OP_AI_A(indexAddrOffAddrzh(r,x,y)); break;
2394 case i_writeAddrOffAddr: OP_AIA_(writeAddrOffAddrzh(x,y,z)); break;
2396 case i_indexFloatOffAddr: OP_AI_F(indexFloatOffAddrzh(r,x,y)); break;
2397 case i_readFloatOffAddr: OP_AI_F(indexFloatOffAddrzh(r,x,y)); break;
2398 case i_writeFloatOffAddr: OP_AIF_(writeFloatOffAddrzh(x,y,z)); break;
2400 case i_indexDoubleOffAddr: OP_AI_D(indexDoubleOffAddrzh(r,x,y)); break;
2401 case i_readDoubleOffAddr: OP_AI_D(indexDoubleOffAddrzh(r,x,y)); break;
2402 case i_writeDoubleOffAddr: OP_AID_(writeDoubleOffAddrzh(x,y,z)); break;
2404 case i_indexStableOffAddr: OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break;
2405 case i_readStableOffAddr: OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break;
2406 case i_writeStableOffAddr: OP_AIs_(writeStablePtrOffAddrzh(x,y,z)); break;
2408 #ifdef STANDALONE_INTEGER
2409 case i_compareInteger:
2411 B* x = IntegerInsideByteArray(PopPtr());
2412 B* y = IntegerInsideByteArray(PopPtr());
2413 StgInt r = do_cmp(x,y);
2414 PushTaggedInt(r<0 ? -1 : (r>0 ? 1 : 0));
2417 case i_negateInteger: OP_Z_Z(neg); break;
2418 case i_plusInteger: OP_ZZ_Z(add); break;
2419 case i_minusInteger: OP_ZZ_Z(sub); break;
2420 case i_timesInteger: OP_ZZ_Z(mul); break;
2421 case i_quotRemInteger:
2423 B* x = IntegerInsideByteArray(PopPtr());
2424 B* y = IntegerInsideByteArray(PopPtr());
2425 int n = size_qrm(x,y);
2426 StgPtr q = CreateByteArrayToHoldInteger(n);
2427 StgPtr r = CreateByteArrayToHoldInteger(n);
2428 if (do_getsign(y)==0)
2429 return (raiseDiv0("quotRemInteger"));
2430 do_qrm(x,y,n,IntegerInsideByteArray(q),
2431 IntegerInsideByteArray(r));
2432 SloppifyIntegerEnd(q);
2433 SloppifyIntegerEnd(r);
2438 case i_intToInteger:
2440 int n = size_fromInt();
2441 StgPtr p = CreateByteArrayToHoldInteger(n);
2442 do_fromInt( PopTaggedInt(), n, IntegerInsideByteArray(p));
2446 case i_wordToInteger:
2448 int n = size_fromWord();
2449 StgPtr p = CreateByteArrayToHoldInteger(n);
2450 do_fromWord( PopTaggedWord(), n, IntegerInsideByteArray(p));
2454 case i_integerToInt: PushTaggedInt(do_toInt(
2455 IntegerInsideByteArray(PopPtr())
2459 case i_integerToWord: PushTaggedWord(do_toWord(
2460 IntegerInsideByteArray(PopPtr())
2464 case i_integerToFloat: PushTaggedFloat(do_toFloat(
2465 IntegerInsideByteArray(PopPtr())
2469 case i_integerToDouble: PushTaggedDouble(do_toDouble(
2470 IntegerInsideByteArray(PopPtr())
2474 #error Non-standalone integer not yet implemented
2475 #endif /* STANDALONE_INTEGER */
2477 case i_gtFloat: OP_FF_B(x>y); break;
2478 case i_geFloat: OP_FF_B(x>=y); break;
2479 case i_eqFloat: OP_FF_B(x==y); break;
2480 case i_neFloat: OP_FF_B(x!=y); break;
2481 case i_ltFloat: OP_FF_B(x<y); break;
2482 case i_leFloat: OP_FF_B(x<=y); break;
2483 case i_minFloat: OP__F(FLT_MIN); break;
2484 case i_maxFloat: OP__F(FLT_MAX); break;
2485 case i_radixFloat: OP__I(FLT_RADIX); break;
2486 case i_digitsFloat: OP__I(FLT_MANT_DIG); break;
2487 case i_minExpFloat: OP__I(FLT_MIN_EXP); break;
2488 case i_maxExpFloat: OP__I(FLT_MAX_EXP); break;
2489 case i_plusFloat: OP_FF_F(x+y); break;
2490 case i_minusFloat: OP_FF_F(x-y); break;
2491 case i_timesFloat: OP_FF_F(x*y); break;
2494 StgFloat x = PopTaggedFloat();
2495 StgFloat y = PopTaggedFloat();
2496 PushTaggedFloat(x/y);
2499 case i_negateFloat: OP_F_F(-x); break;
2500 case i_floatToInt: OP_F_I(x); break;
2501 case i_intToFloat: OP_I_F(x); break;
2502 case i_expFloat: OP_F_F(exp(x)); break;
2503 case i_logFloat: OP_F_F(log(x)); break;
2504 case i_sqrtFloat: OP_F_F(sqrt(x)); break;
2505 case i_sinFloat: OP_F_F(sin(x)); break;
2506 case i_cosFloat: OP_F_F(cos(x)); break;
2507 case i_tanFloat: OP_F_F(tan(x)); break;
2508 case i_asinFloat: OP_F_F(asin(x)); break;
2509 case i_acosFloat: OP_F_F(acos(x)); break;
2510 case i_atanFloat: OP_F_F(atan(x)); break;
2511 case i_sinhFloat: OP_F_F(sinh(x)); break;
2512 case i_coshFloat: OP_F_F(cosh(x)); break;
2513 case i_tanhFloat: OP_F_F(tanh(x)); break;
2514 case i_powerFloat: OP_FF_F(pow(x,y)); break;
2516 #ifdef STANDALONE_INTEGER
2517 case i_encodeFloatZ:
2519 StgPtr sig = PopPtr();
2520 StgInt exp = PopTaggedInt();
2522 B__encodeFloat(IntegerInsideByteArray(sig), exp)
2526 case i_decodeFloatZ:
2528 StgFloat f = PopTaggedFloat();
2529 StgPtr sig = CreateByteArrayToHoldInteger(size_fltmantissa());
2531 B__decodeFloat(IntegerInsideByteArray(sig), &exp, f);
2537 #error encode/decodeFloatZ not yet implemented for GHC ints
2539 case i_isNaNFloat: OP_F_B(isFloatNaN(x)); break;
2540 case i_isInfiniteFloat: OP_F_B(isFloatInfinite(x)); break;
2541 case i_isNegativeZeroFloat: OP_F_B(isFloatNegativeZero(x)); break;
2542 case i_isDenormalizedFloat: OP_F_B(isFloatDenormalized(x)); break;
2543 case i_gtDouble: OP_DD_B(x>y); break;
2544 case i_geDouble: OP_DD_B(x>=y); break;
2545 case i_eqDouble: OP_DD_B(x==y); break;
2546 case i_neDouble: OP_DD_B(x!=y); break;
2547 case i_ltDouble: OP_DD_B(x<y); break;
2548 case i_leDouble: OP_DD_B(x<=y) break;
2549 case i_minDouble: OP__D(DBL_MIN); break;
2550 case i_maxDouble: OP__D(DBL_MAX); break;
2551 case i_radixDouble: OP__I(FLT_RADIX); break;
2552 case i_digitsDouble: OP__I(DBL_MANT_DIG); break;
2553 case i_minExpDouble: OP__I(DBL_MIN_EXP); break;
2554 case i_maxExpDouble: OP__I(DBL_MAX_EXP); break;
2555 case i_plusDouble: OP_DD_D(x+y); break;
2556 case i_minusDouble: OP_DD_D(x-y); break;
2557 case i_timesDouble: OP_DD_D(x*y); break;
2558 case i_divideDouble:
2560 StgDouble x = PopTaggedDouble();
2561 StgDouble y = PopTaggedDouble();
2562 PushTaggedDouble(x/y);
2565 case i_negateDouble: OP_D_D(-x); break;
2566 case i_doubleToInt: OP_D_I(x); break;
2567 case i_intToDouble: OP_I_D(x); break;
2568 case i_doubleToFloat: OP_D_F(x); break;
2569 case i_floatToDouble: OP_F_F(x); break;
2570 case i_expDouble: OP_D_D(exp(x)); break;
2571 case i_logDouble: OP_D_D(log(x)); break;
2572 case i_sqrtDouble: OP_D_D(sqrt(x)); break;
2573 case i_sinDouble: OP_D_D(sin(x)); break;
2574 case i_cosDouble: OP_D_D(cos(x)); break;
2575 case i_tanDouble: OP_D_D(tan(x)); break;
2576 case i_asinDouble: OP_D_D(asin(x)); break;
2577 case i_acosDouble: OP_D_D(acos(x)); break;
2578 case i_atanDouble: OP_D_D(atan(x)); break;
2579 case i_sinhDouble: OP_D_D(sinh(x)); break;
2580 case i_coshDouble: OP_D_D(cosh(x)); break;
2581 case i_tanhDouble: OP_D_D(tanh(x)); break;
2582 case i_powerDouble: OP_DD_D(pow(x,y)); break;
2584 #ifdef STANDALONE_INTEGER
2585 case i_encodeDoubleZ:
2587 StgPtr sig = PopPtr();
2588 StgInt exp = PopTaggedInt();
2590 B__encodeDouble(IntegerInsideByteArray(sig), exp)
2594 case i_decodeDoubleZ:
2596 StgDouble d = PopTaggedDouble();
2597 StgPtr sig = CreateByteArrayToHoldInteger(size_dblmantissa());
2599 B__decodeDouble(IntegerInsideByteArray(sig), &exp, d);
2605 #error encode/decodeDoubleZ not yet implemented for GHC ints
2607 case i_isNaNDouble: OP_D_B(isDoubleNaN(x)); break;
2608 case i_isInfiniteDouble: OP_D_B(isDoubleInfinite(x)); break;
2609 case i_isNegativeZeroDouble: OP_D_B(isDoubleNegativeZero(x)); break;
2610 case i_isDenormalizedDouble: OP_D_B(isDoubleDenormalized(x)); break;
2611 case i_isIEEEDouble:
2613 PushTaggedBool(rtsTrue);
2617 barf("Unrecognised primop1");
2624 /* For normal cases, return NULL and leave *return2 unchanged.
2625 To return the address of the next thing to enter,
2626 return the address of it and leave *return2 unchanged.
2627 To return a StgThreadReturnCode to the scheduler,
2628 set *return2 to it and return a non-NULL value.
2630 static void* enterBCO_primop2 ( int primop2code,
2631 int* /*StgThreadReturnCode* */ return2,
2634 switch (primop2code) {
2635 case i_raise: /* raise#{err} */
2637 StgClosure* err = PopCPtr();
2638 return (raiseAnError(err));
2643 StgClosure* init = PopCPtr();
2645 = stgCast(StgMutVar*,allocate(sizeofW(StgMutVar)));
2646 SET_HDR(mv,&MUT_VAR_info,CCCS);
2648 PushPtr(stgCast(StgPtr,mv));
2653 StgMutVar* mv = stgCast(StgMutVar*,PopPtr());
2659 StgMutVar* mv = stgCast(StgMutVar*,PopPtr());
2660 StgClosure* value = PopCPtr();
2666 nat n = PopTaggedInt(); /* or Word?? */
2667 StgClosure* init = PopCPtr();
2668 StgWord size = sizeofW(StgMutArrPtrs) + n;
2671 = stgCast(StgMutArrPtrs*,allocate(size));
2672 SET_HDR(arr,&MUT_ARR_PTRS_info,CCCS);
2674 for (i = 0; i < n; ++i) {
2675 arr->payload[i] = init;
2677 PushPtr(stgCast(StgPtr,arr));
2683 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2684 nat i = PopTaggedInt(); /* or Word?? */
2685 StgWord n = arr->ptrs;
2687 return (raiseIndex("{index,read}Array"));
2689 PushCPtr(arr->payload[i]);
2694 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2695 nat i = PopTaggedInt(); /* or Word? */
2696 StgClosure* v = PopCPtr();
2697 StgWord n = arr->ptrs;
2699 return (raiseIndex("{index,read}Array"));
2701 arr->payload[i] = v;
2705 case i_sizeMutableArray:
2707 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2708 PushTaggedInt(arr->ptrs);
2711 case i_unsafeFreezeArray:
2713 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2714 SET_INFO(arr,&MUT_ARR_PTRS_FROZEN_info);
2715 PushPtr(stgCast(StgPtr,arr));
2718 case i_unsafeFreezeByteArray:
2720 /* Delightfully simple :-) */
2724 case i_sameMutableArray:
2725 case i_sameMutableByteArray:
2727 StgPtr x = PopPtr();
2728 StgPtr y = PopPtr();
2729 PushTaggedBool(x==y);
2733 case i_newByteArray:
2735 nat n = PopTaggedInt(); /* or Word?? */
2736 StgInt words = (n+sizeof(W_)-1)/sizeof(W_);
2737 StgWord size = sizeofW(StgArrWords) + words;
2738 StgArrWords* arr = stgCast(StgArrWords*,allocate(size));
2739 SET_HDR(arr,&ARR_WORDS_info,CCCS);
2743 for (i = 0; i < n; ++i) {
2744 arr->payload[i] = 0xdeadbeef;
2747 PushPtr(stgCast(StgPtr,arr));
2751 /* Most of these generate alignment warnings on Sparcs and similar architectures.
2752 * These are harmless and are caused by the cast to C* in BYTE_ARR_CTS.
2754 case i_indexCharArray:
2755 OP_mI_ty(Char,"indexCharArray", indexCharArrayzh(r,x,i)); break;
2756 case i_readCharArray:
2757 OP_mI_ty(Char,"readCharArray", readCharArrayzh(r,x,i)); break;
2758 case i_writeCharArray:
2759 OP_mIty_(Char,"writeCharArray", writeCharArrayzh(x,i,z)); break;
2761 case i_indexIntArray:
2762 OP_mI_ty(Int,"indexIntArray", indexIntArrayzh(r,x,i)); break;
2763 case i_readIntArray:
2764 OP_mI_ty(Int,"readIntArray", readIntArrayzh(r,x,i)); break;
2765 case i_writeIntArray:
2766 OP_mIty_(Int,"writeIntArray", writeIntArrayzh(x,i,z)); break;
2768 case i_indexAddrArray:
2769 OP_mI_ty(Addr,"indexAddrArray", indexAddrArrayzh(r,x,i)); break;
2770 case i_readAddrArray:
2771 OP_mI_ty(Addr,"readAddrArray", readAddrArrayzh(r,x,i)); break;
2772 case i_writeAddrArray:
2773 OP_mIty_(Addr,"writeAddrArray", writeAddrArrayzh(x,i,z)); break;
2775 case i_indexFloatArray:
2776 OP_mI_ty(Float,"indexFloatArray", indexFloatArrayzh(r,x,i)); break;
2777 case i_readFloatArray:
2778 OP_mI_ty(Float,"readFloatArray", readFloatArrayzh(r,x,i)); break;
2779 case i_writeFloatArray:
2780 OP_mIty_(Float,"writeFloatArray", writeFloatArrayzh(x,i,z)); break;
2782 case i_indexDoubleArray:
2783 OP_mI_ty(Double,"indexDoubleArray", indexDoubleArrayzh(r,x,i)); break;
2784 case i_readDoubleArray:
2785 OP_mI_ty(Double,"readDoubleArray", readDoubleArrayzh(r,x,i)); break;
2786 case i_writeDoubleArray:
2787 OP_mIty_(Double,"writeDoubleArray", writeDoubleArrayzh(x,i,z)); break;
2790 #ifdef PROVIDE_STABLE
2791 case i_indexStableArray:
2792 OP_mI_ty(StablePtr,"indexStableArray", indexStablePtrArrayzh(r,x,i)); break;
2793 case i_readStableArray:
2794 OP_mI_ty(StablePtr,"readStableArray", readStablePtrArrayzh(r,x,i)); break;
2795 case i_writeStableArray:
2796 OP_mIty_(StablePtr,"writeStableArray", writeStablePtrArrayzh(x,i,z)); break;
2802 #ifdef PROVIDE_COERCE
2803 case i_unsafeCoerce:
2805 /* Another nullop */
2809 #ifdef PROVIDE_PTREQUALITY
2810 case i_reallyUnsafePtrEquality:
2811 { /* identical to i_sameRef */
2812 StgPtr x = PopPtr();
2813 StgPtr y = PopPtr();
2814 PushTaggedBool(x==y);
2818 #ifdef PROVIDE_FOREIGN
2819 /* ForeignObj# operations */
2820 case i_makeForeignObj:
2822 StgForeignObj *result
2823 = stgCast(StgForeignObj*,allocate(sizeofW(StgForeignObj)));
2824 SET_HDR(result,&FOREIGN_info,CCCS);
2825 result -> data = PopTaggedAddr();
2826 PushPtr(stgCast(StgPtr,result));
2829 #endif /* PROVIDE_FOREIGN */
2834 = stgCast(StgWeak*,allocate(sizeofW(StgWeak)));
2835 SET_HDR(w, &WEAK_info, CCCS);
2837 w->value = PopCPtr();
2838 w->finaliser = PopCPtr();
2839 w->link = weak_ptr_list;
2841 IF_DEBUG(weak, fprintf(stderr,"New weak pointer at %p\n",w));
2842 PushPtr(stgCast(StgPtr,w));
2847 StgWeak *w = stgCast(StgWeak*,PopPtr());
2848 if (w->header.info == &WEAK_info) {
2849 PushCPtr(w->value); /* last result */
2850 PushTaggedInt(1); /* first result */
2852 PushPtr(stgCast(StgPtr,w));
2853 /* ToDo: error thunk would be better */
2858 #endif /* PROVIDE_WEAK */
2860 case i_makeStablePtr:
2862 StgPtr p = PopPtr();
2863 StgStablePtr sp = getStablePtr ( p );
2864 PushTaggedStablePtr(sp);
2867 case i_deRefStablePtr:
2870 StgStablePtr sp = PopTaggedStablePtr();
2871 p = deRefStablePtr(sp);
2875 case i_freeStablePtr:
2877 StgStablePtr sp = PopTaggedStablePtr();
2882 case i_createAdjThunkARCH:
2884 StgStablePtr stableptr = PopTaggedStablePtr();
2885 StgAddr typestr = PopTaggedAddr();
2886 StgChar callconv = PopTaggedChar();
2887 StgAddr adj_thunk = createAdjThunk(stableptr,typestr,callconv);
2888 PushTaggedAddr(adj_thunk);
2894 StgInt n = prog_argc;
2900 StgInt n = PopTaggedInt();
2901 StgAddr a = (StgAddr)prog_argv[n];
2906 #ifdef PROVIDE_CONCURRENT
2909 StgClosure* c = PopCPtr();
2910 StgTSO* t = createGenThread(RtsFlags.GcFlags.initialStkSize,c);
2911 PushPtr(stgCast(StgPtr,t));
2913 /* switch at the earliest opportunity */
2915 /* but don't automatically switch to GHC - or you'll waste your
2916 * time slice switching back.
2918 * Actually, there's more to it than that: the default
2919 * (ThreadEnterGHC) causes the thread to crash - don't
2920 * understand why. - ADR
2922 t->whatNext = ThreadEnterHugs;
2927 StgTSO* tso = stgCast(StgTSO*,PopPtr());
2929 if (tso == CurrentTSO) { /* suicide */
2930 *return2 = ThreadFinished;
2931 return (void*)(1+(NULL));
2936 { /* identical to i_sameRef */
2937 StgPtr x = PopPtr();
2938 StgPtr y = PopPtr();
2939 PushTaggedBool(x==y);
2944 StgMVar *mvar = stgCast(StgMVar*,allocate(sizeofW(StgMVar)));
2945 SET_INFO(mvar,&EMPTY_MVAR_info);
2946 mvar->head = mvar->tail = EndTSOQueue;
2947 /* ToDo: this is a little strange */
2948 mvar->value = stgCast(StgClosure*,&END_TSO_QUEUE_closure);
2949 PushPtr(stgCast(StgPtr,mvar));
2954 ToDo: another way out of the problem might be to add an explicit
2955 continuation to primTakeMVar: takeMVar v = primTakeMVar v takeMVar.
2956 The problem with this plan is that now I dont know how much to chop
2961 StgMVar *mvar = stgCast(StgMVar*,PopPtr());
2962 /* If the MVar is empty, put ourselves
2963 * on its blocking queue, and wait
2964 * until we're woken up.
2966 if (GET_INFO(mvar) != &FULL_MVAR_info) {
2967 if (mvar->head == EndTSOQueue) {
2968 mvar->head = CurrentTSO;
2970 mvar->tail->link = CurrentTSO;
2972 CurrentTSO->link = EndTSOQueue;
2973 mvar->tail = CurrentTSO;
2975 /* Hack, hack, hack.
2976 * When we block, we push a restart closure
2977 * on the stack - but which closure?
2978 * We happen to know that the BCO we're
2979 * executing looks like this:
2988 * 14: ALLOC_CONSTR 0x8213a80
2998 * so we rearrange the stack to look the
2999 * way it did when we entered this BCO
3001 * What a disgusting hack!
3007 *return2 = ThreadBlocked;
3008 return (void*)(1+(NULL));
3011 PushCPtr(mvar->value);
3012 SET_INFO(mvar,&EMPTY_MVAR_info);
3013 /* ToDo: this is a little strange */
3014 mvar->value = (StgClosure*)&END_TSO_QUEUE_closure;
3021 StgMVar* mvar = stgCast(StgMVar*,PopPtr());
3022 StgClosure* value = PopCPtr();
3023 if (GET_INFO(mvar) == &FULL_MVAR_info) {
3024 return (raisePrim("putMVar {full MVar}"));
3026 /* wake up the first thread on the
3027 * queue, it will continue with the
3028 * takeMVar operation and mark the
3031 StgTSO* tso = mvar->head;
3032 SET_INFO(mvar,&FULL_MVAR_info);
3033 mvar->value = value;
3034 if (tso != EndTSOQueue) {
3035 PUSH_ON_RUN_QUEUE(tso);
3036 mvar->head = tso->link;
3037 tso->link = EndTSOQueue;
3038 if (mvar->head == EndTSOQueue) {
3039 mvar->tail = EndTSOQueue;
3043 /* yield for better communication performance */
3050 /* As PrimOps.h says: Hmm, I'll think about these later. */
3053 #endif /* PROVIDE_CONCURRENT */
3054 case i_ccall_ccall_Id:
3055 case i_ccall_ccall_IO:
3056 case i_ccall_stdcall_Id:
3057 case i_ccall_stdcall_IO:
3060 CFunDescriptor* descriptor = PopTaggedAddr();
3061 void (*funPtr)(void) = PopTaggedAddr();
3062 char cc = (primop2code == i_ccall_stdcall_Id ||
3063 primop2code == i_ccall_stdcall_IO)
3065 r = ccall(descriptor,funPtr,bco,cc);
3068 return makeErrorCall(
3069 "unhandled type or too many args/results in ccall");
3071 barf("ccall not configured correctly for this platform");
3072 barf("unknown return code from ccall");
3075 barf("Unrecognised primop2");
3081 /* -----------------------------------------------------------------------------
3082 * ccall support code:
3083 * marshall moves args from C stack to Haskell stack
3084 * unmarshall moves args from Haskell stack to C stack
3085 * argSize calculates how much space you need on the C stack
3086 * ---------------------------------------------------------------------------*/
3088 /* Pop arguments off the C stack and Push them onto the Hugs stack.
3089 * Used when preparing for C calling Haskell or in response to
3090 * Haskell calling C.
3092 nat marshall(char arg_ty, void* arg)
3096 PushTaggedInt(*((int*)arg));
3097 return ARG_SIZE(INT_TAG);
3098 #ifdef TODO_STANDALONE_INTEGER
3100 PushTaggedInteger(*((mpz_ptr*)arg));
3101 return ARG_SIZE(INTEGER_TAG);
3104 PushTaggedWord(*((unsigned int*)arg));
3105 return ARG_SIZE(WORD_TAG);
3107 PushTaggedChar(*((char*)arg));
3108 return ARG_SIZE(CHAR_TAG);
3110 PushTaggedFloat(*((float*)arg));
3111 return ARG_SIZE(FLOAT_TAG);
3113 PushTaggedDouble(*((double*)arg));
3114 return ARG_SIZE(DOUBLE_TAG);
3116 PushTaggedAddr(*((void**)arg));
3117 return ARG_SIZE(ADDR_TAG);
3119 PushTaggedStablePtr(*((StgStablePtr*)arg));
3120 return ARG_SIZE(STABLE_TAG);
3121 #ifdef PROVIDE_FOREIGN
3123 /* Not allowed in this direction - you have to
3124 * call makeForeignPtr explicitly
3126 barf("marshall: ForeignPtr#\n");
3131 /* Not allowed in this direction */
3132 barf("marshall: [Mutable]ByteArray#\n");
3135 barf("marshall: unrecognised arg type %d\n",arg_ty);
3140 /* Pop arguments off the Hugs stack and Push them onto the C stack.
3141 * Used when preparing for Haskell calling C or in response to
3142 * C calling Haskell.
3144 nat unmarshall(char res_ty, void* res)
3148 *((int*)res) = PopTaggedInt();
3149 return ARG_SIZE(INT_TAG);
3150 #ifdef TODO_STANDALONE_INTEGER
3152 *((mpz_ptr*)res) = PopTaggedInteger();
3153 return ARG_SIZE(INTEGER_TAG);
3156 *((unsigned int*)res) = PopTaggedWord();
3157 return ARG_SIZE(WORD_TAG);
3159 *((int*)res) = PopTaggedChar();
3160 return ARG_SIZE(CHAR_TAG);
3162 *((float*)res) = PopTaggedFloat();
3163 return ARG_SIZE(FLOAT_TAG);
3165 *((double*)res) = PopTaggedDouble();
3166 return ARG_SIZE(DOUBLE_TAG);
3168 *((void**)res) = PopTaggedAddr();
3169 return ARG_SIZE(ADDR_TAG);
3171 *((StgStablePtr*)res) = PopTaggedStablePtr();
3172 return ARG_SIZE(STABLE_TAG);
3173 #ifdef PROVIDE_FOREIGN
3176 StgForeignObj *result = stgCast(StgForeignObj*,PopPtr());
3177 *((void**)res) = result->data;
3178 return sizeofW(StgPtr);
3184 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
3185 *((void**)res) = stgCast(void*,&(arr->payload));
3186 return sizeofW(StgPtr);
3189 barf("unmarshall: unrecognised result type %d\n",res_ty);
3193 nat argSize( const char* ks )
3196 for( ; *ks != '\0'; ++ks) {
3199 sz += sizeof(StgWord) * ARG_SIZE(INT_TAG);
3201 #ifdef TODO_STANDALONE_INTEGER
3203 sz += sizeof(StgWord) * ARG_SIZE(INTEGER_TAG);
3207 sz += sizeof(StgWord) * ARG_SIZE(WORD_TAG);
3210 sz += sizeof(StgWord) * ARG_SIZE(CHAR_TAG);
3213 sz += sizeof(StgWord) * ARG_SIZE(FLOAT_TAG);
3216 sz += sizeof(StgWord) * ARG_SIZE(DOUBLE_TAG);
3219 sz += sizeof(StgWord) * ARG_SIZE(ADDR_TAG);
3222 sz += sizeof(StgWord) * ARG_SIZE(STABLE_TAG);
3224 #ifdef PROVIDE_FOREIGN
3229 sz += sizeof(StgPtr);
3232 barf("argSize: unrecognised result type %d\n",*ks);
3240 /* -----------------------------------------------------------------------------
3241 * encode/decode Float/Double code for standalone Hugs
3242 * Code based on the HBC code (lib/fltcode.c) and more recently GHC
3243 * (ghc/rts/StgPrimFloat.c)
3244 * ---------------------------------------------------------------------------*/
3246 #ifdef STANDALONE_INTEGER
3248 #if IEEE_FLOATING_POINT
3249 #define MY_DMINEXP ((DBL_MIN_EXP) - (DBL_MANT_DIG) - 1)
3250 /* DMINEXP is defined in values.h on Linux (for example) */
3251 #define DHIGHBIT 0x00100000
3252 #define DMSBIT 0x80000000
3254 #define MY_FMINEXP ((FLT_MIN_EXP) - (FLT_MANT_DIG) - 1)
3255 #define FHIGHBIT 0x00800000
3256 #define FMSBIT 0x80000000
3258 #error The following code doesnt work in a non-IEEE FP environment
3261 #ifdef WORDS_BIGENDIAN
3270 StgDouble B__encodeDouble (B* s, I_ e) /* result = s * 2^e */
3275 /* Convert a B to a double; knows a lot about internal rep! */
3276 for(r = 0.0, i = s->used-1; i >= 0; i--)
3277 r = (r * B_BASE_FLT) + s->stuff[i];
3279 /* Now raise to the exponent */
3280 if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
3283 /* handle the sign */
3284 if (s->sign < 0) r = -r;
3291 #if ! FLOATS_AS_DOUBLES
3292 StgFloat B__encodeFloat (B* s, I_ e) /* result = s * 2^e */
3297 /* Convert a B to a float; knows a lot about internal rep! */
3298 for(r = 0.0, i = s->used-1; i >= 0; i--)
3299 r = (r * B_BASE_FLT) + s->stuff[i];
3301 /* Now raise to the exponent */
3302 if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
3305 /* handle the sign */
3306 if (s->sign < 0) r = -r;
3310 #endif /* FLOATS_AS_DOUBLES */
3314 /* This only supports IEEE floating point */
3315 void B__decodeDouble (B* man, I_* exp, StgDouble dbl)
3317 /* Do some bit fiddling on IEEE */
3318 nat low, high; /* assuming 32 bit ints */
3320 union { double d; int i[2]; } u; /* assuming 32 bit ints, 64 bit double */
3322 u.d = dbl; /* grab chunks of the double */
3326 ASSERT(B_BASE == 256);
3328 /* Assume that the supplied B is the right size */
3331 if (low == 0 && (high & ~DMSBIT) == 0) {
3332 man->sign = man->used = 0;
3337 iexp = ((high >> 20) & 0x7ff) + MY_DMINEXP;
3341 if (iexp != MY_DMINEXP) /* don't add hidden bit to denorms */
3345 /* A denorm, normalize the mantissa */
3346 while (! (high & DHIGHBIT)) {
3356 man->stuff[7] = (((W_)high) >> 24) & 0xff;
3357 man->stuff[6] = (((W_)high) >> 16) & 0xff;
3358 man->stuff[5] = (((W_)high) >> 8) & 0xff;
3359 man->stuff[4] = (((W_)high) ) & 0xff;
3361 man->stuff[3] = (((W_)low) >> 24) & 0xff;
3362 man->stuff[2] = (((W_)low) >> 16) & 0xff;
3363 man->stuff[1] = (((W_)low) >> 8) & 0xff;
3364 man->stuff[0] = (((W_)low) ) & 0xff;
3366 if (sign < 0) man->sign = -1;
3368 do_renormalise(man);
3372 #if ! FLOATS_AS_DOUBLES
3373 void B__decodeFloat (B* man, I_* exp, StgFloat flt)
3375 /* Do some bit fiddling on IEEE */
3376 int high, sign; /* assuming 32 bit ints */
3377 union { float f; int i; } u; /* assuming 32 bit float and int */
3379 u.f = flt; /* grab the float */
3382 ASSERT(B_BASE == 256);
3384 /* Assume that the supplied B is the right size */
3387 if ((high & ~FMSBIT) == 0) {
3388 man->sign = man->used = 0;
3393 *exp = ((high >> 23) & 0xff) + MY_FMINEXP;
3397 if (*exp != MY_FMINEXP) /* don't add hidden bit to denorms */
3401 /* A denorm, normalize the mantissa */
3402 while (! (high & FHIGHBIT)) {
3407 man->stuff[3] = (((W_)high) >> 24) & 0xff;
3408 man->stuff[2] = (((W_)high) >> 16) & 0xff;
3409 man->stuff[1] = (((W_)high) >> 8) & 0xff;
3410 man->stuff[0] = (((W_)high) ) & 0xff;
3412 if (sign < 0) man->sign = -1;
3414 do_renormalise(man);
3417 #endif /* FLOATS_AS_DOUBLES */
3419 #endif /* STANDALONE_INTEGER */
3421 #endif /* INTERPRETER */