2 /* -----------------------------------------------------------------------------
5 * Copyright (c) 1994-1998.
7 * $RCSfile: Evaluator.c,v $
9 * $Date: 2000/03/13 10:39:11 $
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"
27 #include "sainteger.h"
31 #include "Disassembler.h"
36 #include <math.h> /* These are for primops */
37 #include <limits.h> /* These are for primops */
38 #include <float.h> /* These are for primops */
40 #include <ieee754.h> /* These are for primops */
45 /* An incredibly useful abbreviation.
46 * Interestingly, there are some uses of END_TSO_QUEUE_closure that
47 * can't use it because they use the closure at type StgClosure* or
48 * even StgPtr*. I suspect they should be changed. -- ADR
50 #define EndTSOQueue stgCast(StgTSO*,(void*)&END_TSO_QUEUE_closure)
52 /* These macros are rather delicate - read a good ANSI C book carefully
56 #define mycat(x,y) x##y
57 #define mycat2(x,y) mycat(x,y)
58 #define mycat3(x,y,z) mycat2(x,mycat2(y,z))
60 #if defined(__GNUC__) && !defined(DEBUG)
61 #define USE_GCC_LABELS 1
63 #define USE_GCC_LABELS 0
66 /* Make it possible for the evaluator to get hold of bytecode
67 for a given function by name. Useful but a hack. Sigh.
69 extern void* getHugs_AsmObject_for ( char* s );
70 extern int /*Bool*/ combined;
72 /* --------------------------------------------------------------------------
73 * Crude profiling stuff (mainly to assess effect of optimiser)
74 * ------------------------------------------------------------------------*/
76 #ifdef CRUDE_PROFILING
85 struct { int /*StgVar*/ who;
93 CPRecord cpTab[M_CPTAB];
100 for (i = 0; i < M_CPTAB; i++)
101 cpTab[i].who = CP_NIL;
105 void cp_enter ( StgBCO* b )
109 int /*StgVar*/ v = b->stgexpr;
110 if ((void*)v == NULL) return;
119 h = (-v) % M_CPTAB; else
122 assert (h >= 0 && h < M_CPTAB);
123 while (cpTab[h].who != v && cpTab[h].who != CP_NIL) {
124 h++; if (h == M_CPTAB) h = 0;
127 if (cpTab[cpCurr].who == CP_NIL) {
128 cpTab[cpCurr].who = v;
129 if (!is_ret_cont) cpTab[cpCurr].enters = 1;
130 cpTab[cpCurr].bytes = cpTab[cpCurr].insns = 0;
132 if (cpInUse * 2 > M_CPTAB) {
133 fprintf(stderr, "\nCRUDE_PROFILING hash table is too full\n" );
137 if (!is_ret_cont) cpTab[cpCurr].enters++;
143 void cp_bill_words ( int nw )
145 if (cpCurr == CP_NIL) return;
146 cpTab[cpCurr].bytes += sizeof(StgWord)*nw;
150 void cp_bill_insns ( int ni )
152 if (cpCurr == CP_NIL) return;
153 cpTab[cpCurr].insns += ni;
157 static double percent ( double a, double b )
159 return (100.0 * a) / b;
163 void cp_show ( void )
165 int i, j, max, maxN, totE, totB, totI, cumE, cumB, cumI;
168 if (cpInUse == -1) return;
170 fflush(stdout);fflush(stderr);
173 totE = totB = totI = 0;
174 for (i = 0; i < M_CPTAB; i++) {
175 cpTab[i].twho = cpTab[i].who;
176 if (cpTab[i].who != CP_NIL) {
177 totE += cpTab[i].enters;
178 totB += cpTab[i].bytes;
179 totI += cpTab[i].insns;
184 "%6d (%7.3f M) enters, "
185 "%6d (%7.3f M) insns, "
186 "%6d (%7.3f M) bytes\n\n",
187 totE, totE/1000000.0, totI, totI/1000000.0, totB, totB/1000000.0 );
189 cumE = cumB = cumI = 0;
190 for (j = 0; j < 32; j++) {
193 for (i = 0; i < M_CPTAB; i++)
194 if (cpTab[i].who != CP_NIL &&
195 cpTab[i].enters > maxN) {
196 maxN = cpTab[i].enters;
199 if (max == -1) break;
201 cumE += cpTab[max].enters;
202 cumB += cpTab[max].bytes;
203 cumI += cpTab[max].insns;
205 strcpy(nm, maybeName(cpTab[max].who));
206 if (strcmp(nm, "(unknown)")==0)
207 sprintf ( nm, "id%d", -cpTab[max].who);
209 printf ( "%20s %7d es (%4.1f%%, %4.1f%% c) "
210 "%7d bs (%4.1f%%, %4.1f%% c) "
211 "%7d is (%4.1f%%, %4.1f%% c)\n",
213 cpTab[max].enters, percent(cpTab[max].enters,totE), percent(cumE,totE),
214 cpTab[max].bytes, percent(cpTab[max].bytes,totB), percent(cumB,totB),
215 cpTab[max].insns, percent(cpTab[max].insns,totI), percent(cumI,totI)
218 cpTab[max].twho = cpTab[max].who;
219 cpTab[max].who = CP_NIL;
222 for (i = 0; i < M_CPTAB; i++)
223 cpTab[i].who = cpTab[i].twho;
231 /* --------------------------------------------------------------------------
232 * Hugs Hooks - a bit of a hack
233 * ------------------------------------------------------------------------*/
235 void setRtsFlags( int x );
236 void setRtsFlags( int x )
238 unsigned int w = 0x12345678;
239 unsigned char* pw = (unsigned char *)&w;
242 *(int*)(&(RtsFlags.DebugFlags)) = x;
247 w2 |= (w1 && 0xFF); w2 <<= 8; w1 >>= 8;
248 w2 |= (w1 && 0xFF); w2 <<= 8; w1 >>= 8;
249 w2 |= (w1 && 0xFF); w2 <<= 8; w1 >>= 8;
250 w2 |= (w1 && 0xFF); w2 <<= 8; w1 >>= 8;
251 *(int*)(&(RtsFlags.DebugFlags)) = (int)w2;
256 /* --------------------------------------------------------------------------
257 * Entering-objects and bytecode interpreter part of evaluator
258 * ------------------------------------------------------------------------*/
260 /* The primop (and all other) parts of this evaluator operate upon the
261 machine state which lives in MainRegTable. enter is different:
262 to make its closure- and bytecode-interpreting loops go fast, some of that
263 state is pulled out into local vars (viz, registers, if we are lucky).
264 That means that we need to save(load) the local state at every exit(reentry)
265 into enter. That is, around every procedure call it makes. Blargh!
266 If you modify this code, __be warned__ it will fail in mysterious ways if
267 you fail to preserve this property.
269 Currently the pulled-out state is Sp in xSp, Su in xSu and SpLim in xSpLim.
270 The SSS macros saves the state back in MainRegTable, and LLL loads it from
271 MainRegTable. RETURN(v) does SSS and then returns v; all exits should
272 be via RETURN and not plain return.
274 Since xSp, xSu and xSpLim are local vars in enter, they are not visible
275 in procedures called from enter. To fix this, either (1) turn the
276 procedures into macros, so they get copied inline, or (2) bracket
277 the procedure call with SSS and LLL so that the local and global
278 machine states are synchronised for the duration of the call.
282 /* Forward decls ... */
283 static void* enterBCO_primop1 ( int );
284 static void* enterBCO_primop2 ( int , int* /*StgThreadReturnCode* */,
285 StgBCO**, Capability* );
286 static inline void PopUpdateFrame ( StgClosure* obj );
287 static inline void PopCatchFrame ( void );
288 static inline void PopSeqFrame ( void );
289 static inline void PopStopFrame( StgClosure* obj );
290 static inline void PushTaggedRealWorld( void );
291 /* static inline void PushTaggedInteger ( mpz_ptr ); */
292 static inline StgPtr grabHpUpd( nat size );
293 static inline StgPtr grabHpNonUpd( nat size );
294 static StgClosure* raiseAnError ( StgClosure* exception );
296 static int enterCountI = 0;
298 StgDouble B__encodeDouble (B* s, I_ e);
299 void B__decodeDouble (B* man, I_* exp, StgDouble dbl);
300 #if ! FLOATS_AS_DOUBLES
301 StgFloat B__encodeFloat (B* s, I_ e);
302 void B__decodeFloat (B* man, I_* exp, StgFloat flt);
303 StgPtr CreateByteArrayToHoldInteger ( int );
304 B* IntegerInsideByteArray ( StgPtr );
305 void SloppifyIntegerEnd ( StgPtr );
311 #define gSp MainRegTable.rSp
312 #define gSu MainRegTable.rSu
313 #define gSpLim MainRegTable.rSpLim
316 /* Macros to save/load local state. */
318 #define SSS { tSp=gSp = xSp; tSu=gSu = xSu; tSpLim=gSpLim = xSpLim; }
319 #define LLL { tSp=xSp = gSp; tSu=xSu = gSu; tSpLim=xSpLim = gSpLim; }
321 #define SSS { gSp = xSp; gSu = xSu; gSpLim = xSpLim; }
322 #define LLL { xSp = gSp; xSu = gSu; xSpLim = gSpLim; }
325 #define RETURN(vvv) { \
326 StgThreadReturnCode retVal=(vvv); \
328 cap->rCurrentTSO->sp = gSp; \
329 cap->rCurrentTSO->su = gSu; \
330 cap->rCurrentTSO->splim = gSpLim; \
335 /* Macros to operate directly on the pulled-out machine state.
336 These mirror some of the small procedures used in the primop code
337 below, except you have to be careful about side effects,
338 ie xPushPtr(xStackPtr(n)) won't work! It certainly isn't the
339 same as PushPtr(StackPtr(n)). Also note that (1) some of
340 the macros, in particular xPopTagged*, do not make the tag
341 sanity checks that their non-x cousins do, and (2) some of
342 the macros depend critically on the semantics of C comma
343 expressions to work properly.
345 #define xPushPtr(ppp) { xSp--; *xSp=(StgWord)(ppp); }
346 #define xPopPtr() ((StgPtr)(*xSp++))
348 #define xPushCPtr(ppp) { xSp--; *xSp=(StgWord)(ppp); }
349 #define xPopCPtr() ((StgClosure*)(*xSp++))
351 #define xPushWord(ppp) { xSp--; *xSp=(StgWord)(ppp); }
352 #define xPopWord() ((StgWord)(*xSp++))
354 #define xStackPtr(nnn) ((StgPtr)(*(xSp+(nnn))))
355 #define xStackWord(nnn) ((StgWord)(*(xSp+(nnn))))
356 #define xSetStackWord(iii,www) xSp[iii]=(StgWord)(www)
358 #define xPushTag(ttt) { xSp--; *xSp=(StgWord)(ttt); }
359 #define xPopTag(ttt) { StackTag t = (StackTag)(*xSp++); \
362 #define xPushTaggedInt(xxx) { xSp -= sizeofW(StgInt); \
363 *xSp = (xxx); xPushTag(INT_TAG); }
364 #define xTaggedStackInt(iii) ((StgInt)(*(xSp+1+(iii))))
365 #define xPopTaggedInt() ((xSp++,xSp+=sizeofW(StgInt), \
366 (StgInt)(*(xSp-sizeofW(StgInt)))))
368 #define xPushTaggedWord(xxx) { xSp -= sizeofW(StgWord); \
369 *xSp = (xxx); xPushTag(WORD_TAG); }
370 #define xTaggedStackWord(iii) ((StgWord)(*(xSp+1+(iii))))
371 #define xPopTaggedWord() ((xSp++,xSp+=sizeofW(StgWord), \
372 (StgWord)(*(xSp-sizeofW(StgWord)))))
374 #define xPushTaggedAddr(xxx) { xSp -= sizeofW(StgAddr); \
375 *xSp = (StgWord)(xxx); xPushTag(ADDR_TAG); }
376 #define xTaggedStackAddr(iii) ((StgAddr)(*(xSp+1+(iii))))
377 #define xPopTaggedAddr() ((xSp++,xSp+=sizeofW(StgAddr), \
378 (StgAddr)(*(xSp-sizeofW(StgAddr)))))
380 #define xPushTaggedStable(xxx) { xSp -= sizeofW(StgStablePtr); \
381 *xSp = (StgWord)(xxx); xPushTag(STABLE_TAG); }
382 #define xTaggedStackStable(iii) ((StgStablePtr)(*(xSp+1+(iii))))
383 #define xPopTaggedStable() ((xSp++,xSp+=sizeofW(StgStablePtr), \
384 (StgStablePtr)(*(xSp-sizeofW(StgStablePtr)))))
386 #define xPushTaggedChar(xxx) { xSp -= sizeofW(StgChar); \
387 *xSp = (StgWord)(xxx); xPushTag(CHAR_TAG); }
388 #define xTaggedStackChar(iii) ((StgChar)(*(xSp+1+(iii))))
389 #define xPopTaggedChar() ((xSp++,xSp+=sizeofW(StgChar), \
390 (StgChar)(*(xSp-sizeofW(StgChar)))))
392 #define xPushTaggedFloat(xxx) { xSp -= sizeofW(StgFloat); \
393 ASSIGN_FLT(xSp,xxx); xPushTag(FLOAT_TAG); }
394 #define xTaggedStackFloat(iii) PK_FLT(xSp+1+(iii))
395 #define xPopTaggedFloat() ((xSp++,xSp+=sizeofW(StgFloat), \
396 PK_FLT(xSp-sizeofW(StgFloat))))
398 #define xPushTaggedDouble(xxx) { xSp -= sizeofW(StgDouble); \
399 ASSIGN_DBL(xSp,xxx); xPushTag(DOUBLE_TAG); }
400 #define xTaggedStackDouble(iii) PK_DBL(xSp+1+(iii))
401 #define xPopTaggedDouble() ((xSp++,xSp+=sizeofW(StgDouble), \
402 PK_DBL(xSp-sizeofW(StgDouble))))
405 #define xPushUpdateFrame(target, xSp_offset) \
407 StgUpdateFrame *__frame; \
408 __frame = (StgUpdateFrame *)(xSp + (xSp_offset)) - 1; \
409 SET_INFO(__frame, (StgInfoTable *)&Upd_frame_info); \
410 __frame->link = xSu; \
411 __frame->updatee = (StgClosure *)(target); \
415 #define xPopUpdateFrame(ooo) \
417 /* NB: doesn't assume that Sp == Su */ \
418 IF_DEBUG(evaluator, \
419 fprintf(stderr, "Updating "); \
420 printPtr(stgCast(StgPtr,xSu->updatee)); \
421 fprintf(stderr, " with "); \
423 fprintf(stderr,"xSp = %p\txSu = %p\n\n", xSp, xSu); \
425 UPD_IND(xSu->updatee,ooo); \
426 xSp = stgCast(StgStackPtr,xSu) + sizeofW(StgUpdateFrame); \
432 /* Instruction stream macros */
433 #define BCO_INSTR_8 *bciPtr++
434 #define BCO_INSTR_16 ((bciPtr += 2, (*(bciPtr-2) << 8) + *(bciPtr-1)))
435 #define PC (bciPtr - &(bcoInstr(bco,0)))
438 /* State on entry to enter():
439 * - current thread is in cap->rCurrentTSO;
440 * - allocation area is in cap->rCurrentNursery & cap->rNursery
443 StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 )
445 /* use of register here is primarily to make it clear to compilers
446 that these entities are non-aliasable.
448 register StgPtr xSp; /* local state -- stack pointer */
449 register StgUpdateFrame* xSu; /* local state -- frame pointer */
450 register StgPtr xSpLim; /* local state -- stack lim pointer */
451 register StgClosure* obj; /* object currently under evaluation */
452 char eCount; /* enter counter, for context switching */
455 StgPtr tSp; StgUpdateFrame* tSu; StgPtr tSpLim;
458 gSp = cap->rCurrentTSO->sp;
459 gSu = cap->rCurrentTSO->su;
460 gSpLim = cap->rCurrentTSO->splim;
463 /* use the t values to check that Su/Sp/SpLim do not change unexpectedly */
464 tSp = gSp; tSu = gSu; tSpLim = gSpLim;
470 /* Load the local state from global state, and Party On, Dudes! */
471 /* From here onwards, we operate with the local state and
472 save/reload it as necessary.
481 assert(gSpLim == tSpLim);
485 ASSERT(xSpLim <= xSp && xSp <= stgCast(StgPtr,xSu));
487 "\n---------------------------------------------------------------\n");
488 fprintf(stderr,"(%d) Entering: ",enterCountI); printObj(obj);
489 fprintf(stderr,"xSp = %p\txSu = %p\n", xSp, xSu);
490 fprintf(stderr, "\n" );
491 printStack(xSp,cap->rCurrentTSO->stack+cap->rCurrentTSO->stack_size,xSu);
492 fprintf(stderr, "\n\n");
499 ((++eCount) & 0x0F) == 0
504 if (context_switch) {
505 xPushCPtr(obj); /* code to restart with */
506 RETURN(ThreadYielding);
510 switch ( get_itbl(obj)->type ) {
512 barf("Invalid object %p",obj);
516 /* ---------------------------------------------------- */
517 /* Start of the bytecode evaluator */
518 /* ---------------------------------------------------- */
521 # define Ins(x) &&l##x
522 static void *labs[] = { INSTRLIST };
524 # define LoopTopLabel
525 # define Case(x) l##x
526 # define Continue goto *labs[BCO_INSTR_8]
527 # define Dispatch Continue;
530 # define LoopTopLabel insnloop:
531 # define Case(x) case x
532 # define Continue goto insnloop
533 # define Dispatch switch (BCO_INSTR_8) {
534 # define EndDispatch }
537 register StgWord8* bciPtr; /* instruction pointer */
538 register StgBCO* bco = (StgBCO*)obj;
541 /* Don't need to SSS ... LLL around doYouWantToGC */
542 wantToGC = doYouWantToGC();
544 xPushCPtr((StgClosure*)bco); /* code to restart with */
545 RETURN(HeapOverflow);
553 bciPtr = &(bcoInstr(bco,0));
557 ASSERT((StgWord)(PC) < bco->n_instrs);
559 fprintf(stderr,"Sp = %p\tSu = %p\tpc = %d\t", xSp, xSu, PC);
563 fprintf(stderr,"\n");
564 for (i = 8; i >= 0; i--)
565 fprintf(stderr, "%d %p\n", i, (StgPtr)(*(gSp+i)));
567 fprintf(stderr,"\n");
572 SSS; cp_bill_insns(1); LLL;
577 Case(i_INTERNAL_ERROR):
578 barf("INTERNAL_ERROR at %p:%d",bco,PC-1);
580 barf("PANIC at %p:%d",bco,PC-1);
584 if (xSp - n < xSpLim) {
585 xPushCPtr((StgClosure*)bco); /* code to restart with */
586 RETURN(StackOverflow);
590 Case(i_STK_CHECK_big):
592 int n = BCO_INSTR_16;
593 if (xSp - n < xSpLim) {
594 xPushCPtr((StgClosure*)bco); /* code to restart with */
595 RETURN(StackOverflow);
602 if ((StgPtr*)(xSp + n) > (StgPtr*)xSu) {
603 StgWord words = (P_)xSu - xSp;
605 /* first build a PAP */
606 ASSERT((P_)xSu >= xSp); /* was (words >= 0) but that's always true */
607 if (words == 0) { /* optimisation */
608 /* Skip building the PAP and update with an indirection. */
611 /* In the evaluator, we avoid the need to do
612 * a heap check here by including the size of
613 * the PAP in the heap check we performed
614 * when we entered the BCO.
618 SSS; pap = (StgPAP*)grabHpNonUpd(PAP_sizeW(words)); LLL;
619 SET_HDR(pap,&PAP_info,CC_pap);
622 for (i = 0; i < (I_)words; ++i) {
623 payloadWord(pap,i) = xSp[i];
626 obj = stgCast(StgClosure*,pap);
629 /* now deal with "update frame" */
630 /* as an optimisation, we process all on top of stack */
631 /* instead of just the top one */
632 ASSERT(xSp==(P_)xSu);
634 switch (get_itbl(xSu)->type) {
636 /* Hit a catch frame during an arg satisfaction check,
637 * so the thing returning (1) has not thrown an
638 * exception, and (2) is of functional type. Just
639 * zap the catch frame and carry on down the stack
640 * (looking for more arguments, basically).
642 SSS; PopCatchFrame(); LLL;
645 xPopUpdateFrame(obj);
648 SSS; PopStopFrame(obj); LLL;
649 RETURN(ThreadFinished);
651 SSS; PopSeqFrame(); LLL;
652 ASSERT(xSp != (P_)xSu);
653 /* Hit a SEQ frame during an arg satisfaction check.
654 * So now return to bco_info which is under the
655 * SEQ frame. The following code is copied from a
656 * case RET_BCO further down. (The reason why we're
657 * here is that something of functional type has
658 * been seq-d on, and we're now returning to the
659 * algebraic-case-continuation which forced the
660 * evaluation in the first place.)
672 barf("Invalid update frame during argcheck");
674 } while (xSp==(P_)xSu);
682 int words = BCO_INSTR_8;
683 SSS; p = grabHpUpd(AP_sizeW(words)); LLL;
687 Case(i_ALLOC_CONSTR):
690 StgInfoTable* info = bcoConstAddr(bco,BCO_INSTR_8);
691 SSS; p = grabHpNonUpd(sizeW_fromITBL(info)); LLL;
692 SET_HDR((StgClosure*)p,info,??);
696 Case(i_ALLOC_CONSTR_big):
699 int x = BCO_INSTR_16;
700 StgInfoTable* info = bcoConstAddr(bco,x);
701 SSS; p = grabHpNonUpd(sizeW_fromITBL(info)); LLL;
702 SET_HDR((StgClosure*)p,info,??);
708 int x = BCO_INSTR_8; /* ToDo: Word not Int! */
710 StgAP_UPD* o = stgCast(StgAP_UPD*,xStackPtr(x));
711 SET_HDR(o,&AP_UPD_info,??);
713 o->fun = stgCast(StgClosure*,xPopPtr());
714 for(x=0; x < y; ++x) {
715 payloadWord(o,x) = xPopWord();
718 fprintf(stderr,"\tBuilt ");
720 printObj(stgCast(StgClosure*,o));
731 o = stgCast(StgAP_UPD*,xStackPtr(x));
732 SET_HDR(o,&AP_UPD_info,??);
734 o->fun = stgCast(StgClosure*,xPopPtr());
735 for(x=0; x < y; ++x) {
736 payloadWord(o,x) = xPopWord();
739 fprintf(stderr,"\tBuilt ");
741 printObj(stgCast(StgClosure*,o));
750 StgPAP* o = stgCast(StgPAP*,xStackPtr(x));
751 SET_HDR(o,&PAP_info,??);
753 o->fun = stgCast(StgClosure*,xPopPtr());
754 for(x=0; x < y; ++x) {
755 payloadWord(o,x) = xPopWord();
758 fprintf(stderr,"\tBuilt ");
760 printObj(stgCast(StgClosure*,o));
767 int offset = BCO_INSTR_8;
768 StgClosure* o = stgCast(StgClosure*,xStackPtr(offset));
769 const StgInfoTable* info = get_itbl(o);
770 nat p = info->layout.payload.ptrs;
771 nat np = info->layout.payload.nptrs;
773 for(i=0; i < p; ++i) {
774 payloadCPtr(o,i) = xPopCPtr();
776 for(i=0; i < np; ++i) {
777 payloadWord(o,p+i) = 0xdeadbeef;
780 fprintf(stderr,"\tBuilt ");
782 printObj(stgCast(StgClosure*,o));
789 int offset = BCO_INSTR_16;
790 StgClosure* o = stgCast(StgClosure*,xStackPtr(offset));
791 const StgInfoTable* info = get_itbl(o);
792 nat p = info->layout.payload.ptrs;
793 nat np = info->layout.payload.nptrs;
795 for(i=0; i < p; ++i) {
796 payloadCPtr(o,i) = xPopCPtr();
798 for(i=0; i < np; ++i) {
799 payloadWord(o,p+i) = 0xdeadbeef;
802 fprintf(stderr,"\tBuilt ");
804 printObj(stgCast(StgClosure*,o));
813 ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
814 /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
816 xSetStackWord(x+y,xStackWord(x));
826 ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
827 /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
829 xSetStackWord(x+y,xStackWord(x));
841 xPushPtr(bcoConstPtr(bco,BCO_INSTR_8));
842 xPushPtr(stgCast(StgPtr,&ret_bco_info));
847 int tag = BCO_INSTR_8;
848 StgWord offset = BCO_INSTR_16;
849 if (constrTag( (StgClosure*)xStackPtr(0) ) != tag) {
856 StgClosure* o = stgCast(StgClosure*,xStackPtr(0));
857 const StgInfoTable* itbl = get_itbl(o);
858 int i = itbl->layout.payload.ptrs;
859 ASSERT( itbl->type == CONSTR
860 || itbl->type == CONSTR_STATIC
861 || itbl->type == CONSTR_NOCAF_STATIC
862 || itbl->type == CONSTR_1_0
863 || itbl->type == CONSTR_0_1
864 || itbl->type == CONSTR_2_0
865 || itbl->type == CONSTR_1_1
866 || itbl->type == CONSTR_0_2
869 xPushCPtr(payloadCPtr(o,i));
875 int n = BCO_INSTR_16;
876 StgPtr p = xStackPtr(n);
882 StgPtr p = xStackPtr(BCO_INSTR_8);
888 xPushPtr(stgCast(StgPtr,bcoConstPtr(bco,BCO_INSTR_8)));
893 int n = BCO_INSTR_16;
894 xPushPtr(stgCast(StgPtr,bcoConstPtr(bco,n)));
899 SSS; PushTaggedRealWorld(); LLL;
904 StgInt i = xTaggedStackInt(BCO_INSTR_8);
910 xPushTaggedInt(bcoConstInt(bco,BCO_INSTR_8));
913 Case(i_CONST_INT_big):
915 int n = BCO_INSTR_16;
916 xPushTaggedInt(bcoConstInt(bco,n));
922 SSS; o = (StgClosure*)grabHpNonUpd(Izh_sizeW); LLL;
923 SET_HDR(o,&Izh_con_info,??);
924 payloadWord(o,0) = xPopTaggedInt();
926 fprintf(stderr,"\tBuilt ");
928 printObj(stgCast(StgClosure*,o));
931 xPushPtr(stgCast(StgPtr,o));
936 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
937 /* ASSERT(isIntLike(con)); */
938 xPushTaggedInt(payloadWord(con,0));
943 StgWord offset = BCO_INSTR_16;
944 StgInt x = xPopTaggedInt();
945 StgInt y = xPopTaggedInt();
951 Case(i_CONST_INTEGER):
955 char* s = bcoConstAddr(bco,BCO_INSTR_8);
958 p = CreateByteArrayToHoldInteger(n);
959 do_fromStr ( s, n, IntegerInsideByteArray(p));
960 SloppifyIntegerEnd(p);
967 StgWord w = xTaggedStackWord(BCO_INSTR_8);
973 xPushTaggedWord(bcoConstWord(bco,BCO_INSTR_8));
979 SSS; o = (StgClosure*)grabHpNonUpd(Wzh_sizeW); LLL;
980 SET_HDR(o,&Wzh_con_info,??);
981 payloadWord(o,0) = xPopTaggedWord();
983 fprintf(stderr,"\tBuilt ");
985 printObj(stgCast(StgClosure*,o));
988 xPushPtr(stgCast(StgPtr,o));
993 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
994 /* ASSERT(isWordLike(con)); */
995 xPushTaggedWord(payloadWord(con,0));
1000 StgAddr a = xTaggedStackAddr(BCO_INSTR_8);
1006 xPushTaggedAddr(bcoConstAddr(bco,BCO_INSTR_8));
1009 Case(i_CONST_ADDR_big):
1011 int n = BCO_INSTR_16;
1012 xPushTaggedAddr(bcoConstAddr(bco,n));
1018 SSS; o = (StgClosure*)grabHpNonUpd(Azh_sizeW); LLL;
1019 SET_HDR(o,&Azh_con_info,??);
1020 payloadPtr(o,0) = xPopTaggedAddr();
1022 fprintf(stderr,"\tBuilt ");
1024 printObj(stgCast(StgClosure*,o));
1027 xPushPtr(stgCast(StgPtr,o));
1030 Case(i_UNPACK_ADDR):
1032 StgClosure* con = (StgClosure*)xStackPtr(0);
1033 /* ASSERT(isAddrLike(con)); */
1034 xPushTaggedAddr(payloadPtr(con,0));
1039 StgChar c = xTaggedStackChar(BCO_INSTR_8);
1045 xPushTaggedChar(bcoConstChar(bco,BCO_INSTR_8));
1051 SSS; o = (StgClosure*)grabHpNonUpd(Czh_sizeW); LLL;
1052 SET_HDR(o,&Czh_con_info,??);
1053 payloadWord(o,0) = xPopTaggedChar();
1054 xPushPtr(stgCast(StgPtr,o));
1056 fprintf(stderr,"\tBuilt ");
1058 printObj(stgCast(StgClosure*,o));
1063 Case(i_UNPACK_CHAR):
1065 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1066 /* ASSERT(isCharLike(con)); */
1067 xPushTaggedChar(payloadWord(con,0));
1072 StgFloat f = xTaggedStackFloat(BCO_INSTR_8);
1073 xPushTaggedFloat(f);
1076 Case(i_CONST_FLOAT):
1078 xPushTaggedFloat(bcoConstFloat(bco,BCO_INSTR_8));
1084 SSS; o = (StgClosure*)grabHpNonUpd(Fzh_sizeW); LLL;
1085 SET_HDR(o,&Fzh_con_info,??);
1086 ASSIGN_FLT(&payloadWord(o,0),xPopTaggedFloat());
1088 fprintf(stderr,"\tBuilt ");
1090 printObj(stgCast(StgClosure*,o));
1093 xPushPtr(stgCast(StgPtr,o));
1096 Case(i_UNPACK_FLOAT):
1098 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1099 /* ASSERT(isFloatLike(con)); */
1100 xPushTaggedFloat(PK_FLT(&payloadWord(con,0)));
1105 StgDouble d = xTaggedStackDouble(BCO_INSTR_8);
1106 xPushTaggedDouble(d);
1109 Case(i_CONST_DOUBLE):
1111 xPushTaggedDouble(bcoConstDouble(bco,BCO_INSTR_8));
1114 Case(i_CONST_DOUBLE_big):
1116 int n = BCO_INSTR_16;
1117 xPushTaggedDouble(bcoConstDouble(bco,n));
1120 Case(i_PACK_DOUBLE):
1123 SSS; o = (StgClosure*)grabHpNonUpd(Dzh_sizeW); LLL;
1124 SET_HDR(o,&Dzh_con_info,??);
1125 ASSIGN_DBL(&payloadWord(o,0),xPopTaggedDouble());
1127 fprintf(stderr,"\tBuilt ");
1128 printObj(stgCast(StgClosure*,o));
1130 xPushPtr(stgCast(StgPtr,o));
1133 Case(i_UNPACK_DOUBLE):
1135 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1136 /* ASSERT(isDoubleLike(con)); */
1137 xPushTaggedDouble(PK_DBL(&payloadWord(con,0)));
1142 StgStablePtr s = xTaggedStackStable(BCO_INSTR_8);
1143 xPushTaggedStable(s);
1146 Case(i_PACK_STABLE):
1149 SSS; o = (StgClosure*)grabHpNonUpd(Stablezh_sizeW); LLL;
1150 SET_HDR(o,&StablePtr_con_info,??);
1151 payloadWord(o,0) = xPopTaggedStable();
1153 fprintf(stderr,"\tBuilt ");
1155 printObj(stgCast(StgClosure*,o));
1158 xPushPtr(stgCast(StgPtr,o));
1161 Case(i_UNPACK_STABLE):
1163 StgClosure* con = (StgClosure*)xStackPtr(0);
1164 /* ASSERT(isStableLike(con)); */
1165 xPushTaggedStable(payloadWord(con,0));
1173 SSS; p = enterBCO_primop1 ( i ); LLL;
1174 if (p) { obj = p; goto enterLoop; };
1179 int i, trc, pc_saved;
1182 trc = 12345678; /* Assume != any StgThreadReturnCode */
1187 p = enterBCO_primop2 ( i, &trc, &bco_tmp, cap );
1190 bciPtr = &(bcoInstr(bco,pc_saved));
1192 if (trc == 12345678) {
1193 /* we want to enter p */
1194 obj = p; goto enterLoop;
1196 /* trc is the the StgThreadReturnCode for this thread */
1197 RETURN((StgThreadReturnCode)trc);
1203 /* combined insns, created by peephole opt */
1206 int x = BCO_INSTR_8;
1207 int y = BCO_INSTR_8;
1208 ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
1209 /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
1216 xSetStackWord(x+y,xStackWord(x));
1226 p = xStackPtr(BCO_INSTR_8);
1228 p = xStackPtr(BCO_INSTR_8);
1235 xPushPtr(bcoConstPtr(bco,BCO_INSTR_8));
1236 xPushPtr(stgCast(StgPtr,&ret_bco_info));
1237 p = xStackPtr(BCO_INSTR_8);
1243 StgPtr retaddr = bcoConstPtr(bco,BCO_INSTR_8);
1244 StgPtr ptr = xStackPtr(BCO_INSTR_8);
1246 /* A shortcut. We're going to push the address of a
1247 return continuation, and then enter a variable, so
1248 that when the var is evaluated, we return to the
1249 continuation. The shortcut is: if the var is a
1250 constructor, don't bother to enter it. Instead,
1251 push the variable on the stack (since this is what
1252 the continuation expects) and jump directly to the
1255 if (get_itbl((StgClosure*)ptr)->type == CONSTR) {
1257 obj = (StgClosure*)retaddr;
1259 fprintf(stderr, "object to enter is a constructor -- "
1260 "jumping directly to return continuation\n" );
1265 /* This is the normal, non-short-cut route */
1267 xPushPtr(stgCast(StgPtr,&ret_bco_info));
1268 obj = (StgClosure*)ptr;
1273 Case(i_VAR_DOUBLE_big):
1274 Case(i_CONST_FLOAT_big):
1275 Case(i_VAR_FLOAT_big):
1276 Case(i_CONST_CHAR_big):
1277 Case(i_VAR_CHAR_big):
1278 Case(i_VAR_ADDR_big):
1279 Case(i_VAR_STABLE_big):
1280 Case(i_CONST_INTEGER_big):
1281 Case(i_VAR_INT_big):
1282 Case(i_VAR_WORD_big):
1283 Case(i_RETADDR_big):
1287 disInstr ( bco, PC );
1288 barf("\nUnrecognised instruction");
1292 barf("enterBCO: ran off end of loop");
1296 # undef LoopTopLabel
1302 /* ---------------------------------------------------- */
1303 /* End of the bytecode evaluator */
1304 /* ---------------------------------------------------- */
1308 StgBlockingQueue* bh;
1309 StgCAF* caf = (StgCAF*)obj;
1310 if (xSp - sizeofW(StgUpdateFrame) < xSpLim) {
1311 xPushCPtr(obj); /* code to restart with */
1312 RETURN(StackOverflow);
1314 /* ToDo: look for xSp==xSu && stackInt(0) == UPD_FRAME
1315 and insert an indirection immediately */
1316 SSS; bh = (StgBlockingQueue*)grabHpUpd(BLACKHOLE_sizeW()); LLL;
1317 SET_INFO(bh,&CAF_BLACKHOLE_info);
1318 bh->blocking_queue = EndTSOQueue;
1320 fprintf(stderr,"Created CAF_BLACKHOLE %p for CAF %p in evaluator\n",bh,caf));
1321 SET_INFO(caf,&CAF_ENTERED_info);
1322 caf->value = (StgClosure*)bh;
1323 if (caf->mut_link == NULL) {
1324 SSS; recordOldToNewPtrs((StgMutClosure*)caf); LLL;
1326 xPushUpdateFrame(bh,0);
1327 xSp -= sizeofW(StgUpdateFrame);
1328 caf->link = enteredCAFs;
1335 StgCAF* caf = (StgCAF*)obj;
1336 obj = caf->value; /* it's just a fancy indirection */
1342 case SE_CAF_BLACKHOLE:
1344 /* Let the scheduler figure out what to do :-) */
1345 cap->rCurrentTSO->whatNext = ThreadEnterGHC;
1347 RETURN(ThreadYielding);
1351 StgAP_UPD* ap = stgCast(StgAP_UPD*,obj);
1353 if (xSp - (i + sizeofW(StgUpdateFrame)) < xSpLim) {
1354 xPushCPtr(obj); /* code to restart with */
1355 RETURN(StackOverflow);
1357 /* ToDo: look for xSp==xSu && stackInt(0) == UPD_FRAME
1358 and insert an indirection immediately */
1359 xPushUpdateFrame(ap,0);
1360 xSp -= sizeofW(StgUpdateFrame);
1362 xPushWord(payloadWord(ap,i));
1365 #ifdef EAGER_BLACKHOLING
1366 #warn LAZY_BLACKHOLING is default for StgHugs
1367 #error Dont know if EAGER_BLACKHOLING works in StgHugs
1369 /* superfluous - but makes debugging easier */
1370 StgBlackHole* bh = stgCast(StgBlackHole*,ap);
1371 SET_INFO(bh,&BLACKHOLE_info);
1372 bh->blocking_queue = EndTSOQueue;
1374 fprintf(stderr,"Eagerly blackholed AP_UPD %p in evaluator\n",bh));
1377 #endif /* EAGER_BLACKHOLING */
1382 StgPAP* pap = stgCast(StgPAP*,obj);
1383 int i = pap->n_args; /* ToDo: stack check */
1384 /* ToDo: if PAP is in whnf, we can update any update frames
1388 xPushWord(payloadWord(pap,i));
1395 obj = stgCast(StgInd*,obj)->indirectee;
1400 obj = stgCast(StgIndOldGen*,obj)->indirectee;
1409 case CONSTR_INTLIKE:
1410 case CONSTR_CHARLIKE:
1412 case CONSTR_NOCAF_STATIC:
1415 switch (get_itbl(stgCast(StgClosure*,xSp))->type) {
1417 SSS; PopCatchFrame(); LLL;
1420 xPopUpdateFrame(obj);
1423 SSS; PopSeqFrame(); LLL;
1427 ASSERT(xSp==(P_)xSu);
1430 fprintf(stderr, "hit a STOP_FRAME\n");
1432 fprintf(stderr,"xSp = %p\txSu = %p\n", xSp, xSu);
1433 printStack(xSp,cap->rCurrentTSO->stack
1434 + cap->rCurrentTSO->stack_size,xSu);
1437 SSS; PopStopFrame(obj); LLL;
1438 RETURN(ThreadFinished);
1448 /* was: goto enterLoop;
1449 But we know that obj must be a bco now, so jump directly.
1452 case RET_SMALL: /* return to GHC */
1456 cap->rCurrentTSO->whatNext = ThreadEnterGHC;
1458 RETURN(ThreadYielding);
1460 belch("entered CONSTR with invalid continuation on stack");
1463 printObj(stgCast(StgClosure*,xSp));
1466 barf("bailing out");
1473 //fprintf(stderr, "enterCountI = %d\n", enterCountI);
1474 //fprintf(stderr, "entering unknown closure -- yielding to sched\n");
1477 cap->rCurrentTSO->whatNext = ThreadEnterGHC;
1478 xPushCPtr(obj); /* code to restart with */
1479 RETURN(ThreadYielding);
1482 barf("Ran off the end of enter - yoiks");
1499 #undef xSetStackWord
1502 #undef xPushTaggedInt
1503 #undef xPopTaggedInt
1504 #undef xTaggedStackInt
1505 #undef xPushTaggedWord
1506 #undef xPopTaggedWord
1507 #undef xTaggedStackWord
1508 #undef xPushTaggedAddr
1509 #undef xTaggedStackAddr
1510 #undef xPopTaggedAddr
1511 #undef xPushTaggedStable
1512 #undef xTaggedStackStable
1513 #undef xPopTaggedStable
1514 #undef xPushTaggedChar
1515 #undef xTaggedStackChar
1516 #undef xPopTaggedChar
1517 #undef xPushTaggedFloat
1518 #undef xTaggedStackFloat
1519 #undef xPopTaggedFloat
1520 #undef xPushTaggedDouble
1521 #undef xTaggedStackDouble
1522 #undef xPopTaggedDouble
1523 #undef xPopUpdateFrame
1524 #undef xPushUpdateFrame
1527 /* --------------------------------------------------------------------------
1528 * Supporting routines for primops
1529 * ------------------------------------------------------------------------*/
1531 static inline void PushTag ( StackTag t )
1533 inline void PushPtr ( StgPtr x )
1534 { *(--stgCast(StgPtr*,gSp)) = x; }
1535 static inline void PushCPtr ( StgClosure* x )
1536 { *(--stgCast(StgClosure**,gSp)) = x; }
1537 static inline void PushInt ( StgInt x )
1538 { *(--stgCast(StgInt*,gSp)) = x; }
1539 static inline void PushWord ( StgWord x )
1540 { *(--stgCast(StgWord*,gSp)) = x; }
1543 static inline void checkTag ( StackTag t1, StackTag t2 )
1544 { ASSERT(t1 == t2);}
1545 static inline void PopTag ( StackTag t )
1546 { checkTag(t,*(gSp++)); }
1547 inline StgPtr PopPtr ( void )
1548 { return *stgCast(StgPtr*,gSp)++; }
1549 static inline StgClosure* PopCPtr ( void )
1550 { return *stgCast(StgClosure**,gSp)++; }
1551 static inline StgInt PopInt ( void )
1552 { return *stgCast(StgInt*,gSp)++; }
1553 static inline StgWord PopWord ( void )
1554 { return *stgCast(StgWord*,gSp)++; }
1556 static inline StgPtr stackPtr ( StgStackOffset i )
1557 { return *stgCast(StgPtr*, gSp+i); }
1558 static inline StgInt stackInt ( StgStackOffset i )
1559 { return *stgCast(StgInt*, gSp+i); }
1560 static inline StgWord stackWord ( StgStackOffset i )
1561 { return *stgCast(StgWord*,gSp+i); }
1563 static inline void setStackWord ( StgStackOffset i, StgWord w )
1566 static inline void PushTaggedRealWorld( void )
1567 { PushTag(REALWORLD_TAG); }
1568 inline void PushTaggedInt ( StgInt x )
1569 { gSp -= sizeofW(StgInt); *gSp = x; PushTag(INT_TAG); }
1570 inline void PushTaggedWord ( StgWord x )
1571 { gSp -= sizeofW(StgWord); *gSp = x; PushTag(WORD_TAG); }
1572 inline void PushTaggedAddr ( StgAddr x )
1573 { gSp -= sizeofW(StgAddr); *gSp = (W_)x; PushTag(ADDR_TAG); }
1574 inline void PushTaggedChar ( StgChar x )
1575 { gSp -= sizeofW(StgChar); *gSp = stgCast(StgWord,x); PushTag(CHAR_TAG); }
1576 inline void PushTaggedFloat ( StgFloat x )
1577 { gSp -= sizeofW(StgFloat); ASSIGN_FLT(gSp,x); PushTag(FLOAT_TAG); }
1578 inline void PushTaggedDouble ( StgDouble x )
1579 { gSp -= sizeofW(StgDouble); ASSIGN_DBL(gSp,x); PushTag(DOUBLE_TAG); }
1580 inline void PushTaggedStablePtr ( StgStablePtr x )
1581 { gSp -= sizeofW(StgStablePtr); *gSp = x; PushTag(STABLE_TAG); }
1582 static inline void PushTaggedBool ( int x )
1583 { PushTaggedInt(x); }
1587 static inline void PopTaggedRealWorld ( void )
1588 { PopTag(REALWORLD_TAG); }
1589 inline StgInt PopTaggedInt ( void )
1590 { StgInt r; PopTag(INT_TAG); r = *stgCast(StgInt*, gSp);
1591 gSp += sizeofW(StgInt); return r;}
1592 inline StgWord PopTaggedWord ( void )
1593 { StgWord r; PopTag(WORD_TAG); r = *stgCast(StgWord*, gSp);
1594 gSp += sizeofW(StgWord); return r;}
1595 inline StgAddr PopTaggedAddr ( void )
1596 { StgAddr r; PopTag(ADDR_TAG); r = *stgCast(StgAddr*, gSp);
1597 gSp += sizeofW(StgAddr); return r;}
1598 inline StgChar PopTaggedChar ( void )
1599 { StgChar r; PopTag(CHAR_TAG); r = stgCast(StgChar, *gSp);
1600 gSp += sizeofW(StgChar); return r;}
1601 inline StgFloat PopTaggedFloat ( void )
1602 { StgFloat r; PopTag(FLOAT_TAG); r = PK_FLT(gSp);
1603 gSp += sizeofW(StgFloat); return r;}
1604 inline StgDouble PopTaggedDouble ( void )
1605 { StgDouble r; PopTag(DOUBLE_TAG); r = PK_DBL(gSp);
1606 gSp += sizeofW(StgDouble); return r;}
1607 inline StgStablePtr PopTaggedStablePtr ( void )
1608 { StgInt r; PopTag(STABLE_TAG); r = *stgCast(StgStablePtr*, gSp);
1609 gSp += sizeofW(StgStablePtr); return r;}
1613 static inline StgInt taggedStackInt ( StgStackOffset i )
1614 { checkTag(INT_TAG,gSp[i]); return *stgCast(StgInt*, gSp+1+i); }
1615 static inline StgWord taggedStackWord ( StgStackOffset i )
1616 { checkTag(WORD_TAG,gSp[i]); return *stgCast(StgWord*, gSp+1+i); }
1617 static inline StgAddr taggedStackAddr ( StgStackOffset i )
1618 { checkTag(ADDR_TAG,gSp[i]); return *stgCast(StgAddr*, gSp+1+i); }
1619 static inline StgChar taggedStackChar ( StgStackOffset i )
1620 { checkTag(CHAR_TAG,gSp[i]); return stgCast(StgChar, *(gSp+1+i)) ; }
1621 static inline StgFloat taggedStackFloat ( StgStackOffset i )
1622 { checkTag(FLOAT_TAG,gSp[i]); return PK_FLT(gSp+1+i); }
1623 static inline StgDouble taggedStackDouble ( StgStackOffset i )
1624 { checkTag(DOUBLE_TAG,gSp[i]); return PK_DBL(gSp+1+i); }
1625 static inline StgStablePtr taggedStackStable ( StgStackOffset i )
1626 { checkTag(STABLE_TAG,gSp[i]); return *stgCast(StgStablePtr*, gSp+1+i); }
1629 /* --------------------------------------------------------------------------
1632 * Should we allocate from a nursery or use the
1633 * doYouWantToGC/allocate interface? We'd already implemented a
1634 * nursery-style scheme when the doYouWantToGC/allocate interface
1636 * One reason to prefer the doYouWantToGC/allocate interface is to
1637 * support operations which allocate an unknown amount in the heap
1638 * (array ops, gmp ops, etc)
1639 * ------------------------------------------------------------------------*/
1641 static inline StgPtr grabHpUpd( nat size )
1643 ASSERT( size >= MIN_UPD_SIZE + sizeofW(StgHeader) );
1644 #ifdef CRUDE_PROFILING
1645 cp_bill_words ( size );
1647 return allocate(size);
1650 static inline StgPtr grabHpNonUpd( nat size )
1652 ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
1653 #ifdef CRUDE_PROFILING
1654 cp_bill_words ( size );
1656 return allocate(size);
1659 /* --------------------------------------------------------------------------
1660 * Manipulate "update frame" list:
1661 * o Update frames (based on stg_do_update and friends in Updates.hc)
1662 * o Error handling/catching (based on catchzh_fast and friends in Prims.hc)
1663 * o Seq frames (based on seq_frame_entry in Prims.hc)
1665 * ------------------------------------------------------------------------*/
1667 static inline void PopUpdateFrame ( StgClosure* obj )
1669 /* NB: doesn't assume that gSp == gSu */
1671 fprintf(stderr, "Updating ");
1672 printPtr(stgCast(StgPtr,gSu->updatee));
1673 fprintf(stderr, " with ");
1675 fprintf(stderr,"gSp = %p\tgSu = %p\n\n", gSp, gSu);
1677 #ifdef EAGER_BLACKHOLING
1678 #warn LAZY_BLACKHOLING is default for StgHugs
1679 #error Dont know if EAGER_BLACKHOLING works in StgHugs
1680 ASSERT(get_itbl(gSu->updatee)->type == BLACKHOLE
1681 || get_itbl(gSu->updatee)->type == SE_BLACKHOLE
1682 || get_itbl(gSu->updatee)->type == CAF_BLACKHOLE
1683 || get_itbl(gSu->updatee)->type == SE_CAF_BLACKHOLE
1685 #endif /* EAGER_BLACKHOLING */
1686 UPD_IND(gSu->updatee,obj);
1687 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgUpdateFrame);
1691 static inline void PopStopFrame ( StgClosure* obj )
1693 /* Move gSu just off the end of the stack, we're about to gSpam the
1694 * STOP_FRAME with the return value.
1696 gSu = stgCast(StgUpdateFrame*,gSp+1);
1697 *stgCast(StgClosure**,gSp) = obj;
1700 static inline void PushCatchFrame ( StgClosure* handler )
1703 /* ToDo: stack check! */
1704 gSp -= sizeofW(StgCatchFrame);
1705 fp = stgCast(StgCatchFrame*,gSp);
1706 SET_HDR(fp,(StgInfoTable*)&catch_frame_info,CCCS);
1707 fp->handler = handler;
1709 gSu = stgCast(StgUpdateFrame*,fp);
1712 static inline void PopCatchFrame ( void )
1714 /* NB: doesn't assume that gSp == gSu */
1715 /* fprintf(stderr,"Popping catch frame\n"); */
1716 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgCatchFrame);
1717 gSu = stgCast(StgCatchFrame*,gSu)->link;
1720 static inline void PushSeqFrame ( void )
1723 /* ToDo: stack check! */
1724 gSp -= sizeofW(StgSeqFrame);
1725 fp = stgCast(StgSeqFrame*,gSp);
1726 SET_HDR(fp,(StgInfoTable*)&seq_frame_info,CCCS);
1728 gSu = stgCast(StgUpdateFrame*,fp);
1731 static inline void PopSeqFrame ( void )
1733 /* NB: doesn't assume that gSp == gSu */
1734 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgSeqFrame);
1735 gSu = stgCast(StgSeqFrame*,gSu)->link;
1738 static inline StgClosure* raiseAnError ( StgClosure* exception )
1740 /* This closure represents the expression 'primRaise E' where E
1741 * is the exception raised (:: Exception).
1742 * It is used to overwrite all the
1743 * thunks which are currently under evaluation.
1745 HaskellObj primRaiseClosure
1746 = asmClosureOfObject(getHugs_AsmObject_for("primRaise"));
1747 HaskellObj reraiseClosure
1748 = rts_apply ( primRaiseClosure, exception );
1751 switch (get_itbl(gSu)->type) {
1753 UPD_IND(gSu->updatee,reraiseClosure);
1754 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgUpdateFrame);
1760 case CATCH_FRAME: /* found it! */
1762 StgCatchFrame* fp = stgCast(StgCatchFrame*,gSu);
1763 StgClosure *handler = fp->handler;
1765 gSp += sizeofW(StgCatchFrame); /* Pop */
1766 PushCPtr(exception);
1770 barf("raiseError: uncaught exception: STOP_FRAME");
1772 barf("raiseError: weird activation record");
1778 static StgClosure* makeErrorCall ( const char* msg )
1780 /* Note! the msg string should be allocated in a
1781 place which will not get freed -- preferably
1782 read-only data of the program. That's because
1783 the thunk we build here may linger indefinitely.
1784 (thinks: probably not so, but anyway ...)
1787 = asmClosureOfObject(getHugs_AsmObject_for("error"));
1789 = asmClosureOfObject(getHugs_AsmObject_for("hugsprimUnpackString"));
1791 = rts_apply ( unpack, rts_mkAddr ( (void*)msg ) );
1793 = rts_apply ( error, thunk );
1795 (StgClosure*) thunk;
1798 #define raiseIndex(where) makeErrorCall("Array index out of range in " where)
1799 #define raiseDiv0(where) makeErrorCall("Division by zero in " where)
1801 /* --------------------------------------------------------------------------
1803 * ------------------------------------------------------------------------*/
1805 #define OP_CC_B(e) \
1807 unsigned char x = PopTaggedChar(); \
1808 unsigned char y = PopTaggedChar(); \
1809 PushTaggedBool(e); \
1814 unsigned char x = PopTaggedChar(); \
1823 #define OP_IW_I(e) \
1825 StgInt x = PopTaggedInt(); \
1826 StgWord y = PopTaggedWord(); \
1830 #define OP_II_I(e) \
1832 StgInt x = PopTaggedInt(); \
1833 StgInt y = PopTaggedInt(); \
1837 #define OP_II_B(e) \
1839 StgInt x = PopTaggedInt(); \
1840 StgInt y = PopTaggedInt(); \
1841 PushTaggedBool(e); \
1846 PushTaggedAddr(e); \
1851 StgInt x = PopTaggedInt(); \
1852 PushTaggedAddr(e); \
1857 StgInt x = PopTaggedInt(); \
1863 PushTaggedChar(e); \
1868 StgInt x = PopTaggedInt(); \
1869 PushTaggedChar(e); \
1874 PushTaggedWord(e); \
1879 StgInt x = PopTaggedInt(); \
1880 PushTaggedWord(e); \
1885 StgInt x = PopTaggedInt(); \
1886 PushTaggedStablePtr(e); \
1891 PushTaggedFloat(e); \
1896 StgInt x = PopTaggedInt(); \
1897 PushTaggedFloat(e); \
1902 PushTaggedDouble(e); \
1907 StgInt x = PopTaggedInt(); \
1908 PushTaggedDouble(e); \
1911 #define OP_WW_B(e) \
1913 StgWord x = PopTaggedWord(); \
1914 StgWord y = PopTaggedWord(); \
1915 PushTaggedBool(e); \
1918 #define OP_WW_W(e) \
1920 StgWord x = PopTaggedWord(); \
1921 StgWord y = PopTaggedWord(); \
1922 PushTaggedWord(e); \
1927 StgWord x = PopTaggedWord(); \
1933 StgStablePtr x = PopTaggedStablePtr(); \
1939 StgWord x = PopTaggedWord(); \
1940 PushTaggedWord(e); \
1943 #define OP_AA_B(e) \
1945 StgAddr x = PopTaggedAddr(); \
1946 StgAddr y = PopTaggedAddr(); \
1947 PushTaggedBool(e); \
1951 StgAddr x = PopTaggedAddr(); \
1954 #define OP_AI_C(s) \
1956 StgAddr x = PopTaggedAddr(); \
1957 int y = PopTaggedInt(); \
1960 PushTaggedChar(r); \
1962 #define OP_AI_I(s) \
1964 StgAddr x = PopTaggedAddr(); \
1965 int y = PopTaggedInt(); \
1970 #define OP_AI_A(s) \
1972 StgAddr x = PopTaggedAddr(); \
1973 int y = PopTaggedInt(); \
1976 PushTaggedAddr(s); \
1978 #define OP_AI_F(s) \
1980 StgAddr x = PopTaggedAddr(); \
1981 int y = PopTaggedInt(); \
1984 PushTaggedFloat(r); \
1986 #define OP_AI_D(s) \
1988 StgAddr x = PopTaggedAddr(); \
1989 int y = PopTaggedInt(); \
1992 PushTaggedDouble(r); \
1994 #define OP_AI_s(s) \
1996 StgAddr x = PopTaggedAddr(); \
1997 int y = PopTaggedInt(); \
2000 PushTaggedStablePtr(r); \
2002 #define OP_AIC_(s) \
2004 StgAddr x = PopTaggedAddr(); \
2005 int y = PopTaggedInt(); \
2006 StgChar z = PopTaggedChar(); \
2009 #define OP_AII_(s) \
2011 StgAddr x = PopTaggedAddr(); \
2012 int y = PopTaggedInt(); \
2013 StgInt z = PopTaggedInt(); \
2016 #define OP_AIA_(s) \
2018 StgAddr x = PopTaggedAddr(); \
2019 int y = PopTaggedInt(); \
2020 StgAddr z = PopTaggedAddr(); \
2023 #define OP_AIF_(s) \
2025 StgAddr x = PopTaggedAddr(); \
2026 int y = PopTaggedInt(); \
2027 StgFloat z = PopTaggedFloat(); \
2030 #define OP_AID_(s) \
2032 StgAddr x = PopTaggedAddr(); \
2033 int y = PopTaggedInt(); \
2034 StgDouble z = PopTaggedDouble(); \
2037 #define OP_AIs_(s) \
2039 StgAddr x = PopTaggedAddr(); \
2040 int y = PopTaggedInt(); \
2041 StgStablePtr z = PopTaggedStablePtr(); \
2046 #define OP_FF_B(e) \
2048 StgFloat x = PopTaggedFloat(); \
2049 StgFloat y = PopTaggedFloat(); \
2050 PushTaggedBool(e); \
2053 #define OP_FF_F(e) \
2055 StgFloat x = PopTaggedFloat(); \
2056 StgFloat y = PopTaggedFloat(); \
2057 PushTaggedFloat(e); \
2062 StgFloat x = PopTaggedFloat(); \
2063 PushTaggedFloat(e); \
2068 StgFloat x = PopTaggedFloat(); \
2069 PushTaggedBool(e); \
2074 StgFloat x = PopTaggedFloat(); \
2080 StgFloat x = PopTaggedFloat(); \
2081 PushTaggedDouble(e); \
2084 #define OP_DD_B(e) \
2086 StgDouble x = PopTaggedDouble(); \
2087 StgDouble y = PopTaggedDouble(); \
2088 PushTaggedBool(e); \
2091 #define OP_DD_D(e) \
2093 StgDouble x = PopTaggedDouble(); \
2094 StgDouble y = PopTaggedDouble(); \
2095 PushTaggedDouble(e); \
2100 StgDouble x = PopTaggedDouble(); \
2101 PushTaggedBool(e); \
2106 StgDouble x = PopTaggedDouble(); \
2107 PushTaggedDouble(e); \
2112 StgDouble x = PopTaggedDouble(); \
2118 StgDouble x = PopTaggedDouble(); \
2119 PushTaggedFloat(e); \
2123 StgPtr CreateByteArrayToHoldInteger ( int nbytes )
2125 StgWord words = (nbytes+sizeof(W_)-1)/sizeof(W_);
2126 StgWord size = sizeofW(StgArrWords) + words;
2127 StgArrWords* arr = (StgArrWords*)allocate(size);
2128 SET_HDR(arr,&ARR_WORDS_info,CCCS);
2130 ASSERT((W_)nbytes <= arr->words * sizeof(W_));
2133 for (i = 0; i < words; ++i) {
2134 arr->payload[i] = 0xdeadbeef;
2136 { B* b = (B*) &(arr->payload[0]);
2137 b->used = b->sign = 0;
2143 B* IntegerInsideByteArray ( StgPtr arr0 )
2146 StgArrWords* arr = (StgArrWords*)arr0;
2147 ASSERT(GET_INFO(arr) == &ARR_WORDS_info);
2148 b = (B*) &(arr->payload[0]);
2152 void SloppifyIntegerEnd ( StgPtr arr0 )
2154 StgArrWords* arr = (StgArrWords*)arr0;
2155 B* b = (B*) & (arr->payload[0]);
2156 I_ nwunused = arr->words - sizeofW(B) - (b->used+sizeof(W_)-1)/sizeof(W_);
2157 if (nwunused >= ((I_)sizeofW(StgArrWords))) {
2159 b->size -= nwunused * sizeof(W_);
2160 if (b->size < b->used) b->size = b->used;
2163 arr->words -= nwunused;
2164 slop = (StgArrWords*)&(arr->payload[arr->words]);
2165 SET_HDR(slop,&ARR_WORDS_info,CCCS);
2166 slop->words = nwunused - sizeofW(StgArrWords);
2167 ASSERT( &(slop->payload[slop->words]) ==
2168 &(arr->payload[arr->words + nwunused]) );
2172 #define OP_Z_Z(op) \
2174 B* x = IntegerInsideByteArray(PopPtr()); \
2175 int n = mycat2(size_,op)(x); \
2176 StgPtr p = CreateByteArrayToHoldInteger(n); \
2177 mycat2(do_,op)(x,n,IntegerInsideByteArray(p)); \
2178 SloppifyIntegerEnd(p); \
2181 #define OP_ZZ_Z(op) \
2183 B* x = IntegerInsideByteArray(PopPtr()); \
2184 B* y = IntegerInsideByteArray(PopPtr()); \
2185 int n = mycat2(size_,op)(x,y); \
2186 StgPtr p = CreateByteArrayToHoldInteger(n); \
2187 mycat2(do_,op)(x,y,n,IntegerInsideByteArray(p)); \
2188 SloppifyIntegerEnd(p); \
2195 #define HEADER_mI(ty,where) \
2196 StgArrWords* x = stgCast(StgArrWords*,PopPtr()); \
2197 nat i = PopTaggedInt(); \
2198 if (i * sizeof(ty) + (sizeof(ty)) > sizeof(StgWord) * x->words) { \
2199 return (raiseIndex(where)); \
2201 #define OP_mI_ty(ty,where,s) \
2203 HEADER_mI(mycat2(Stg,ty),where) \
2204 { mycat2(Stg,ty) r; \
2206 mycat2(PushTagged,ty)(r); \
2209 #define OP_mIty_(ty,where,s) \
2211 HEADER_mI(mycat2(Stg,ty),where) \
2213 mycat2(Stg,ty) z = mycat2(PopTagged,ty)(); \
2219 static void myStackCheck ( Capability* cap )
2221 /* fprintf(stderr, "myStackCheck\n"); */
2222 if (!(gSpLim <= gSp && gSp <= stgCast(StgPtr,gSu))) {
2223 fprintf(stderr, "myStackCheck: invalid initial gSp/gSu \n" );
2227 if (!( (P_)gSu >= (P_)cap->rCurrentTSO->stack
2229 (P_)gSu <= (P_)(cap->rCurrentTSO->stack
2230 + cap->rCurrentTSO->stack_size))) {
2231 fprintf ( stderr, "myStackCheck: gSu out of stack\n" );
2234 switch (get_itbl(stgCast(StgClosure*,gSu))->type) {
2236 gSu = (StgUpdateFrame*) ((StgCatchFrame*)(gSu))->link;
2239 gSu = (StgUpdateFrame*) ((StgUpdateFrame*)(gSu))->link;
2242 gSu = (StgUpdateFrame*) ((StgSeqFrame*)(gSu))->link;
2247 fprintf(stderr, "myStackCheck: invalid activation record\n"); assert(0);
2254 /* --------------------------------------------------------------------------
2255 * Primop stuff for bytecode interpreter
2256 * ------------------------------------------------------------------------*/
2258 /* Returns & of the next thing to enter (if throwing an exception),
2259 or NULL in the normal case.
2261 static void* enterBCO_primop1 ( int primop1code )
2264 barf("enterBCO_primop1 in combined mode");
2266 switch (primop1code) {
2267 case i_pushseqframe:
2269 StgClosure* c = PopCPtr();
2274 case i_pushcatchframe:
2276 StgClosure* e = PopCPtr();
2277 StgClosure* h = PopCPtr();
2283 case i_gtChar: OP_CC_B(x>y); break;
2284 case i_geChar: OP_CC_B(x>=y); break;
2285 case i_eqChar: OP_CC_B(x==y); break;
2286 case i_neChar: OP_CC_B(x!=y); break;
2287 case i_ltChar: OP_CC_B(x<y); break;
2288 case i_leChar: OP_CC_B(x<=y); break;
2289 case i_charToInt: OP_C_I(x); break;
2290 case i_intToChar: OP_I_C(x); break;
2292 case i_gtInt: OP_II_B(x>y); break;
2293 case i_geInt: OP_II_B(x>=y); break;
2294 case i_eqInt: OP_II_B(x==y); break;
2295 case i_neInt: OP_II_B(x!=y); break;
2296 case i_ltInt: OP_II_B(x<y); break;
2297 case i_leInt: OP_II_B(x<=y); break;
2298 case i_minInt: OP__I(INT_MIN); break;
2299 case i_maxInt: OP__I(INT_MAX); break;
2300 case i_plusInt: OP_II_I(x+y); break;
2301 case i_minusInt: OP_II_I(x-y); break;
2302 case i_timesInt: OP_II_I(x*y); break;
2305 int x = PopTaggedInt();
2306 int y = PopTaggedInt();
2308 return (raiseDiv0("quotInt"));
2310 /* ToDo: protect against minInt / -1 errors
2311 * (repeat for all other division primops) */
2317 int x = PopTaggedInt();
2318 int y = PopTaggedInt();
2320 return (raiseDiv0("remInt"));
2327 StgInt x = PopTaggedInt();
2328 StgInt y = PopTaggedInt();
2330 return (raiseDiv0("quotRemInt"));
2332 PushTaggedInt(x%y); /* last result */
2333 PushTaggedInt(x/y); /* first result */
2336 case i_negateInt: OP_I_I(-x); break;
2338 case i_andInt: OP_II_I(x&y); break;
2339 case i_orInt: OP_II_I(x|y); break;
2340 case i_xorInt: OP_II_I(x^y); break;
2341 case i_notInt: OP_I_I(~x); break;
2342 case i_shiftLInt: OP_II_I(x<<y); break;
2343 case i_shiftRAInt: OP_II_I(x>>y); break; /* ToDo */
2344 case i_shiftRLInt: OP_II_I(x>>y); break; /* ToDo */
2346 case i_gtWord: OP_WW_B(x>y); break;
2347 case i_geWord: OP_WW_B(x>=y); break;
2348 case i_eqWord: OP_WW_B(x==y); break;
2349 case i_neWord: OP_WW_B(x!=y); break;
2350 case i_ltWord: OP_WW_B(x<y); break;
2351 case i_leWord: OP_WW_B(x<=y); break;
2352 case i_minWord: OP__W(0); break;
2353 case i_maxWord: OP__W(UINT_MAX); break;
2354 case i_plusWord: OP_WW_W(x+y); break;
2355 case i_minusWord: OP_WW_W(x-y); break;
2356 case i_timesWord: OP_WW_W(x*y); break;
2359 StgWord x = PopTaggedWord();
2360 StgWord y = PopTaggedWord();
2362 return (raiseDiv0("quotWord"));
2364 PushTaggedWord(x/y);
2369 StgWord x = PopTaggedWord();
2370 StgWord y = PopTaggedWord();
2372 return (raiseDiv0("remWord"));
2374 PushTaggedWord(x%y);
2379 StgWord x = PopTaggedWord();
2380 StgWord y = PopTaggedWord();
2382 return (raiseDiv0("quotRemWord"));
2384 PushTaggedWord(x%y); /* last result */
2385 PushTaggedWord(x/y); /* first result */
2388 case i_negateWord: OP_W_W(-x); break;
2389 case i_andWord: OP_WW_W(x&y); break;
2390 case i_orWord: OP_WW_W(x|y); break;
2391 case i_xorWord: OP_WW_W(x^y); break;
2392 case i_notWord: OP_W_W(~x); break;
2393 case i_shiftLWord: OP_WW_W(x<<y); break;
2394 case i_shiftRAWord: OP_WW_W(x>>y); break; /* ToDo */
2395 case i_shiftRLWord: OP_WW_W(x>>y); break; /* ToDo */
2396 case i_intToWord: OP_I_W(x); break;
2397 case i_wordToInt: OP_W_I(x); break;
2399 case i_gtAddr: OP_AA_B(x>y); break;
2400 case i_geAddr: OP_AA_B(x>=y); break;
2401 case i_eqAddr: OP_AA_B(x==y); break;
2402 case i_neAddr: OP_AA_B(x!=y); break;
2403 case i_ltAddr: OP_AA_B(x<y); break;
2404 case i_leAddr: OP_AA_B(x<=y); break;
2405 case i_intToAddr: OP_I_A((StgAddr)x); break; /* ToDo */
2406 case i_addrToInt: OP_A_I((StgInt)x); break; /* ToDo */
2408 case i_intToStable: OP_I_s(x); break;
2409 case i_stableToInt: OP_s_I(x); break;
2411 case i_indexCharOffAddr: OP_AI_C(indexCharOffAddrzh(r,x,y)); break;
2412 case i_readCharOffAddr: OP_AI_C(indexCharOffAddrzh(r,x,y)); break;
2413 case i_writeCharOffAddr: OP_AIC_(writeCharOffAddrzh(x,y,z)); break;
2415 case i_indexIntOffAddr: OP_AI_I(indexIntOffAddrzh(r,x,y)); break;
2416 case i_readIntOffAddr: OP_AI_I(indexIntOffAddrzh(r,x,y)); break;
2417 case i_writeIntOffAddr: OP_AII_(writeIntOffAddrzh(x,y,z)); break;
2419 case i_indexAddrOffAddr: OP_AI_A(indexAddrOffAddrzh(r,x,y)); break;
2420 case i_readAddrOffAddr: OP_AI_A(indexAddrOffAddrzh(r,x,y)); break;
2421 case i_writeAddrOffAddr: OP_AIA_(writeAddrOffAddrzh(x,y,z)); break;
2423 case i_indexFloatOffAddr: OP_AI_F(indexFloatOffAddrzh(r,x,y)); break;
2424 case i_readFloatOffAddr: OP_AI_F(indexFloatOffAddrzh(r,x,y)); break;
2425 case i_writeFloatOffAddr: OP_AIF_(writeFloatOffAddrzh(x,y,z)); break;
2427 case i_indexDoubleOffAddr: OP_AI_D(indexDoubleOffAddrzh(r,x,y)); break;
2428 case i_readDoubleOffAddr: OP_AI_D(indexDoubleOffAddrzh(r,x,y)); break;
2429 case i_writeDoubleOffAddr: OP_AID_(writeDoubleOffAddrzh(x,y,z)); break;
2431 case i_indexStableOffAddr: OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break;
2432 case i_readStableOffAddr: OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break;
2433 case i_writeStableOffAddr: OP_AIs_(writeStablePtrOffAddrzh(x,y,z)); break;
2435 case i_compareInteger:
2437 B* x = IntegerInsideByteArray(PopPtr());
2438 B* y = IntegerInsideByteArray(PopPtr());
2439 StgInt r = do_cmp(x,y);
2440 PushTaggedInt(r<0 ? -1 : (r>0 ? 1 : 0));
2443 case i_negateInteger: OP_Z_Z(neg); break;
2444 case i_plusInteger: OP_ZZ_Z(add); break;
2445 case i_minusInteger: OP_ZZ_Z(sub); break;
2446 case i_timesInteger: OP_ZZ_Z(mul); break;
2447 case i_quotRemInteger:
2449 B* x = IntegerInsideByteArray(PopPtr());
2450 B* y = IntegerInsideByteArray(PopPtr());
2451 int n = size_qrm(x,y);
2452 StgPtr q = CreateByteArrayToHoldInteger(n);
2453 StgPtr r = CreateByteArrayToHoldInteger(n);
2454 if (do_getsign(y)==0)
2455 return (raiseDiv0("quotRemInteger"));
2456 do_qrm(x,y,n,IntegerInsideByteArray(q),
2457 IntegerInsideByteArray(r));
2458 SloppifyIntegerEnd(q);
2459 SloppifyIntegerEnd(r);
2464 case i_intToInteger:
2466 int n = size_fromInt();
2467 StgPtr p = CreateByteArrayToHoldInteger(n);
2468 do_fromInt( PopTaggedInt(), n, IntegerInsideByteArray(p));
2472 case i_wordToInteger:
2474 int n = size_fromWord();
2475 StgPtr p = CreateByteArrayToHoldInteger(n);
2476 do_fromWord( PopTaggedWord(), n, IntegerInsideByteArray(p));
2480 case i_integerToInt: PushTaggedInt(do_toInt(
2481 IntegerInsideByteArray(PopPtr())
2485 case i_integerToWord: PushTaggedWord(do_toWord(
2486 IntegerInsideByteArray(PopPtr())
2490 case i_integerToFloat: PushTaggedFloat(do_toFloat(
2491 IntegerInsideByteArray(PopPtr())
2495 case i_integerToDouble: PushTaggedDouble(do_toDouble(
2496 IntegerInsideByteArray(PopPtr())
2500 case i_gtFloat: OP_FF_B(x>y); break;
2501 case i_geFloat: OP_FF_B(x>=y); break;
2502 case i_eqFloat: OP_FF_B(x==y); break;
2503 case i_neFloat: OP_FF_B(x!=y); break;
2504 case i_ltFloat: OP_FF_B(x<y); break;
2505 case i_leFloat: OP_FF_B(x<=y); break;
2506 case i_minFloat: OP__F(FLT_MIN); break;
2507 case i_maxFloat: OP__F(FLT_MAX); break;
2508 case i_radixFloat: OP__I(FLT_RADIX); break;
2509 case i_digitsFloat: OP__I(FLT_MANT_DIG); break;
2510 case i_minExpFloat: OP__I(FLT_MIN_EXP); break;
2511 case i_maxExpFloat: OP__I(FLT_MAX_EXP); break;
2512 case i_plusFloat: OP_FF_F(x+y); break;
2513 case i_minusFloat: OP_FF_F(x-y); break;
2514 case i_timesFloat: OP_FF_F(x*y); break;
2517 StgFloat x = PopTaggedFloat();
2518 StgFloat y = PopTaggedFloat();
2519 PushTaggedFloat(x/y);
2522 case i_negateFloat: OP_F_F(-x); break;
2523 case i_floatToInt: OP_F_I(x); break;
2524 case i_intToFloat: OP_I_F(x); break;
2525 case i_expFloat: OP_F_F(exp(x)); break;
2526 case i_logFloat: OP_F_F(log(x)); break;
2527 case i_sqrtFloat: OP_F_F(sqrt(x)); break;
2528 case i_sinFloat: OP_F_F(sin(x)); break;
2529 case i_cosFloat: OP_F_F(cos(x)); break;
2530 case i_tanFloat: OP_F_F(tan(x)); break;
2531 case i_asinFloat: OP_F_F(asin(x)); break;
2532 case i_acosFloat: OP_F_F(acos(x)); break;
2533 case i_atanFloat: OP_F_F(atan(x)); break;
2534 case i_sinhFloat: OP_F_F(sinh(x)); break;
2535 case i_coshFloat: OP_F_F(cosh(x)); break;
2536 case i_tanhFloat: OP_F_F(tanh(x)); break;
2537 case i_powerFloat: OP_FF_F(pow(x,y)); break;
2539 case i_encodeFloatZ:
2541 StgPtr sig = PopPtr();
2542 StgInt exp = PopTaggedInt();
2544 B__encodeFloat(IntegerInsideByteArray(sig), exp)
2548 case i_decodeFloatZ:
2550 StgFloat f = PopTaggedFloat();
2551 StgPtr sig = CreateByteArrayToHoldInteger(size_fltmantissa());
2553 B__decodeFloat(IntegerInsideByteArray(sig), &exp, f);
2559 case i_isNaNFloat: OP_F_B(isFloatNaN(x)); break;
2560 case i_isInfiniteFloat: OP_F_B(isFloatInfinite(x)); break;
2561 case i_isNegativeZeroFloat: OP_F_B(isFloatNegativeZero(x)); break;
2562 case i_isDenormalizedFloat: OP_F_B(isFloatDenormalized(x)); break;
2563 case i_gtDouble: OP_DD_B(x>y); break;
2564 case i_geDouble: OP_DD_B(x>=y); break;
2565 case i_eqDouble: OP_DD_B(x==y); break;
2566 case i_neDouble: OP_DD_B(x!=y); break;
2567 case i_ltDouble: OP_DD_B(x<y); break;
2568 case i_leDouble: OP_DD_B(x<=y) break;
2569 case i_minDouble: OP__D(DBL_MIN); break;
2570 case i_maxDouble: OP__D(DBL_MAX); break;
2571 case i_radixDouble: OP__I(FLT_RADIX); break;
2572 case i_digitsDouble: OP__I(DBL_MANT_DIG); break;
2573 case i_minExpDouble: OP__I(DBL_MIN_EXP); break;
2574 case i_maxExpDouble: OP__I(DBL_MAX_EXP); break;
2575 case i_plusDouble: OP_DD_D(x+y); break;
2576 case i_minusDouble: OP_DD_D(x-y); break;
2577 case i_timesDouble: OP_DD_D(x*y); break;
2578 case i_divideDouble:
2580 StgDouble x = PopTaggedDouble();
2581 StgDouble y = PopTaggedDouble();
2582 PushTaggedDouble(x/y);
2585 case i_negateDouble: OP_D_D(-x); break;
2586 case i_doubleToInt: OP_D_I(x); break;
2587 case i_intToDouble: OP_I_D(x); break;
2588 case i_doubleToFloat: OP_D_F(x); break;
2589 case i_floatToDouble: OP_F_F(x); break;
2590 case i_expDouble: OP_D_D(exp(x)); break;
2591 case i_logDouble: OP_D_D(log(x)); break;
2592 case i_sqrtDouble: OP_D_D(sqrt(x)); break;
2593 case i_sinDouble: OP_D_D(sin(x)); break;
2594 case i_cosDouble: OP_D_D(cos(x)); break;
2595 case i_tanDouble: OP_D_D(tan(x)); break;
2596 case i_asinDouble: OP_D_D(asin(x)); break;
2597 case i_acosDouble: OP_D_D(acos(x)); break;
2598 case i_atanDouble: OP_D_D(atan(x)); break;
2599 case i_sinhDouble: OP_D_D(sinh(x)); break;
2600 case i_coshDouble: OP_D_D(cosh(x)); break;
2601 case i_tanhDouble: OP_D_D(tanh(x)); break;
2602 case i_powerDouble: OP_DD_D(pow(x,y)); break;
2604 case i_encodeDoubleZ:
2606 StgPtr sig = PopPtr();
2607 StgInt exp = PopTaggedInt();
2609 B__encodeDouble(IntegerInsideByteArray(sig), exp)
2613 case i_decodeDoubleZ:
2615 StgDouble d = PopTaggedDouble();
2616 StgPtr sig = CreateByteArrayToHoldInteger(size_dblmantissa());
2618 B__decodeDouble(IntegerInsideByteArray(sig), &exp, d);
2624 case i_isNaNDouble: OP_D_B(isDoubleNaN(x)); break;
2625 case i_isInfiniteDouble: OP_D_B(isDoubleInfinite(x)); break;
2626 case i_isNegativeZeroDouble: OP_D_B(isDoubleNegativeZero(x)); break;
2627 case i_isDenormalizedDouble: OP_D_B(isDoubleDenormalized(x)); break;
2628 case i_isIEEEDouble:
2630 PushTaggedBool(rtsTrue);
2634 barf("Unrecognised primop1");
2641 /* For normal cases, return NULL and leave *return2 unchanged.
2642 To return the address of the next thing to enter,
2643 return the address of it and leave *return2 unchanged.
2644 To return a StgThreadReturnCode to the scheduler,
2645 set *return2 to it and return a non-NULL value.
2647 static void* enterBCO_primop2 ( int primop2code,
2648 int* /*StgThreadReturnCode* */ return2,
2653 /* A small concession: we need to allow ccalls,
2654 even in combined mode.
2656 if (primop2code != i_ccall_ccall_IO &&
2657 primop2code != i_ccall_stdcall_IO)
2658 barf("enterBCO_primop2 in combined mode");
2661 switch (primop2code) {
2662 case i_raise: /* raise#{err} */
2664 StgClosure* err = PopCPtr();
2665 return (raiseAnError(err));
2670 StgClosure* init = PopCPtr();
2672 = stgCast(StgMutVar*,allocate(sizeofW(StgMutVar)));
2673 SET_HDR(mv,&MUT_VAR_info,CCCS);
2675 PushPtr(stgCast(StgPtr,mv));
2680 StgMutVar* mv = stgCast(StgMutVar*,PopPtr());
2686 StgMutVar* mv = stgCast(StgMutVar*,PopPtr());
2687 StgClosure* value = PopCPtr();
2693 nat n = PopTaggedInt(); /* or Word?? */
2694 StgClosure* init = PopCPtr();
2695 StgWord size = sizeofW(StgMutArrPtrs) + n;
2698 = stgCast(StgMutArrPtrs*,allocate(size));
2699 SET_HDR(arr,&MUT_ARR_PTRS_info,CCCS);
2701 for (i = 0; i < n; ++i) {
2702 arr->payload[i] = init;
2704 PushPtr(stgCast(StgPtr,arr));
2710 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2711 nat i = PopTaggedInt(); /* or Word?? */
2712 StgWord n = arr->ptrs;
2714 return (raiseIndex("{index,read}Array"));
2716 PushCPtr(arr->payload[i]);
2721 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2722 nat i = PopTaggedInt(); /* or Word? */
2723 StgClosure* v = PopCPtr();
2724 StgWord n = arr->ptrs;
2726 return (raiseIndex("{index,read}Array"));
2728 arr->payload[i] = v;
2732 case i_sizeMutableArray:
2734 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2735 PushTaggedInt(arr->ptrs);
2738 case i_unsafeFreezeArray:
2740 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2741 SET_INFO(arr,&MUT_ARR_PTRS_FROZEN_info);
2742 PushPtr(stgCast(StgPtr,arr));
2745 case i_unsafeFreezeByteArray:
2747 /* Delightfully simple :-) */
2751 case i_sameMutableArray:
2752 case i_sameMutableByteArray:
2754 StgPtr x = PopPtr();
2755 StgPtr y = PopPtr();
2756 PushTaggedBool(x==y);
2760 case i_newByteArray:
2762 nat n = PopTaggedInt(); /* or Word?? */
2763 StgInt words = (n+sizeof(W_)-1)/sizeof(W_);
2764 StgWord size = sizeofW(StgArrWords) + words;
2765 StgArrWords* arr = stgCast(StgArrWords*,allocate(size));
2766 SET_HDR(arr,&ARR_WORDS_info,CCCS);
2770 for (i = 0; i < n; ++i) {
2771 arr->payload[i] = 0xdeadbeef;
2774 PushPtr(stgCast(StgPtr,arr));
2778 /* Most of these generate alignment warnings on Sparcs and similar architectures.
2779 * These are harmless and are caused by the cast to C* in BYTE_ARR_CTS.
2781 case i_indexCharArray:
2782 OP_mI_ty(Char,"indexCharArray", indexCharArrayzh(r,x,i)); break;
2783 case i_readCharArray:
2784 OP_mI_ty(Char,"readCharArray", readCharArrayzh(r,x,i)); break;
2785 case i_writeCharArray:
2786 OP_mIty_(Char,"writeCharArray", writeCharArrayzh(x,i,z)); break;
2788 case i_indexIntArray:
2789 OP_mI_ty(Int,"indexIntArray", indexIntArrayzh(r,x,i)); break;
2790 case i_readIntArray:
2791 OP_mI_ty(Int,"readIntArray", readIntArrayzh(r,x,i)); break;
2792 case i_writeIntArray:
2793 OP_mIty_(Int,"writeIntArray", writeIntArrayzh(x,i,z)); break;
2795 case i_indexAddrArray:
2796 OP_mI_ty(Addr,"indexAddrArray", indexAddrArrayzh(r,x,i)); break;
2797 case i_readAddrArray:
2798 OP_mI_ty(Addr,"readAddrArray", readAddrArrayzh(r,x,i)); break;
2799 case i_writeAddrArray:
2800 OP_mIty_(Addr,"writeAddrArray", writeAddrArrayzh(x,i,z)); break;
2802 case i_indexFloatArray:
2803 OP_mI_ty(Float,"indexFloatArray", indexFloatArrayzh(r,x,i)); break;
2804 case i_readFloatArray:
2805 OP_mI_ty(Float,"readFloatArray", readFloatArrayzh(r,x,i)); break;
2806 case i_writeFloatArray:
2807 OP_mIty_(Float,"writeFloatArray", writeFloatArrayzh(x,i,z)); break;
2809 case i_indexDoubleArray:
2810 OP_mI_ty(Double,"indexDoubleArray", indexDoubleArrayzh(r,x,i)); break;
2811 case i_readDoubleArray:
2812 OP_mI_ty(Double,"readDoubleArray", readDoubleArrayzh(r,x,i)); break;
2813 case i_writeDoubleArray:
2814 OP_mIty_(Double,"writeDoubleArray", writeDoubleArrayzh(x,i,z)); break;
2817 #ifdef PROVIDE_STABLE
2818 case i_indexStableArray:
2819 OP_mI_ty(StablePtr,"indexStableArray", indexStablePtrArrayzh(r,x,i)); break;
2820 case i_readStableArray:
2821 OP_mI_ty(StablePtr,"readStableArray", readStablePtrArrayzh(r,x,i)); break;
2822 case i_writeStableArray:
2823 OP_mIty_(StablePtr,"writeStableArray", writeStablePtrArrayzh(x,i,z)); break;
2829 #ifdef PROVIDE_COERCE
2830 case i_unsafeCoerce:
2832 /* Another nullop */
2836 #ifdef PROVIDE_PTREQUALITY
2837 case i_reallyUnsafePtrEquality:
2838 { /* identical to i_sameRef */
2839 StgPtr x = PopPtr();
2840 StgPtr y = PopPtr();
2841 PushTaggedBool(x==y);
2845 #ifdef PROVIDE_FOREIGN
2846 /* ForeignObj# operations */
2847 case i_makeForeignObj:
2849 StgForeignObj *result
2850 = stgCast(StgForeignObj*,allocate(sizeofW(StgForeignObj)));
2851 SET_HDR(result,&FOREIGN_info,CCCS);
2852 result -> data = PopTaggedAddr();
2853 PushPtr(stgCast(StgPtr,result));
2856 #endif /* PROVIDE_FOREIGN */
2861 = stgCast(StgWeak*,allocate(sizeofW(StgWeak)));
2862 SET_HDR(w, &WEAK_info, CCCS);
2864 w->value = PopCPtr();
2865 w->finaliser = PopCPtr();
2866 w->link = weak_ptr_list;
2868 IF_DEBUG(weak, fprintf(stderr,"New weak pointer at %p\n",w));
2869 PushPtr(stgCast(StgPtr,w));
2874 StgWeak *w = stgCast(StgWeak*,PopPtr());
2875 if (w->header.info == &WEAK_info) {
2876 PushCPtr(w->value); /* last result */
2877 PushTaggedInt(1); /* first result */
2879 PushPtr(stgCast(StgPtr,w));
2880 /* ToDo: error thunk would be better */
2885 #endif /* PROVIDE_WEAK */
2887 case i_makeStablePtr:
2889 StgPtr p = PopPtr();
2890 StgStablePtr sp = getStablePtr ( p );
2891 PushTaggedStablePtr(sp);
2894 case i_deRefStablePtr:
2897 StgStablePtr sp = PopTaggedStablePtr();
2898 p = deRefStablePtr(sp);
2902 case i_freeStablePtr:
2904 StgStablePtr sp = PopTaggedStablePtr();
2909 case i_createAdjThunkARCH:
2911 StgStablePtr stableptr = PopTaggedStablePtr();
2912 StgAddr typestr = PopTaggedAddr();
2913 StgChar callconv = PopTaggedChar();
2914 StgAddr adj_thunk = createAdjThunk(stableptr,typestr,callconv);
2915 PushTaggedAddr(adj_thunk);
2921 StgInt n = prog_argc;
2927 StgInt n = PopTaggedInt();
2928 StgAddr a = (StgAddr)prog_argv[n];
2935 StgMVar *mvar = stgCast(StgMVar*,allocate(sizeofW(StgMVar)));
2936 SET_INFO(mvar,&EMPTY_MVAR_info);
2937 mvar->head = mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
2938 mvar->value = stgCast(StgClosure*,&END_TSO_QUEUE_closure);
2939 PushPtr(stgCast(StgPtr,mvar));
2944 StgMVar *mvar = (StgMVar*)PopCPtr();
2945 if (GET_INFO(mvar) == &EMPTY_MVAR_info) {
2947 /* The MVar is empty. Attach ourselves to the TSO's
2950 if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
2951 mvar->head = cap->rCurrentTSO;
2953 mvar->tail->link = cap->rCurrentTSO;
2955 cap->rCurrentTSO->link = (StgTSO *)&END_TSO_QUEUE_closure;
2956 cap->rCurrentTSO->why_blocked = BlockedOnMVar;
2957 cap->rCurrentTSO->block_info.closure = (StgClosure *)mvar;
2958 mvar->tail = cap->rCurrentTSO;
2960 /* At this point, the top-of-stack holds the MVar,
2961 and underneath is the world token (). So the
2962 stack is in the same state as when primTakeMVar
2963 was entered (primTakeMVar is handwritten bytecode).
2964 Push obj, which is this BCO, and return to the
2965 scheduler. When the MVar is filled, the scheduler
2966 will re-enter primTakeMVar, with the args still on
2967 the top of the stack.
2969 PushCPtr((StgClosure*)(*bco));
2970 *return2 = ThreadBlocked;
2971 return (void*)(1+(char*)(NULL));
2974 PushCPtr(mvar->value);
2975 mvar->value = (StgClosure *)&END_TSO_QUEUE_closure;
2976 SET_INFO(mvar,&EMPTY_MVAR_info);
2982 StgMVar* mvar = stgCast(StgMVar*,PopPtr());
2983 StgClosure* value = PopCPtr();
2984 if (GET_INFO(mvar) == &FULL_MVAR_info) {
2985 return (makeErrorCall("putMVar {full MVar}"));
2987 /* wake up the first thread on the
2988 * queue, it will continue with the
2989 * takeMVar operation and mark the
2992 mvar->value = value;
2994 if (mvar->head != (StgTSO *)&END_TSO_QUEUE_closure) {
2995 ASSERT(mvar->head->why_blocked == BlockedOnMVar);
2996 mvar->head = unblockOne(mvar->head);
2997 if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
2998 mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
3002 /* unlocks the MVar in the SMP case */
3003 SET_INFO(mvar,&FULL_MVAR_info);
3005 /* yield for better communication performance */
3011 { /* identical to i_sameRef */
3012 StgMVar* x = (StgMVar*)PopPtr();
3013 StgMVar* y = (StgMVar*)PopPtr();
3014 PushTaggedBool(x==y);
3019 StgWord tid = cap->rCurrentTSO->id;
3020 PushTaggedWord(tid);
3023 case i_cmpThreadIds:
3025 StgWord tid1 = PopTaggedWord();
3026 StgWord tid2 = PopTaggedWord();
3027 if (tid1 < tid2) PushTaggedInt(-1);
3028 else if (tid1 > tid2) PushTaggedInt(1);
3029 else PushTaggedInt(0);
3034 StgClosure* closure;
3037 closure = PopCPtr();
3038 tso = createGenThread (RtsFlags.GcFlags.initialStkSize,closure);
3040 scheduleThread(tso);
3042 PushTaggedWord(tid);
3046 #ifdef PROVIDE_CONCURRENT
3049 StgTSO* tso = stgCast(StgTSO*,PopPtr());
3051 if (tso == cap->rCurrentTSO) { /* suicide */
3052 *return2 = ThreadFinished;
3053 return (void*)(1+(NULL));
3061 /* As PrimOps.h says: Hmm, I'll think about these later. */
3064 #endif /* PROVIDE_CONCURRENT */
3066 case i_ccall_ccall_Id:
3067 case i_ccall_ccall_IO:
3068 case i_ccall_stdcall_Id:
3069 case i_ccall_stdcall_IO:
3072 CFunDescriptor* descriptor;
3073 void (*funPtr)(void);
3075 descriptor = PopTaggedAddr();
3076 funPtr = PopTaggedAddr();
3077 cc = (primop2code == i_ccall_stdcall_Id ||
3078 primop2code == i_ccall_stdcall_IO)
3080 r = ccall(descriptor,funPtr,bco,cc,cap);
3083 return makeErrorCall(
3084 "unhandled type or too many args/results in ccall");
3086 barf("ccall not configured correctly for this platform");
3087 barf("unknown return code from ccall");
3090 barf("Unrecognised primop2");
3096 /* -----------------------------------------------------------------------------
3097 * ccall support code:
3098 * marshall moves args from C stack to Haskell stack
3099 * unmarshall moves args from Haskell stack to C stack
3100 * argSize calculates how much gSpace you need on the C stack
3101 * ---------------------------------------------------------------------------*/
3103 /* Pop arguments off the C stack and Push them onto the Hugs stack.
3104 * Used when preparing for C calling Haskell or in regSponse to
3105 * Haskell calling C.
3107 nat marshall(char arg_ty, void* arg)
3111 PushTaggedInt(*((int*)arg));
3112 return ARG_SIZE(INT_TAG);
3115 PushTaggedInteger(*((mpz_ptr*)arg));
3116 return ARG_SIZE(INTEGER_TAG);
3119 PushTaggedWord(*((unsigned int*)arg));
3120 return ARG_SIZE(WORD_TAG);
3122 PushTaggedChar(*((char*)arg));
3123 return ARG_SIZE(CHAR_TAG);
3125 PushTaggedFloat(*((float*)arg));
3126 return ARG_SIZE(FLOAT_TAG);
3128 PushTaggedDouble(*((double*)arg));
3129 return ARG_SIZE(DOUBLE_TAG);
3131 PushTaggedAddr(*((void**)arg));
3132 return ARG_SIZE(ADDR_TAG);
3134 PushTaggedStablePtr(*((StgStablePtr*)arg));
3135 return ARG_SIZE(STABLE_TAG);
3136 #ifdef PROVIDE_FOREIGN
3138 /* Not allowed in this direction - you have to
3139 * call makeForeignPtr explicitly
3141 barf("marshall: ForeignPtr#\n");
3146 /* Not allowed in this direction */
3147 barf("marshall: [Mutable]ByteArray#\n");
3150 barf("marshall: unrecognised arg type %d\n",arg_ty);
3155 /* Pop arguments off the Hugs stack and Push them onto the C stack.
3156 * Used when preparing for Haskell calling C or in regSponse to
3157 * C calling Haskell.
3159 nat unmarshall(char res_ty, void* res)
3163 *((int*)res) = PopTaggedInt();
3164 return ARG_SIZE(INT_TAG);
3167 *((mpz_ptr*)res) = PopTaggedInteger();
3168 return ARG_SIZE(INTEGER_TAG);
3171 *((unsigned int*)res) = PopTaggedWord();
3172 return ARG_SIZE(WORD_TAG);
3174 *((int*)res) = PopTaggedChar();
3175 return ARG_SIZE(CHAR_TAG);
3177 *((float*)res) = PopTaggedFloat();
3178 return ARG_SIZE(FLOAT_TAG);
3180 *((double*)res) = PopTaggedDouble();
3181 return ARG_SIZE(DOUBLE_TAG);
3183 *((void**)res) = PopTaggedAddr();
3184 return ARG_SIZE(ADDR_TAG);
3186 *((StgStablePtr*)res) = PopTaggedStablePtr();
3187 return ARG_SIZE(STABLE_TAG);
3188 #ifdef PROVIDE_FOREIGN
3191 StgForeignObj *result = stgCast(StgForeignObj*,PopPtr());
3192 *((void**)res) = result->data;
3193 return sizeofW(StgPtr);
3199 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
3200 *((void**)res) = stgCast(void*,&(arr->payload));
3201 return sizeofW(StgPtr);
3204 barf("unmarshall: unrecognised result type %d\n",res_ty);
3208 nat argSize( const char* ks )
3211 for( ; *ks != '\0'; ++ks) {
3214 sz += sizeof(StgWord) * ARG_SIZE(INT_TAG);
3218 sz += sizeof(StgWord) * ARG_SIZE(INTEGER_TAG);
3222 sz += sizeof(StgWord) * ARG_SIZE(WORD_TAG);
3225 sz += sizeof(StgWord) * ARG_SIZE(CHAR_TAG);
3228 sz += sizeof(StgWord) * ARG_SIZE(FLOAT_TAG);
3231 sz += sizeof(StgWord) * ARG_SIZE(DOUBLE_TAG);
3234 sz += sizeof(StgWord) * ARG_SIZE(ADDR_TAG);
3237 sz += sizeof(StgWord) * ARG_SIZE(STABLE_TAG);
3239 #ifdef PROVIDE_FOREIGN
3244 sz += sizeof(StgPtr);
3247 barf("argSize: unrecognised result type %d\n",*ks);
3255 /* -----------------------------------------------------------------------------
3256 * encode/decode Float/Double code for standalone Hugs
3257 * Code based on the HBC code (lib/fltcode.c) and more recently GHC
3258 * (ghc/rts/StgPrimFloat.c)
3259 * ---------------------------------------------------------------------------*/
3261 #if IEEE_FLOATING_POINT
3262 #define MY_DMINEXP ((DBL_MIN_EXP) - (DBL_MANT_DIG) - 1)
3263 /* DMINEXP is defined in values.h on Linux (for example) */
3264 #define DHIGHBIT 0x00100000
3265 #define DMSBIT 0x80000000
3267 #define MY_FMINEXP ((FLT_MIN_EXP) - (FLT_MANT_DIG) - 1)
3268 #define FHIGHBIT 0x00800000
3269 #define FMSBIT 0x80000000
3271 #error The following code doesnt work in a non-IEEE FP environment
3274 #ifdef WORDS_BIGENDIAN
3283 StgDouble B__encodeDouble (B* s, I_ e) /* result = s * 2^e */
3288 /* Convert a B to a double; knows a lot about internal rep! */
3289 for(r = 0.0, i = s->used-1; i >= 0; i--)
3290 r = (r * B_BASE_FLT) + s->stuff[i];
3292 /* Now raise to the exponent */
3293 if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
3296 /* handle the sign */
3297 if (s->sign < 0) r = -r;
3304 #if ! FLOATS_AS_DOUBLES
3305 StgFloat B__encodeFloat (B* s, I_ e) /* result = s * 2^e */
3310 /* Convert a B to a float; knows a lot about internal rep! */
3311 for(r = 0.0, i = s->used-1; i >= 0; i--)
3312 r = (r * B_BASE_FLT) + s->stuff[i];
3314 /* Now raise to the exponent */
3315 if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
3318 /* handle the sign */
3319 if (s->sign < 0) r = -r;
3323 #endif /* FLOATS_AS_DOUBLES */
3327 /* This only supports IEEE floating point */
3328 void B__decodeDouble (B* man, I_* exp, StgDouble dbl)
3330 /* Do some bit fiddling on IEEE */
3331 nat low, high; /* assuming 32 bit ints */
3333 union { double d; int i[2]; } u; /* assuming 32 bit ints, 64 bit double */
3335 u.d = dbl; /* grab chunks of the double */
3339 ASSERT(B_BASE == 256);
3341 /* Assume that the supplied B is the right size */
3344 if (low == 0 && (high & ~DMSBIT) == 0) {
3345 man->sign = man->used = 0;
3350 iexp = ((high >> 20) & 0x7ff) + MY_DMINEXP;
3354 if (iexp != MY_DMINEXP) /* don't add hidden bit to denorms */
3358 /* A denorm, normalize the mantissa */
3359 while (! (high & DHIGHBIT)) {
3369 man->stuff[7] = (((W_)high) >> 24) & 0xff;
3370 man->stuff[6] = (((W_)high) >> 16) & 0xff;
3371 man->stuff[5] = (((W_)high) >> 8) & 0xff;
3372 man->stuff[4] = (((W_)high) ) & 0xff;
3374 man->stuff[3] = (((W_)low) >> 24) & 0xff;
3375 man->stuff[2] = (((W_)low) >> 16) & 0xff;
3376 man->stuff[1] = (((W_)low) >> 8) & 0xff;
3377 man->stuff[0] = (((W_)low) ) & 0xff;
3379 if (sign < 0) man->sign = -1;
3381 do_renormalise(man);
3385 #if ! FLOATS_AS_DOUBLES
3386 void B__decodeFloat (B* man, I_* exp, StgFloat flt)
3388 /* Do some bit fiddling on IEEE */
3389 int high, sign; /* assuming 32 bit ints */
3390 union { float f; int i; } u; /* assuming 32 bit float and int */
3392 u.f = flt; /* grab the float */
3395 ASSERT(B_BASE == 256);
3397 /* Assume that the supplied B is the right size */
3400 if ((high & ~FMSBIT) == 0) {
3401 man->sign = man->used = 0;
3406 *exp = ((high >> 23) & 0xff) + MY_FMINEXP;
3410 if (*exp != MY_FMINEXP) /* don't add hidden bit to denorms */
3414 /* A denorm, normalize the mantissa */
3415 while (! (high & FHIGHBIT)) {
3420 man->stuff[3] = (((W_)high) >> 24) & 0xff;
3421 man->stuff[2] = (((W_)high) >> 16) & 0xff;
3422 man->stuff[1] = (((W_)high) >> 8) & 0xff;
3423 man->stuff[0] = (((W_)high) ) & 0xff;
3425 if (sign < 0) man->sign = -1;
3427 do_renormalise(man);
3430 #endif /* FLOATS_AS_DOUBLES */
3432 #endif /* INTERPRETER */