2 /* -----------------------------------------------------------------------------
5 * Copyright (c) 1994-1998.
7 * $RCSfile: Evaluator.c,v $
9 * $Date: 2000/03/17 14:37:21 $
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} */
27 #include "Evaluator.h"
28 #include "sainteger.h"
32 #include "Disassembler.h"
37 #include <math.h> /* These are for primops */
38 #include <limits.h> /* These are for primops */
39 #include <float.h> /* These are for primops */
41 #include <ieee754.h> /* These are for primops */
44 /* Allegedly useful macro */
45 #define payloadWord( c, i ) (*stgCast(StgWord*, ((c)->payload+(i))))
47 /* An incredibly useful abbreviation.
48 * Interestingly, there are some uses of END_TSO_QUEUE_closure that
49 * can't use it because they use the closure at type StgClosure* or
50 * even StgPtr*. I suspect they should be changed. -- ADR
52 #define EndTSOQueue stgCast(StgTSO*,(void*)&END_TSO_QUEUE_closure)
54 /* These macros are rather delicate - read a good ANSI C book carefully
58 #define mycat(x,y) x##y
59 #define mycat2(x,y) mycat(x,y)
60 #define mycat3(x,y,z) mycat2(x,mycat2(y,z))
62 #if defined(__GNUC__) && !defined(DEBUG)
63 #define USE_GCC_LABELS 1
65 #define USE_GCC_LABELS 0
68 /* Make it possible for the evaluator to get hold of bytecode
69 for a given function by name. Useful but a hack. Sigh.
71 extern void* getHugs_AsmObject_for ( char* s );
72 extern int /*Bool*/ combined;
74 /* --------------------------------------------------------------------------
75 * Crude profiling stuff (mainly to assess effect of optimiser)
76 * ------------------------------------------------------------------------*/
78 #ifdef CRUDE_PROFILING
87 struct { int /*StgVar*/ who;
95 CPRecord cpTab[M_CPTAB];
102 for (i = 0; i < M_CPTAB; i++)
103 cpTab[i].who = CP_NIL;
107 void cp_enter ( StgBCO* b )
111 int /*StgVar*/ v = b->stgexpr;
112 if ((void*)v == NULL) return;
121 h = (-v) % M_CPTAB; else
124 assert (h >= 0 && h < M_CPTAB);
125 while (cpTab[h].who != v && cpTab[h].who != CP_NIL) {
126 h++; if (h == M_CPTAB) h = 0;
129 if (cpTab[cpCurr].who == CP_NIL) {
130 cpTab[cpCurr].who = v;
131 if (!is_ret_cont) cpTab[cpCurr].enters = 1;
132 cpTab[cpCurr].bytes = cpTab[cpCurr].insns = 0;
134 if (cpInUse * 2 > M_CPTAB) {
135 fprintf(stderr, "\nCRUDE_PROFILING hash table is too full\n" );
139 if (!is_ret_cont) cpTab[cpCurr].enters++;
145 void cp_bill_words ( int nw )
147 if (cpCurr == CP_NIL) return;
148 cpTab[cpCurr].bytes += sizeof(StgWord)*nw;
152 void cp_bill_insns ( int ni )
154 if (cpCurr == CP_NIL) return;
155 cpTab[cpCurr].insns += ni;
159 static double percent ( double a, double b )
161 return (100.0 * a) / b;
165 void cp_show ( void )
167 int i, j, max, maxN, totE, totB, totI, cumE, cumB, cumI;
170 if (cpInUse == -1) return;
172 fflush(stdout);fflush(stderr);
175 totE = totB = totI = 0;
176 for (i = 0; i < M_CPTAB; i++) {
177 cpTab[i].twho = cpTab[i].who;
178 if (cpTab[i].who != CP_NIL) {
179 totE += cpTab[i].enters;
180 totB += cpTab[i].bytes;
181 totI += cpTab[i].insns;
186 "%6d (%7.3f M) enters, "
187 "%6d (%7.3f M) insns, "
188 "%6d (%7.3f M) bytes\n\n",
189 totE, totE/1000000.0, totI, totI/1000000.0, totB, totB/1000000.0 );
191 cumE = cumB = cumI = 0;
192 for (j = 0; j < 32; j++) {
195 for (i = 0; i < M_CPTAB; i++)
196 if (cpTab[i].who != CP_NIL &&
197 cpTab[i].enters > maxN) {
198 maxN = cpTab[i].enters;
201 if (max == -1) break;
203 cumE += cpTab[max].enters;
204 cumB += cpTab[max].bytes;
205 cumI += cpTab[max].insns;
207 strcpy(nm, maybeName(cpTab[max].who));
208 if (strcmp(nm, "(unknown)")==0)
209 sprintf ( nm, "id%d", -cpTab[max].who);
211 printf ( "%20s %7d es (%4.1f%%, %4.1f%% c) "
212 "%7d bs (%4.1f%%, %4.1f%% c) "
213 "%7d is (%4.1f%%, %4.1f%% c)\n",
215 cpTab[max].enters, percent(cpTab[max].enters,totE), percent(cumE,totE),
216 cpTab[max].bytes, percent(cpTab[max].bytes,totB), percent(cumB,totB),
217 cpTab[max].insns, percent(cpTab[max].insns,totI), percent(cumI,totI)
220 cpTab[max].twho = cpTab[max].who;
221 cpTab[max].who = CP_NIL;
224 for (i = 0; i < M_CPTAB; i++)
225 cpTab[i].who = cpTab[i].twho;
233 /* --------------------------------------------------------------------------
234 * Hugs Hooks - a bit of a hack
235 * ------------------------------------------------------------------------*/
237 void setRtsFlags( int x );
238 void setRtsFlags( int x )
240 unsigned int w = 0x12345678;
241 unsigned char* pw = (unsigned char *)&w;
244 *(int*)(&(RtsFlags.DebugFlags)) = x;
249 w2 |= (w1 && 0xFF); w2 <<= 8; w1 >>= 8;
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 *(int*)(&(RtsFlags.DebugFlags)) = (int)w2;
258 /* --------------------------------------------------------------------------
259 * Entering-objects and bytecode interpreter part of evaluator
260 * ------------------------------------------------------------------------*/
262 /* The primop (and all other) parts of this evaluator operate upon the
263 machine state which lives in MainRegTable. enter is different:
264 to make its closure- and bytecode-interpreting loops go fast, some of that
265 state is pulled out into local vars (viz, registers, if we are lucky).
266 That means that we need to save(load) the local state at every exit(reentry)
267 into enter. That is, around every procedure call it makes. Blargh!
268 If you modify this code, __be warned__ it will fail in mysterious ways if
269 you fail to preserve this property.
271 Currently the pulled-out state is Sp in xSp, Su in xSu and SpLim in xSpLim.
272 The SSS macros saves the state back in MainRegTable, and LLL loads it from
273 MainRegTable. RETURN(v) does SSS and then returns v; all exits should
274 be via RETURN and not plain return.
276 Since xSp, xSu and xSpLim are local vars in enter, they are not visible
277 in procedures called from enter. To fix this, either (1) turn the
278 procedures into macros, so they get copied inline, or (2) bracket
279 the procedure call with SSS and LLL so that the local and global
280 machine states are synchronised for the duration of the call.
284 /* Forward decls ... */
285 static void* enterBCO_primop1 ( int );
286 static void* enterBCO_primop2 ( int , int* /*StgThreadReturnCode* */,
287 StgBCO**, Capability* );
288 static inline void PopUpdateFrame ( StgClosure* obj );
289 static inline void PopCatchFrame ( void );
290 static inline void PopSeqFrame ( void );
291 static inline void PopStopFrame( StgClosure* obj );
292 static inline void PushTaggedRealWorld( void );
293 /* static inline void PushTaggedInteger ( mpz_ptr ); */
294 static inline StgPtr grabHpUpd( nat size );
295 static inline StgPtr grabHpNonUpd( nat size );
296 static StgClosure* raiseAnError ( StgClosure* exception );
298 static int enterCountI = 0;
300 StgDouble B__encodeDouble (B* s, I_ e);
301 void B__decodeDouble (B* man, I_* exp, StgDouble dbl);
302 #if ! FLOATS_AS_DOUBLES
303 StgFloat B__encodeFloat (B* s, I_ e);
304 void B__decodeFloat (B* man, I_* exp, StgFloat flt);
305 StgPtr CreateByteArrayToHoldInteger ( int );
306 B* IntegerInsideByteArray ( StgPtr );
307 void SloppifyIntegerEnd ( StgPtr );
313 #define gSp MainRegTable.rSp
314 #define gSu MainRegTable.rSu
315 #define gSpLim MainRegTable.rSpLim
318 /* Macros to save/load local state. */
320 #define SSS { tSp=gSp = xSp; tSu=gSu = xSu; tSpLim=gSpLim = xSpLim; }
321 #define LLL { tSp=xSp = gSp; tSu=xSu = gSu; tSpLim=xSpLim = gSpLim; }
323 #define SSS { gSp = xSp; gSu = xSu; gSpLim = xSpLim; }
324 #define LLL { xSp = gSp; xSu = gSu; xSpLim = gSpLim; }
327 #define RETURN(vvv) { \
328 StgThreadReturnCode retVal=(vvv); \
330 cap->rCurrentTSO->sp = gSp; \
331 cap->rCurrentTSO->su = gSu; \
332 cap->rCurrentTSO->splim = gSpLim; \
337 /* Macros to operate directly on the pulled-out machine state.
338 These mirror some of the small procedures used in the primop code
339 below, except you have to be careful about side effects,
340 ie xPushPtr(xStackPtr(n)) won't work! It certainly isn't the
341 same as PushPtr(StackPtr(n)). Also note that (1) some of
342 the macros, in particular xPopTagged*, do not make the tag
343 sanity checks that their non-x cousins do, and (2) some of
344 the macros depend critically on the semantics of C comma
345 expressions to work properly.
347 #define xPushPtr(ppp) { xSp--; *xSp=(StgWord)(ppp); }
348 #define xPopPtr() ((StgPtr)(*xSp++))
350 #define xPushCPtr(ppp) { xSp--; *xSp=(StgWord)(ppp); }
351 #define xPopCPtr() ((StgClosure*)(*xSp++))
353 #define xPushWord(ppp) { xSp--; *xSp=(StgWord)(ppp); }
354 #define xPopWord() ((StgWord)(*xSp++))
356 #define xStackPtr(nnn) ((StgPtr)(*(xSp+(nnn))))
357 #define xStackWord(nnn) ((StgWord)(*(xSp+(nnn))))
358 #define xSetStackWord(iii,www) xSp[iii]=(StgWord)(www)
360 #define xPushTag(ttt) { xSp--; *xSp=(StgWord)(ttt); }
361 #define xPopTag(ttt) { StackTag t = (StackTag)(*xSp++); \
364 #define xPushTaggedInt(xxx) { xSp -= sizeofW(StgInt); \
365 *xSp = (xxx); xPushTag(INT_TAG); }
366 #define xTaggedStackInt(iii) ((StgInt)(*(xSp+1+(iii))))
367 #define xPopTaggedInt() ((xSp++,xSp+=sizeofW(StgInt), \
368 (StgInt)(*(xSp-sizeofW(StgInt)))))
370 #define xPushTaggedWord(xxx) { xSp -= sizeofW(StgWord); \
371 *xSp = (xxx); xPushTag(WORD_TAG); }
372 #define xTaggedStackWord(iii) ((StgWord)(*(xSp+1+(iii))))
373 #define xPopTaggedWord() ((xSp++,xSp+=sizeofW(StgWord), \
374 (StgWord)(*(xSp-sizeofW(StgWord)))))
376 #define xPushTaggedAddr(xxx) { xSp -= sizeofW(StgAddr); \
377 *xSp = (StgWord)(xxx); xPushTag(ADDR_TAG); }
378 #define xTaggedStackAddr(iii) ((StgAddr)(*(xSp+1+(iii))))
379 #define xPopTaggedAddr() ((xSp++,xSp+=sizeofW(StgAddr), \
380 (StgAddr)(*(xSp-sizeofW(StgAddr)))))
382 #define xPushTaggedStable(xxx) { xSp -= sizeofW(StgStablePtr); \
383 *xSp = (StgWord)(xxx); xPushTag(STABLE_TAG); }
384 #define xTaggedStackStable(iii) ((StgStablePtr)(*(xSp+1+(iii))))
385 #define xPopTaggedStable() ((xSp++,xSp+=sizeofW(StgStablePtr), \
386 (StgStablePtr)(*(xSp-sizeofW(StgStablePtr)))))
388 #define xPushTaggedChar(xxx) { xSp -= sizeofW(StgChar); \
389 *xSp = (StgWord)(xxx); xPushTag(CHAR_TAG); }
390 #define xTaggedStackChar(iii) ((StgChar)(*(xSp+1+(iii))))
391 #define xPopTaggedChar() ((xSp++,xSp+=sizeofW(StgChar), \
392 (StgChar)(*(xSp-sizeofW(StgChar)))))
394 #define xPushTaggedFloat(xxx) { xSp -= sizeofW(StgFloat); \
395 ASSIGN_FLT(xSp,xxx); xPushTag(FLOAT_TAG); }
396 #define xTaggedStackFloat(iii) PK_FLT(xSp+1+(iii))
397 #define xPopTaggedFloat() ((xSp++,xSp+=sizeofW(StgFloat), \
398 PK_FLT(xSp-sizeofW(StgFloat))))
400 #define xPushTaggedDouble(xxx) { xSp -= sizeofW(StgDouble); \
401 ASSIGN_DBL(xSp,xxx); xPushTag(DOUBLE_TAG); }
402 #define xTaggedStackDouble(iii) PK_DBL(xSp+1+(iii))
403 #define xPopTaggedDouble() ((xSp++,xSp+=sizeofW(StgDouble), \
404 PK_DBL(xSp-sizeofW(StgDouble))))
407 #define xPushUpdateFrame(target, xSp_offset) \
409 StgUpdateFrame *__frame; \
410 __frame = (StgUpdateFrame *)(xSp + (xSp_offset)) - 1; \
411 SET_INFO(__frame, (StgInfoTable *)&Upd_frame_info); \
412 __frame->link = xSu; \
413 __frame->updatee = (StgClosure *)(target); \
417 #define xPopUpdateFrame(ooo) \
419 /* NB: doesn't assume that Sp == Su */ \
420 IF_DEBUG(evaluator, \
421 fprintf(stderr, "Updating "); \
422 printPtr(stgCast(StgPtr,xSu->updatee)); \
423 fprintf(stderr, " with "); \
425 fprintf(stderr,"xSp = %p\txSu = %p\n\n", xSp, xSu); \
427 UPD_IND(xSu->updatee,ooo); \
428 xSp = stgCast(StgStackPtr,xSu) + sizeofW(StgUpdateFrame); \
434 /* Instruction stream macros */
435 #define BCO_INSTR_8 *bciPtr++
436 #define BCO_INSTR_16 ((bciPtr += 2, (*(bciPtr-2) << 8) + *(bciPtr-1)))
437 #define PC (bciPtr - &(bcoInstr(bco,0)))
440 /* State on entry to enter():
441 * - current thread is in cap->rCurrentTSO;
442 * - allocation area is in cap->rCurrentNursery & cap->rNursery
445 StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 )
447 /* use of register here is primarily to make it clear to compilers
448 that these entities are non-aliasable.
450 register StgPtr xSp; /* local state -- stack pointer */
451 register StgUpdateFrame* xSu; /* local state -- frame pointer */
452 register StgPtr xSpLim; /* local state -- stack lim pointer */
453 register StgClosure* obj; /* object currently under evaluation */
454 char eCount; /* enter counter, for context switching */
457 StgPtr tSp; StgUpdateFrame* tSu; StgPtr tSpLim;
460 gSp = cap->rCurrentTSO->sp;
461 gSu = cap->rCurrentTSO->su;
462 gSpLim = cap->rCurrentTSO->splim;
465 /* use the t values to check that Su/Sp/SpLim do not change unexpectedly */
466 tSp = gSp; tSu = gSu; tSpLim = gSpLim;
472 /* Load the local state from global state, and Party On, Dudes! */
473 /* From here onwards, we operate with the local state and
474 save/reload it as necessary.
483 assert(gSpLim == tSpLim);
487 ASSERT(xSpLim <= xSp && xSp <= stgCast(StgPtr,xSu));
489 "\n---------------------------------------------------------------\n");
490 fprintf(stderr,"(%d) Entering: ",enterCountI); printObj(obj);
491 fprintf(stderr,"xSp = %p\txSu = %p\n", xSp, xSu);
492 fprintf(stderr, "\n" );
493 printStack(xSp,cap->rCurrentTSO->stack+cap->rCurrentTSO->stack_size,xSu);
494 fprintf(stderr, "\n\n");
501 ((++eCount) & 0x0F) == 0
506 if (context_switch) {
507 xPushCPtr(obj); /* code to restart with */
508 RETURN(ThreadYielding);
512 switch ( get_itbl(obj)->type ) {
514 barf("Invalid object %p",obj);
518 /* ---------------------------------------------------- */
519 /* Start of the bytecode evaluator */
520 /* ---------------------------------------------------- */
523 # define Ins(x) &&l##x
524 static void *labs[] = { INSTRLIST };
526 # define LoopTopLabel
527 # define Case(x) l##x
528 # define Continue goto *labs[BCO_INSTR_8]
529 # define Dispatch Continue;
532 # define LoopTopLabel insnloop:
533 # define Case(x) case x
534 # define Continue goto insnloop
535 # define Dispatch switch (BCO_INSTR_8) {
536 # define EndDispatch }
539 register StgWord8* bciPtr; /* instruction pointer */
540 register StgBCO* bco = (StgBCO*)obj;
543 /* Don't need to SSS ... LLL around doYouWantToGC */
544 wantToGC = doYouWantToGC();
546 xPushCPtr((StgClosure*)bco); /* code to restart with */
547 RETURN(HeapOverflow);
555 bciPtr = &(bcoInstr(bco,0));
559 ASSERT((StgWord)(PC) < bco->n_instrs);
561 fprintf(stderr,"Sp = %p\tSu = %p\tpc = %d\t", xSp, xSu, PC);
565 fprintf(stderr,"\n");
566 for (i = 8; i >= 0; i--)
567 fprintf(stderr, "%d %p\n", i, (StgPtr)(*(gSp+i)));
569 fprintf(stderr,"\n");
574 SSS; cp_bill_insns(1); LLL;
579 Case(i_INTERNAL_ERROR):
580 barf("INTERNAL_ERROR at %p:%d",bco,PC-1);
582 barf("PANIC at %p:%d",bco,PC-1);
586 if (xSp - n < xSpLim) {
587 xPushCPtr((StgClosure*)bco); /* code to restart with */
588 RETURN(StackOverflow);
592 Case(i_STK_CHECK_big):
594 int n = BCO_INSTR_16;
595 if (xSp - n < xSpLim) {
596 xPushCPtr((StgClosure*)bco); /* code to restart with */
597 RETURN(StackOverflow);
604 if ((StgPtr*)(xSp + n) > (StgPtr*)xSu) {
605 StgWord words = (P_)xSu - xSp;
607 /* first build a PAP */
608 ASSERT((P_)xSu >= xSp); /* was (words >= 0) but that's always true */
609 if (words == 0) { /* optimisation */
610 /* Skip building the PAP and update with an indirection. */
613 /* In the evaluator, we avoid the need to do
614 * a heap check here by including the size of
615 * the PAP in the heap check we performed
616 * when we entered the BCO.
620 SSS; pap = (StgPAP*)grabHpNonUpd(PAP_sizeW(words)); LLL;
621 SET_HDR(pap,&PAP_info,CC_pap);
624 for (i = 0; i < (I_)words; ++i) {
625 payloadWord(pap,i) = xSp[i];
628 obj = stgCast(StgClosure*,pap);
631 /* now deal with "update frame" */
632 /* as an optimisation, we process all on top of stack */
633 /* instead of just the top one */
634 ASSERT(xSp==(P_)xSu);
636 switch (get_itbl(xSu)->type) {
638 /* Hit a catch frame during an arg satisfaction check,
639 * so the thing returning (1) has not thrown an
640 * exception, and (2) is of functional type. Just
641 * zap the catch frame and carry on down the stack
642 * (looking for more arguments, basically).
644 SSS; PopCatchFrame(); LLL;
647 xPopUpdateFrame(obj);
650 SSS; PopStopFrame(obj); LLL;
651 RETURN(ThreadFinished);
653 SSS; PopSeqFrame(); LLL;
654 ASSERT(xSp != (P_)xSu);
655 /* Hit a SEQ frame during an arg satisfaction check.
656 * So now return to bco_info which is under the
657 * SEQ frame. The following code is copied from a
658 * case RET_BCO further down. (The reason why we're
659 * here is that something of functional type has
660 * been seq-d on, and we're now returning to the
661 * algebraic-case-continuation which forced the
662 * evaluation in the first place.)
674 barf("Invalid update frame during argcheck");
676 } while (xSp==(P_)xSu);
684 int words = BCO_INSTR_8;
685 SSS; p = grabHpUpd(AP_sizeW(words)); LLL;
689 Case(i_ALLOC_CONSTR):
692 StgInfoTable* info = bcoConstAddr(bco,BCO_INSTR_8);
693 SSS; p = grabHpNonUpd(sizeW_fromITBL(info)); LLL;
694 SET_HDR((StgClosure*)p,info,??);
698 Case(i_ALLOC_CONSTR_big):
701 int x = BCO_INSTR_16;
702 StgInfoTable* info = bcoConstAddr(bco,x);
703 SSS; p = grabHpNonUpd(sizeW_fromITBL(info)); LLL;
704 SET_HDR((StgClosure*)p,info,??);
710 int x = BCO_INSTR_8; /* ToDo: Word not Int! */
712 StgAP_UPD* o = stgCast(StgAP_UPD*,xStackPtr(x));
713 SET_HDR(o,&AP_UPD_info,??);
715 o->fun = stgCast(StgClosure*,xPopPtr());
716 for(x=0; x < y; ++x) {
717 payloadWord(o,x) = xPopWord();
720 fprintf(stderr,"\tBuilt ");
722 printObj(stgCast(StgClosure*,o));
733 o = stgCast(StgAP_UPD*,xStackPtr(x));
734 SET_HDR(o,&AP_UPD_info,??);
736 o->fun = stgCast(StgClosure*,xPopPtr());
737 for(x=0; x < y; ++x) {
738 payloadWord(o,x) = xPopWord();
741 fprintf(stderr,"\tBuilt ");
743 printObj(stgCast(StgClosure*,o));
752 StgPAP* o = stgCast(StgPAP*,xStackPtr(x));
753 SET_HDR(o,&PAP_info,??);
755 o->fun = stgCast(StgClosure*,xPopPtr());
756 for(x=0; x < y; ++x) {
757 payloadWord(o,x) = xPopWord();
760 fprintf(stderr,"\tBuilt ");
762 printObj(stgCast(StgClosure*,o));
769 int offset = BCO_INSTR_8;
770 StgClosure* o = stgCast(StgClosure*,xStackPtr(offset));
771 const StgInfoTable* info = get_itbl(o);
772 nat p = info->layout.payload.ptrs;
773 nat np = info->layout.payload.nptrs;
775 for(i=0; i < p; ++i) {
776 o->payload[i] = xPopCPtr();
778 for(i=0; i < np; ++i) {
779 payloadWord(o,p+i) = 0xdeadbeef;
782 fprintf(stderr,"\tBuilt ");
784 printObj(stgCast(StgClosure*,o));
791 int offset = BCO_INSTR_16;
792 StgClosure* o = stgCast(StgClosure*,xStackPtr(offset));
793 const StgInfoTable* info = get_itbl(o);
794 nat p = info->layout.payload.ptrs;
795 nat np = info->layout.payload.nptrs;
797 for(i=0; i < p; ++i) {
798 o->payload[i] = xPopCPtr();
800 for(i=0; i < np; ++i) {
801 payloadWord(o,p+i) = 0xdeadbeef;
804 fprintf(stderr,"\tBuilt ");
806 printObj(stgCast(StgClosure*,o));
815 ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
816 /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
818 xSetStackWord(x+y,xStackWord(x));
828 ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
829 /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
831 xSetStackWord(x+y,xStackWord(x));
843 xPushPtr(bcoConstPtr(bco,BCO_INSTR_8));
844 xPushPtr(stgCast(StgPtr,&ret_bco_info));
849 int tag = BCO_INSTR_8;
850 StgWord offset = BCO_INSTR_16;
851 if (constrTag( (StgClosure*)xStackPtr(0) ) != tag) {
858 StgClosure* o = stgCast(StgClosure*,xStackPtr(0));
859 const StgInfoTable* itbl = get_itbl(o);
860 int i = itbl->layout.payload.ptrs;
861 ASSERT( itbl->type == CONSTR
862 || itbl->type == CONSTR_STATIC
863 || itbl->type == CONSTR_NOCAF_STATIC
864 || itbl->type == CONSTR_1_0
865 || itbl->type == CONSTR_0_1
866 || itbl->type == CONSTR_2_0
867 || itbl->type == CONSTR_1_1
868 || itbl->type == CONSTR_0_2
871 xPushCPtr(o->payload[i]);
877 int n = BCO_INSTR_16;
878 StgPtr p = xStackPtr(n);
884 StgPtr p = xStackPtr(BCO_INSTR_8);
890 xPushPtr(stgCast(StgPtr,bcoConstPtr(bco,BCO_INSTR_8)));
895 int n = BCO_INSTR_16;
896 xPushPtr(stgCast(StgPtr,bcoConstPtr(bco,n)));
901 SSS; PushTaggedRealWorld(); LLL;
906 StgInt i = xTaggedStackInt(BCO_INSTR_8);
912 xPushTaggedInt(bcoConstInt(bco,BCO_INSTR_8));
915 Case(i_CONST_INT_big):
917 int n = BCO_INSTR_16;
918 xPushTaggedInt(bcoConstInt(bco,n));
924 SSS; o = (StgClosure*)grabHpNonUpd(Izh_sizeW); LLL;
925 SET_HDR(o,Izh_con_info,??);
926 payloadWord(o,0) = xPopTaggedInt();
928 fprintf(stderr,"\tBuilt ");
930 printObj(stgCast(StgClosure*,o));
933 xPushPtr(stgCast(StgPtr,o));
938 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
939 /* ASSERT(isIntLike(con)); */
940 xPushTaggedInt(payloadWord(con,0));
945 StgWord offset = BCO_INSTR_16;
946 StgInt x = xPopTaggedInt();
947 StgInt y = xPopTaggedInt();
953 Case(i_CONST_INTEGER):
957 char* s = bcoConstAddr(bco,BCO_INSTR_8);
960 p = CreateByteArrayToHoldInteger(n);
961 do_fromStr ( s, n, IntegerInsideByteArray(p));
962 SloppifyIntegerEnd(p);
969 StgWord w = xTaggedStackWord(BCO_INSTR_8);
975 xPushTaggedWord(bcoConstWord(bco,BCO_INSTR_8));
981 SSS; o = (StgClosure*)grabHpNonUpd(Wzh_sizeW); LLL;
982 SET_HDR(o,Wzh_con_info,??);
983 payloadWord(o,0) = xPopTaggedWord();
985 fprintf(stderr,"\tBuilt ");
987 printObj(stgCast(StgClosure*,o));
990 xPushPtr(stgCast(StgPtr,o));
995 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
996 /* ASSERT(isWordLike(con)); */
997 xPushTaggedWord(payloadWord(con,0));
1002 StgAddr a = xTaggedStackAddr(BCO_INSTR_8);
1008 xPushTaggedAddr(bcoConstAddr(bco,BCO_INSTR_8));
1011 Case(i_CONST_ADDR_big):
1013 int n = BCO_INSTR_16;
1014 xPushTaggedAddr(bcoConstAddr(bco,n));
1020 SSS; o = (StgClosure*)grabHpNonUpd(Azh_sizeW); LLL;
1021 SET_HDR(o,Azh_con_info,??);
1022 payloadPtr(o,0) = xPopTaggedAddr();
1024 fprintf(stderr,"\tBuilt ");
1026 printObj(stgCast(StgClosure*,o));
1029 xPushPtr(stgCast(StgPtr,o));
1032 Case(i_UNPACK_ADDR):
1034 StgClosure* con = (StgClosure*)xStackPtr(0);
1035 /* ASSERT(isAddrLike(con)); */
1036 xPushTaggedAddr(payloadPtr(con,0));
1041 StgChar c = xTaggedStackChar(BCO_INSTR_8);
1047 xPushTaggedChar(bcoConstChar(bco,BCO_INSTR_8));
1053 SSS; o = (StgClosure*)grabHpNonUpd(Czh_sizeW); LLL;
1054 SET_HDR(o,Czh_con_info,??);
1055 payloadWord(o,0) = xPopTaggedChar();
1056 xPushPtr(stgCast(StgPtr,o));
1058 fprintf(stderr,"\tBuilt ");
1060 printObj(stgCast(StgClosure*,o));
1065 Case(i_UNPACK_CHAR):
1067 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1068 /* ASSERT(isCharLike(con)); */
1069 xPushTaggedChar(payloadWord(con,0));
1074 StgFloat f = xTaggedStackFloat(BCO_INSTR_8);
1075 xPushTaggedFloat(f);
1078 Case(i_CONST_FLOAT):
1080 xPushTaggedFloat(bcoConstFloat(bco,BCO_INSTR_8));
1086 SSS; o = (StgClosure*)grabHpNonUpd(Fzh_sizeW); LLL;
1087 SET_HDR(o,Fzh_con_info,??);
1088 ASSIGN_FLT(&payloadWord(o,0),xPopTaggedFloat());
1090 fprintf(stderr,"\tBuilt ");
1092 printObj(stgCast(StgClosure*,o));
1095 xPushPtr(stgCast(StgPtr,o));
1098 Case(i_UNPACK_FLOAT):
1100 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1101 /* ASSERT(isFloatLike(con)); */
1102 xPushTaggedFloat(PK_FLT(&payloadWord(con,0)));
1107 StgDouble d = xTaggedStackDouble(BCO_INSTR_8);
1108 xPushTaggedDouble(d);
1111 Case(i_CONST_DOUBLE):
1113 xPushTaggedDouble(bcoConstDouble(bco,BCO_INSTR_8));
1116 Case(i_CONST_DOUBLE_big):
1118 int n = BCO_INSTR_16;
1119 xPushTaggedDouble(bcoConstDouble(bco,n));
1122 Case(i_PACK_DOUBLE):
1125 SSS; o = (StgClosure*)grabHpNonUpd(Dzh_sizeW); LLL;
1126 SET_HDR(o,Dzh_con_info,??);
1127 ASSIGN_DBL(&payloadWord(o,0),xPopTaggedDouble());
1129 fprintf(stderr,"\tBuilt ");
1130 printObj(stgCast(StgClosure*,o));
1132 xPushPtr(stgCast(StgPtr,o));
1135 Case(i_UNPACK_DOUBLE):
1137 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1138 /* ASSERT(isDoubleLike(con)); */
1139 xPushTaggedDouble(PK_DBL(&payloadWord(con,0)));
1144 StgStablePtr s = xTaggedStackStable(BCO_INSTR_8);
1145 xPushTaggedStable(s);
1148 Case(i_PACK_STABLE):
1151 SSS; o = (StgClosure*)grabHpNonUpd(Stablezh_sizeW); LLL;
1152 SET_HDR(o,StablePtr_con_info,??);
1153 payloadWord(o,0) = xPopTaggedStable();
1155 fprintf(stderr,"\tBuilt ");
1157 printObj(stgCast(StgClosure*,o));
1160 xPushPtr(stgCast(StgPtr,o));
1163 Case(i_UNPACK_STABLE):
1165 StgClosure* con = (StgClosure*)xStackPtr(0);
1166 /* ASSERT(isStableLike(con)); */
1167 xPushTaggedStable(payloadWord(con,0));
1175 SSS; p = enterBCO_primop1 ( i ); LLL;
1176 if (p) { obj = p; goto enterLoop; };
1181 int i, trc, pc_saved;
1184 trc = 12345678; /* Assume != any StgThreadReturnCode */
1189 p = enterBCO_primop2 ( i, &trc, &bco_tmp, cap );
1192 bciPtr = &(bcoInstr(bco,pc_saved));
1194 if (trc == 12345678) {
1195 /* we want to enter p */
1196 obj = p; goto enterLoop;
1198 /* trc is the the StgThreadReturnCode for this thread */
1199 RETURN((StgThreadReturnCode)trc);
1205 /* combined insns, created by peephole opt */
1208 int x = BCO_INSTR_8;
1209 int y = BCO_INSTR_8;
1210 ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
1211 /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
1218 xSetStackWord(x+y,xStackWord(x));
1228 p = xStackPtr(BCO_INSTR_8);
1230 p = xStackPtr(BCO_INSTR_8);
1237 xPushPtr(bcoConstPtr(bco,BCO_INSTR_8));
1238 xPushPtr(stgCast(StgPtr,&ret_bco_info));
1239 p = xStackPtr(BCO_INSTR_8);
1245 StgPtr retaddr = bcoConstPtr(bco,BCO_INSTR_8);
1246 StgPtr ptr = xStackPtr(BCO_INSTR_8);
1248 /* A shortcut. We're going to push the address of a
1249 return continuation, and then enter a variable, so
1250 that when the var is evaluated, we return to the
1251 continuation. The shortcut is: if the var is a
1252 constructor, don't bother to enter it. Instead,
1253 push the variable on the stack (since this is what
1254 the continuation expects) and jump directly to the
1257 if (get_itbl((StgClosure*)ptr)->type == CONSTR) {
1259 obj = (StgClosure*)retaddr;
1261 fprintf(stderr, "object to enter is a constructor -- "
1262 "jumping directly to return continuation\n" );
1267 /* This is the normal, non-short-cut route */
1269 xPushPtr(stgCast(StgPtr,&ret_bco_info));
1270 obj = (StgClosure*)ptr;
1275 Case(i_VAR_DOUBLE_big):
1276 Case(i_CONST_FLOAT_big):
1277 Case(i_VAR_FLOAT_big):
1278 Case(i_CONST_CHAR_big):
1279 Case(i_VAR_CHAR_big):
1280 Case(i_VAR_ADDR_big):
1281 Case(i_VAR_STABLE_big):
1282 Case(i_CONST_INTEGER_big):
1283 Case(i_VAR_INT_big):
1284 Case(i_VAR_WORD_big):
1285 Case(i_RETADDR_big):
1289 disInstr ( bco, PC );
1290 barf("\nUnrecognised instruction");
1294 barf("enterBCO: ran off end of loop");
1298 # undef LoopTopLabel
1304 /* ---------------------------------------------------- */
1305 /* End of the bytecode evaluator */
1306 /* ---------------------------------------------------- */
1310 StgBlockingQueue* bh;
1311 StgCAF* caf = (StgCAF*)obj;
1312 if (xSp - sizeofW(StgUpdateFrame) < xSpLim) {
1313 xPushCPtr(obj); /* code to restart with */
1314 RETURN(StackOverflow);
1316 /* ToDo: look for xSp==xSu && stackInt(0) == UPD_FRAME
1317 and insert an indirection immediately */
1318 SSS; bh = (StgBlockingQueue*)grabHpUpd(BLACKHOLE_sizeW()); LLL;
1319 SET_INFO(bh,&CAF_BLACKHOLE_info);
1320 bh->blocking_queue = EndTSOQueue;
1322 fprintf(stderr,"Created CAF_BLACKHOLE %p for CAF %p in evaluator\n",bh,caf));
1323 SET_INFO(caf,&CAF_ENTERED_info);
1324 caf->value = (StgClosure*)bh;
1325 if (caf->mut_link == NULL) {
1326 SSS; recordOldToNewPtrs((StgMutClosure*)caf); LLL;
1328 xPushUpdateFrame(bh,0);
1329 xSp -= sizeofW(StgUpdateFrame);
1330 caf->link = enteredCAFs;
1337 StgCAF* caf = (StgCAF*)obj;
1338 obj = caf->value; /* it's just a fancy indirection */
1344 case SE_CAF_BLACKHOLE:
1346 /* Let the scheduler figure out what to do :-) */
1347 cap->rCurrentTSO->what_next = ThreadEnterGHC;
1349 RETURN(ThreadYielding);
1353 StgAP_UPD* ap = stgCast(StgAP_UPD*,obj);
1355 if (xSp - (i + sizeofW(StgUpdateFrame)) < xSpLim) {
1356 xPushCPtr(obj); /* code to restart with */
1357 RETURN(StackOverflow);
1359 /* ToDo: look for xSp==xSu && stackInt(0) == UPD_FRAME
1360 and insert an indirection immediately */
1361 xPushUpdateFrame(ap,0);
1362 xSp -= sizeofW(StgUpdateFrame);
1364 xPushWord(payloadWord(ap,i));
1367 #ifdef EAGER_BLACKHOLING
1368 #warn LAZY_BLACKHOLING is default for StgHugs
1369 #error Dont know if EAGER_BLACKHOLING works in StgHugs
1371 /* superfluous - but makes debugging easier */
1372 StgBlackHole* bh = stgCast(StgBlackHole*,ap);
1373 SET_INFO(bh,&BLACKHOLE_info);
1374 bh->blocking_queue = EndTSOQueue;
1376 fprintf(stderr,"Eagerly blackholed AP_UPD %p in evaluator\n",bh));
1379 #endif /* EAGER_BLACKHOLING */
1384 StgPAP* pap = stgCast(StgPAP*,obj);
1385 int i = pap->n_args; /* ToDo: stack check */
1386 /* ToDo: if PAP is in whnf, we can update any update frames
1390 xPushWord(payloadWord(pap,i));
1397 obj = stgCast(StgInd*,obj)->indirectee;
1402 obj = stgCast(StgIndOldGen*,obj)->indirectee;
1411 case CONSTR_INTLIKE:
1412 case CONSTR_CHARLIKE:
1414 case CONSTR_NOCAF_STATIC:
1417 switch (get_itbl(stgCast(StgClosure*,xSp))->type) {
1419 SSS; PopCatchFrame(); LLL;
1422 xPopUpdateFrame(obj);
1425 SSS; PopSeqFrame(); LLL;
1429 ASSERT(xSp==(P_)xSu);
1432 fprintf(stderr, "hit a STOP_FRAME\n");
1434 fprintf(stderr,"xSp = %p\txSu = %p\n", xSp, xSu);
1435 printStack(xSp,cap->rCurrentTSO->stack
1436 + cap->rCurrentTSO->stack_size,xSu);
1439 SSS; PopStopFrame(obj); LLL;
1440 RETURN(ThreadFinished);
1450 /* was: goto enterLoop;
1451 But we know that obj must be a bco now, so jump directly.
1454 case RET_SMALL: /* return to GHC */
1458 cap->rCurrentTSO->what_next = ThreadEnterGHC;
1460 RETURN(ThreadYielding);
1462 belch("entered CONSTR with invalid continuation on stack");
1465 printObj(stgCast(StgClosure*,xSp));
1468 barf("bailing out");
1475 //fprintf(stderr, "enterCountI = %d\n", enterCountI);
1476 //fprintf(stderr, "entering unknown closure -- yielding to sched\n");
1479 cap->rCurrentTSO->what_next = ThreadEnterGHC;
1480 xPushCPtr(obj); /* code to restart with */
1481 RETURN(ThreadYielding);
1484 barf("Ran off the end of enter - yoiks");
1501 #undef xSetStackWord
1504 #undef xPushTaggedInt
1505 #undef xPopTaggedInt
1506 #undef xTaggedStackInt
1507 #undef xPushTaggedWord
1508 #undef xPopTaggedWord
1509 #undef xTaggedStackWord
1510 #undef xPushTaggedAddr
1511 #undef xTaggedStackAddr
1512 #undef xPopTaggedAddr
1513 #undef xPushTaggedStable
1514 #undef xTaggedStackStable
1515 #undef xPopTaggedStable
1516 #undef xPushTaggedChar
1517 #undef xTaggedStackChar
1518 #undef xPopTaggedChar
1519 #undef xPushTaggedFloat
1520 #undef xTaggedStackFloat
1521 #undef xPopTaggedFloat
1522 #undef xPushTaggedDouble
1523 #undef xTaggedStackDouble
1524 #undef xPopTaggedDouble
1525 #undef xPopUpdateFrame
1526 #undef xPushUpdateFrame
1529 /* --------------------------------------------------------------------------
1530 * Supporting routines for primops
1531 * ------------------------------------------------------------------------*/
1533 static inline void PushTag ( StackTag t )
1535 inline void PushPtr ( StgPtr x )
1536 { *(--stgCast(StgPtr*,gSp)) = x; }
1537 static inline void PushCPtr ( StgClosure* x )
1538 { *(--stgCast(StgClosure**,gSp)) = x; }
1539 static inline void PushInt ( StgInt x )
1540 { *(--stgCast(StgInt*,gSp)) = x; }
1541 static inline void PushWord ( StgWord x )
1542 { *(--stgCast(StgWord*,gSp)) = x; }
1545 static inline void checkTag ( StackTag t1, StackTag t2 )
1546 { ASSERT(t1 == t2);}
1547 static inline void PopTag ( StackTag t )
1548 { checkTag(t,*(gSp++)); }
1549 inline StgPtr PopPtr ( void )
1550 { return *stgCast(StgPtr*,gSp)++; }
1551 static inline StgClosure* PopCPtr ( void )
1552 { return *stgCast(StgClosure**,gSp)++; }
1553 static inline StgInt PopInt ( void )
1554 { return *stgCast(StgInt*,gSp)++; }
1555 static inline StgWord PopWord ( void )
1556 { return *stgCast(StgWord*,gSp)++; }
1558 static inline StgPtr stackPtr ( StgStackOffset i )
1559 { return *stgCast(StgPtr*, gSp+i); }
1560 static inline StgInt stackInt ( StgStackOffset i )
1561 { return *stgCast(StgInt*, gSp+i); }
1562 static inline StgWord stackWord ( StgStackOffset i )
1563 { return *stgCast(StgWord*,gSp+i); }
1565 static inline void setStackWord ( StgStackOffset i, StgWord w )
1568 static inline void PushTaggedRealWorld( void )
1569 { PushTag(REALWORLD_TAG); }
1570 inline void PushTaggedInt ( StgInt x )
1571 { gSp -= sizeofW(StgInt); *gSp = x; PushTag(INT_TAG); }
1572 inline void PushTaggedWord ( StgWord x )
1573 { gSp -= sizeofW(StgWord); *gSp = x; PushTag(WORD_TAG); }
1574 inline void PushTaggedAddr ( StgAddr x )
1575 { gSp -= sizeofW(StgAddr); *gSp = (W_)x; PushTag(ADDR_TAG); }
1576 inline void PushTaggedChar ( StgChar x )
1577 { gSp -= sizeofW(StgChar); *gSp = stgCast(StgWord,x); PushTag(CHAR_TAG); }
1578 inline void PushTaggedFloat ( StgFloat x )
1579 { gSp -= sizeofW(StgFloat); ASSIGN_FLT(gSp,x); PushTag(FLOAT_TAG); }
1580 inline void PushTaggedDouble ( StgDouble x )
1581 { gSp -= sizeofW(StgDouble); ASSIGN_DBL(gSp,x); PushTag(DOUBLE_TAG); }
1582 inline void PushTaggedStablePtr ( StgStablePtr x )
1583 { gSp -= sizeofW(StgStablePtr); *gSp = x; PushTag(STABLE_TAG); }
1584 static inline void PushTaggedBool ( int x )
1585 { PushTaggedInt(x); }
1589 static inline void PopTaggedRealWorld ( void )
1590 { PopTag(REALWORLD_TAG); }
1591 inline StgInt PopTaggedInt ( void )
1592 { StgInt r; PopTag(INT_TAG); r = *stgCast(StgInt*, gSp);
1593 gSp += sizeofW(StgInt); return r;}
1594 inline StgWord PopTaggedWord ( void )
1595 { StgWord r; PopTag(WORD_TAG); r = *stgCast(StgWord*, gSp);
1596 gSp += sizeofW(StgWord); return r;}
1597 inline StgAddr PopTaggedAddr ( void )
1598 { StgAddr r; PopTag(ADDR_TAG); r = *stgCast(StgAddr*, gSp);
1599 gSp += sizeofW(StgAddr); return r;}
1600 inline StgChar PopTaggedChar ( void )
1601 { StgChar r; PopTag(CHAR_TAG); r = stgCast(StgChar, *gSp);
1602 gSp += sizeofW(StgChar); return r;}
1603 inline StgFloat PopTaggedFloat ( void )
1604 { StgFloat r; PopTag(FLOAT_TAG); r = PK_FLT(gSp);
1605 gSp += sizeofW(StgFloat); return r;}
1606 inline StgDouble PopTaggedDouble ( void )
1607 { StgDouble r; PopTag(DOUBLE_TAG); r = PK_DBL(gSp);
1608 gSp += sizeofW(StgDouble); return r;}
1609 inline StgStablePtr PopTaggedStablePtr ( void )
1610 { StgInt r; PopTag(STABLE_TAG); r = *stgCast(StgStablePtr*, gSp);
1611 gSp += sizeofW(StgStablePtr); return r;}
1615 static inline StgInt taggedStackInt ( StgStackOffset i )
1616 { checkTag(INT_TAG,gSp[i]); return *stgCast(StgInt*, gSp+1+i); }
1617 static inline StgWord taggedStackWord ( StgStackOffset i )
1618 { checkTag(WORD_TAG,gSp[i]); return *stgCast(StgWord*, gSp+1+i); }
1619 static inline StgAddr taggedStackAddr ( StgStackOffset i )
1620 { checkTag(ADDR_TAG,gSp[i]); return *stgCast(StgAddr*, gSp+1+i); }
1621 static inline StgChar taggedStackChar ( StgStackOffset i )
1622 { checkTag(CHAR_TAG,gSp[i]); return stgCast(StgChar, *(gSp+1+i)) ; }
1623 static inline StgFloat taggedStackFloat ( StgStackOffset i )
1624 { checkTag(FLOAT_TAG,gSp[i]); return PK_FLT(gSp+1+i); }
1625 static inline StgDouble taggedStackDouble ( StgStackOffset i )
1626 { checkTag(DOUBLE_TAG,gSp[i]); return PK_DBL(gSp+1+i); }
1627 static inline StgStablePtr taggedStackStable ( StgStackOffset i )
1628 { checkTag(STABLE_TAG,gSp[i]); return *stgCast(StgStablePtr*, gSp+1+i); }
1631 /* --------------------------------------------------------------------------
1634 * Should we allocate from a nursery or use the
1635 * doYouWantToGC/allocate interface? We'd already implemented a
1636 * nursery-style scheme when the doYouWantToGC/allocate interface
1638 * One reason to prefer the doYouWantToGC/allocate interface is to
1639 * support operations which allocate an unknown amount in the heap
1640 * (array ops, gmp ops, etc)
1641 * ------------------------------------------------------------------------*/
1643 static inline StgPtr grabHpUpd( nat size )
1645 ASSERT( size >= MIN_UPD_SIZE + sizeofW(StgHeader) );
1646 #ifdef CRUDE_PROFILING
1647 cp_bill_words ( size );
1649 return allocate(size);
1652 static inline StgPtr grabHpNonUpd( nat size )
1654 ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
1655 #ifdef CRUDE_PROFILING
1656 cp_bill_words ( size );
1658 return allocate(size);
1661 /* --------------------------------------------------------------------------
1662 * Manipulate "update frame" list:
1663 * o Update frames (based on stg_do_update and friends in Updates.hc)
1664 * o Error handling/catching (based on catchzh_fast and friends in Prims.hc)
1665 * o Seq frames (based on seq_frame_entry in Prims.hc)
1667 * ------------------------------------------------------------------------*/
1669 static inline void PopUpdateFrame ( StgClosure* obj )
1671 /* NB: doesn't assume that gSp == gSu */
1673 fprintf(stderr, "Updating ");
1674 printPtr(stgCast(StgPtr,gSu->updatee));
1675 fprintf(stderr, " with ");
1677 fprintf(stderr,"gSp = %p\tgSu = %p\n\n", gSp, gSu);
1679 #ifdef EAGER_BLACKHOLING
1680 #warn LAZY_BLACKHOLING is default for StgHugs
1681 #error Dont know if EAGER_BLACKHOLING works in StgHugs
1682 ASSERT(get_itbl(gSu->updatee)->type == BLACKHOLE
1683 || get_itbl(gSu->updatee)->type == SE_BLACKHOLE
1684 || get_itbl(gSu->updatee)->type == CAF_BLACKHOLE
1685 || get_itbl(gSu->updatee)->type == SE_CAF_BLACKHOLE
1687 #endif /* EAGER_BLACKHOLING */
1688 UPD_IND(gSu->updatee,obj);
1689 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgUpdateFrame);
1693 static inline void PopStopFrame ( StgClosure* obj )
1695 /* Move gSu just off the end of the stack, we're about to gSpam the
1696 * STOP_FRAME with the return value.
1698 gSu = stgCast(StgUpdateFrame*,gSp+1);
1699 *stgCast(StgClosure**,gSp) = obj;
1702 static inline void PushCatchFrame ( StgClosure* handler )
1705 /* ToDo: stack check! */
1706 gSp -= sizeofW(StgCatchFrame);
1707 fp = stgCast(StgCatchFrame*,gSp);
1708 SET_HDR(fp,(StgInfoTable*)&catch_frame_info,CCCS);
1709 fp->handler = handler;
1711 gSu = stgCast(StgUpdateFrame*,fp);
1714 static inline void PopCatchFrame ( void )
1716 /* NB: doesn't assume that gSp == gSu */
1717 /* fprintf(stderr,"Popping catch frame\n"); */
1718 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgCatchFrame);
1719 gSu = stgCast(StgCatchFrame*,gSu)->link;
1722 static inline void PushSeqFrame ( void )
1725 /* ToDo: stack check! */
1726 gSp -= sizeofW(StgSeqFrame);
1727 fp = stgCast(StgSeqFrame*,gSp);
1728 SET_HDR(fp,(StgInfoTable*)&seq_frame_info,CCCS);
1730 gSu = stgCast(StgUpdateFrame*,fp);
1733 static inline void PopSeqFrame ( void )
1735 /* NB: doesn't assume that gSp == gSu */
1736 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgSeqFrame);
1737 gSu = stgCast(StgSeqFrame*,gSu)->link;
1740 static inline StgClosure* raiseAnError ( StgClosure* exception )
1742 /* This closure represents the expression 'primRaise E' where E
1743 * is the exception raised (:: Exception).
1744 * It is used to overwrite all the
1745 * thunks which are currently under evaluation.
1747 HaskellObj primRaiseClosure
1748 = asmClosureOfObject(getHugs_AsmObject_for("primRaise"));
1749 HaskellObj reraiseClosure
1750 = rts_apply ( primRaiseClosure, exception );
1753 switch (get_itbl(gSu)->type) {
1755 UPD_IND(gSu->updatee,reraiseClosure);
1756 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgUpdateFrame);
1762 case CATCH_FRAME: /* found it! */
1764 StgCatchFrame* fp = stgCast(StgCatchFrame*,gSu);
1765 StgClosure *handler = fp->handler;
1767 gSp += sizeofW(StgCatchFrame); /* Pop */
1768 PushCPtr(exception);
1772 barf("raiseError: uncaught exception: STOP_FRAME");
1774 barf("raiseError: weird activation record");
1780 static StgClosure* makeErrorCall ( const char* msg )
1782 /* Note! the msg string should be allocated in a
1783 place which will not get freed -- preferably
1784 read-only data of the program. That's because
1785 the thunk we build here may linger indefinitely.
1786 (thinks: probably not so, but anyway ...)
1789 = asmClosureOfObject(getHugs_AsmObject_for("error"));
1791 = asmClosureOfObject(getHugs_AsmObject_for("hugsprimUnpackString"));
1793 = rts_apply ( unpack, rts_mkAddr ( (void*)msg ) );
1795 = rts_apply ( error, thunk );
1797 (StgClosure*) thunk;
1800 #define raiseIndex(where) makeErrorCall("Array index out of range in " where)
1801 #define raiseDiv0(where) makeErrorCall("Division by zero in " where)
1803 /* --------------------------------------------------------------------------
1805 * ------------------------------------------------------------------------*/
1807 #define OP_CC_B(e) \
1809 unsigned char x = PopTaggedChar(); \
1810 unsigned char y = PopTaggedChar(); \
1811 PushTaggedBool(e); \
1816 unsigned char x = PopTaggedChar(); \
1825 #define OP_IW_I(e) \
1827 StgInt x = PopTaggedInt(); \
1828 StgWord y = PopTaggedWord(); \
1832 #define OP_II_I(e) \
1834 StgInt x = PopTaggedInt(); \
1835 StgInt y = PopTaggedInt(); \
1839 #define OP_II_B(e) \
1841 StgInt x = PopTaggedInt(); \
1842 StgInt y = PopTaggedInt(); \
1843 PushTaggedBool(e); \
1848 PushTaggedAddr(e); \
1853 StgInt x = PopTaggedInt(); \
1854 PushTaggedAddr(e); \
1859 StgInt x = PopTaggedInt(); \
1865 PushTaggedChar(e); \
1870 StgInt x = PopTaggedInt(); \
1871 PushTaggedChar(e); \
1876 PushTaggedWord(e); \
1881 StgInt x = PopTaggedInt(); \
1882 PushTaggedWord(e); \
1887 StgInt x = PopTaggedInt(); \
1888 PushTaggedStablePtr(e); \
1893 PushTaggedFloat(e); \
1898 StgInt x = PopTaggedInt(); \
1899 PushTaggedFloat(e); \
1904 PushTaggedDouble(e); \
1909 StgInt x = PopTaggedInt(); \
1910 PushTaggedDouble(e); \
1913 #define OP_WW_B(e) \
1915 StgWord x = PopTaggedWord(); \
1916 StgWord y = PopTaggedWord(); \
1917 PushTaggedBool(e); \
1920 #define OP_WW_W(e) \
1922 StgWord x = PopTaggedWord(); \
1923 StgWord y = PopTaggedWord(); \
1924 PushTaggedWord(e); \
1929 StgWord x = PopTaggedWord(); \
1935 StgStablePtr x = PopTaggedStablePtr(); \
1941 StgWord x = PopTaggedWord(); \
1942 PushTaggedWord(e); \
1945 #define OP_AA_B(e) \
1947 StgAddr x = PopTaggedAddr(); \
1948 StgAddr y = PopTaggedAddr(); \
1949 PushTaggedBool(e); \
1953 StgAddr x = PopTaggedAddr(); \
1956 #define OP_AI_C(s) \
1958 StgAddr x = PopTaggedAddr(); \
1959 int y = PopTaggedInt(); \
1962 PushTaggedChar(r); \
1964 #define OP_AI_I(s) \
1966 StgAddr x = PopTaggedAddr(); \
1967 int y = PopTaggedInt(); \
1972 #define OP_AI_A(s) \
1974 StgAddr x = PopTaggedAddr(); \
1975 int y = PopTaggedInt(); \
1978 PushTaggedAddr(s); \
1980 #define OP_AI_F(s) \
1982 StgAddr x = PopTaggedAddr(); \
1983 int y = PopTaggedInt(); \
1986 PushTaggedFloat(r); \
1988 #define OP_AI_D(s) \
1990 StgAddr x = PopTaggedAddr(); \
1991 int y = PopTaggedInt(); \
1994 PushTaggedDouble(r); \
1996 #define OP_AI_s(s) \
1998 StgAddr x = PopTaggedAddr(); \
1999 int y = PopTaggedInt(); \
2002 PushTaggedStablePtr(r); \
2004 #define OP_AIC_(s) \
2006 StgAddr x = PopTaggedAddr(); \
2007 int y = PopTaggedInt(); \
2008 StgChar z = PopTaggedChar(); \
2011 #define OP_AII_(s) \
2013 StgAddr x = PopTaggedAddr(); \
2014 int y = PopTaggedInt(); \
2015 StgInt z = PopTaggedInt(); \
2018 #define OP_AIA_(s) \
2020 StgAddr x = PopTaggedAddr(); \
2021 int y = PopTaggedInt(); \
2022 StgAddr z = PopTaggedAddr(); \
2025 #define OP_AIF_(s) \
2027 StgAddr x = PopTaggedAddr(); \
2028 int y = PopTaggedInt(); \
2029 StgFloat z = PopTaggedFloat(); \
2032 #define OP_AID_(s) \
2034 StgAddr x = PopTaggedAddr(); \
2035 int y = PopTaggedInt(); \
2036 StgDouble z = PopTaggedDouble(); \
2039 #define OP_AIs_(s) \
2041 StgAddr x = PopTaggedAddr(); \
2042 int y = PopTaggedInt(); \
2043 StgStablePtr z = PopTaggedStablePtr(); \
2048 #define OP_FF_B(e) \
2050 StgFloat x = PopTaggedFloat(); \
2051 StgFloat y = PopTaggedFloat(); \
2052 PushTaggedBool(e); \
2055 #define OP_FF_F(e) \
2057 StgFloat x = PopTaggedFloat(); \
2058 StgFloat y = PopTaggedFloat(); \
2059 PushTaggedFloat(e); \
2064 StgFloat x = PopTaggedFloat(); \
2065 PushTaggedFloat(e); \
2070 StgFloat x = PopTaggedFloat(); \
2071 PushTaggedBool(e); \
2076 StgFloat x = PopTaggedFloat(); \
2082 StgFloat x = PopTaggedFloat(); \
2083 PushTaggedDouble(e); \
2086 #define OP_DD_B(e) \
2088 StgDouble x = PopTaggedDouble(); \
2089 StgDouble y = PopTaggedDouble(); \
2090 PushTaggedBool(e); \
2093 #define OP_DD_D(e) \
2095 StgDouble x = PopTaggedDouble(); \
2096 StgDouble y = PopTaggedDouble(); \
2097 PushTaggedDouble(e); \
2102 StgDouble x = PopTaggedDouble(); \
2103 PushTaggedBool(e); \
2108 StgDouble x = PopTaggedDouble(); \
2109 PushTaggedDouble(e); \
2114 StgDouble x = PopTaggedDouble(); \
2120 StgDouble x = PopTaggedDouble(); \
2121 PushTaggedFloat(e); \
2125 StgPtr CreateByteArrayToHoldInteger ( int nbytes )
2127 StgWord words = (nbytes+sizeof(W_)-1)/sizeof(W_);
2128 StgWord size = sizeofW(StgArrWords) + words;
2129 StgArrWords* arr = (StgArrWords*)allocate(size);
2130 SET_HDR(arr,&ARR_WORDS_info,CCCS);
2132 ASSERT((W_)nbytes <= arr->words * sizeof(W_));
2135 for (i = 0; i < words; ++i) {
2136 arr->payload[i] = 0xdeadbeef;
2138 { B* b = (B*) &(arr->payload[0]);
2139 b->used = b->sign = 0;
2145 B* IntegerInsideByteArray ( StgPtr arr0 )
2148 StgArrWords* arr = (StgArrWords*)arr0;
2149 ASSERT(GET_INFO(arr) == &ARR_WORDS_info);
2150 b = (B*) &(arr->payload[0]);
2154 void SloppifyIntegerEnd ( StgPtr arr0 )
2156 StgArrWords* arr = (StgArrWords*)arr0;
2157 B* b = (B*) & (arr->payload[0]);
2158 I_ nwunused = arr->words - sizeofW(B) - (b->used+sizeof(W_)-1)/sizeof(W_);
2159 if (nwunused >= ((I_)sizeofW(StgArrWords))) {
2161 b->size -= nwunused * sizeof(W_);
2162 if (b->size < b->used) b->size = b->used;
2165 arr->words -= nwunused;
2166 slop = (StgArrWords*)&(arr->payload[arr->words]);
2167 SET_HDR(slop,&ARR_WORDS_info,CCCS);
2168 slop->words = nwunused - sizeofW(StgArrWords);
2169 ASSERT( &(slop->payload[slop->words]) ==
2170 &(arr->payload[arr->words + nwunused]) );
2174 #define OP_Z_Z(op) \
2176 B* x = IntegerInsideByteArray(PopPtr()); \
2177 int n = mycat2(size_,op)(x); \
2178 StgPtr p = CreateByteArrayToHoldInteger(n); \
2179 mycat2(do_,op)(x,n,IntegerInsideByteArray(p)); \
2180 SloppifyIntegerEnd(p); \
2183 #define OP_ZZ_Z(op) \
2185 B* x = IntegerInsideByteArray(PopPtr()); \
2186 B* y = IntegerInsideByteArray(PopPtr()); \
2187 int n = mycat2(size_,op)(x,y); \
2188 StgPtr p = CreateByteArrayToHoldInteger(n); \
2189 mycat2(do_,op)(x,y,n,IntegerInsideByteArray(p)); \
2190 SloppifyIntegerEnd(p); \
2197 #define HEADER_mI(ty,where) \
2198 StgArrWords* x = stgCast(StgArrWords*,PopPtr()); \
2199 nat i = PopTaggedInt(); \
2200 if (i * sizeof(ty) + (sizeof(ty)) > sizeof(StgWord) * x->words) { \
2201 return (raiseIndex(where)); \
2203 #define OP_mI_ty(ty,where,s) \
2205 HEADER_mI(mycat2(Stg,ty),where) \
2206 { mycat2(Stg,ty) r; \
2208 mycat2(PushTagged,ty)(r); \
2211 #define OP_mIty_(ty,where,s) \
2213 HEADER_mI(mycat2(Stg,ty),where) \
2215 mycat2(Stg,ty) z = mycat2(PopTagged,ty)(); \
2221 static void myStackCheck ( Capability* cap )
2223 /* fprintf(stderr, "myStackCheck\n"); */
2224 if (!(gSpLim <= gSp && gSp <= stgCast(StgPtr,gSu))) {
2225 fprintf(stderr, "myStackCheck: invalid initial gSp/gSu \n" );
2229 if (!( (P_)gSu >= (P_)cap->rCurrentTSO->stack
2231 (P_)gSu <= (P_)(cap->rCurrentTSO->stack
2232 + cap->rCurrentTSO->stack_size))) {
2233 fprintf ( stderr, "myStackCheck: gSu out of stack\n" );
2236 switch (get_itbl(stgCast(StgClosure*,gSu))->type) {
2238 gSu = (StgUpdateFrame*) ((StgCatchFrame*)(gSu))->link;
2241 gSu = (StgUpdateFrame*) ((StgUpdateFrame*)(gSu))->link;
2244 gSu = (StgUpdateFrame*) ((StgSeqFrame*)(gSu))->link;
2249 fprintf(stderr, "myStackCheck: invalid activation record\n"); assert(0);
2256 /* --------------------------------------------------------------------------
2257 * Primop stuff for bytecode interpreter
2258 * ------------------------------------------------------------------------*/
2260 /* Returns & of the next thing to enter (if throwing an exception),
2261 or NULL in the normal case.
2263 static void* enterBCO_primop1 ( int primop1code )
2266 barf("enterBCO_primop1 in combined mode");
2268 switch (primop1code) {
2269 case i_pushseqframe:
2271 StgClosure* c = PopCPtr();
2276 case i_pushcatchframe:
2278 StgClosure* e = PopCPtr();
2279 StgClosure* h = PopCPtr();
2285 case i_gtChar: OP_CC_B(x>y); break;
2286 case i_geChar: OP_CC_B(x>=y); break;
2287 case i_eqChar: OP_CC_B(x==y); break;
2288 case i_neChar: OP_CC_B(x!=y); break;
2289 case i_ltChar: OP_CC_B(x<y); break;
2290 case i_leChar: OP_CC_B(x<=y); break;
2291 case i_charToInt: OP_C_I(x); break;
2292 case i_intToChar: OP_I_C(x); break;
2294 case i_gtInt: OP_II_B(x>y); break;
2295 case i_geInt: OP_II_B(x>=y); break;
2296 case i_eqInt: OP_II_B(x==y); break;
2297 case i_neInt: OP_II_B(x!=y); break;
2298 case i_ltInt: OP_II_B(x<y); break;
2299 case i_leInt: OP_II_B(x<=y); break;
2300 case i_minInt: OP__I(INT_MIN); break;
2301 case i_maxInt: OP__I(INT_MAX); break;
2302 case i_plusInt: OP_II_I(x+y); break;
2303 case i_minusInt: OP_II_I(x-y); break;
2304 case i_timesInt: OP_II_I(x*y); break;
2307 int x = PopTaggedInt();
2308 int y = PopTaggedInt();
2310 return (raiseDiv0("quotInt"));
2312 /* ToDo: protect against minInt / -1 errors
2313 * (repeat for all other division primops) */
2319 int x = PopTaggedInt();
2320 int y = PopTaggedInt();
2322 return (raiseDiv0("remInt"));
2329 StgInt x = PopTaggedInt();
2330 StgInt y = PopTaggedInt();
2332 return (raiseDiv0("quotRemInt"));
2334 PushTaggedInt(x%y); /* last result */
2335 PushTaggedInt(x/y); /* first result */
2338 case i_negateInt: OP_I_I(-x); break;
2340 case i_andInt: OP_II_I(x&y); break;
2341 case i_orInt: OP_II_I(x|y); break;
2342 case i_xorInt: OP_II_I(x^y); break;
2343 case i_notInt: OP_I_I(~x); break;
2344 case i_shiftLInt: OP_II_I(x<<y); break;
2345 case i_shiftRAInt: OP_II_I(x>>y); break; /* ToDo */
2346 case i_shiftRLInt: OP_II_I(x>>y); break; /* ToDo */
2348 case i_gtWord: OP_WW_B(x>y); break;
2349 case i_geWord: OP_WW_B(x>=y); break;
2350 case i_eqWord: OP_WW_B(x==y); break;
2351 case i_neWord: OP_WW_B(x!=y); break;
2352 case i_ltWord: OP_WW_B(x<y); break;
2353 case i_leWord: OP_WW_B(x<=y); break;
2354 case i_minWord: OP__W(0); break;
2355 case i_maxWord: OP__W(UINT_MAX); break;
2356 case i_plusWord: OP_WW_W(x+y); break;
2357 case i_minusWord: OP_WW_W(x-y); break;
2358 case i_timesWord: OP_WW_W(x*y); break;
2361 StgWord x = PopTaggedWord();
2362 StgWord y = PopTaggedWord();
2364 return (raiseDiv0("quotWord"));
2366 PushTaggedWord(x/y);
2371 StgWord x = PopTaggedWord();
2372 StgWord y = PopTaggedWord();
2374 return (raiseDiv0("remWord"));
2376 PushTaggedWord(x%y);
2381 StgWord x = PopTaggedWord();
2382 StgWord y = PopTaggedWord();
2384 return (raiseDiv0("quotRemWord"));
2386 PushTaggedWord(x%y); /* last result */
2387 PushTaggedWord(x/y); /* first result */
2390 case i_negateWord: OP_W_W(-x); break;
2391 case i_andWord: OP_WW_W(x&y); break;
2392 case i_orWord: OP_WW_W(x|y); break;
2393 case i_xorWord: OP_WW_W(x^y); break;
2394 case i_notWord: OP_W_W(~x); break;
2395 case i_shiftLWord: OP_WW_W(x<<y); break;
2396 case i_shiftRAWord: OP_WW_W(x>>y); break; /* ToDo */
2397 case i_shiftRLWord: OP_WW_W(x>>y); break; /* ToDo */
2398 case i_intToWord: OP_I_W(x); break;
2399 case i_wordToInt: OP_W_I(x); break;
2401 case i_gtAddr: OP_AA_B(x>y); break;
2402 case i_geAddr: OP_AA_B(x>=y); break;
2403 case i_eqAddr: OP_AA_B(x==y); break;
2404 case i_neAddr: OP_AA_B(x!=y); break;
2405 case i_ltAddr: OP_AA_B(x<y); break;
2406 case i_leAddr: OP_AA_B(x<=y); break;
2407 case i_intToAddr: OP_I_A((StgAddr)x); break; /* ToDo */
2408 case i_addrToInt: OP_A_I((StgInt)x); break; /* ToDo */
2410 case i_intToStable: OP_I_s(x); break;
2411 case i_stableToInt: OP_s_I(x); break;
2413 case i_indexCharOffAddr: OP_AI_C(indexCharOffAddrzh(r,x,y)); break;
2414 case i_readCharOffAddr: OP_AI_C(indexCharOffAddrzh(r,x,y)); break;
2415 case i_writeCharOffAddr: OP_AIC_(writeCharOffAddrzh(x,y,z)); break;
2417 case i_indexIntOffAddr: OP_AI_I(indexIntOffAddrzh(r,x,y)); break;
2418 case i_readIntOffAddr: OP_AI_I(indexIntOffAddrzh(r,x,y)); break;
2419 case i_writeIntOffAddr: OP_AII_(writeIntOffAddrzh(x,y,z)); break;
2421 case i_indexAddrOffAddr: OP_AI_A(indexAddrOffAddrzh(r,x,y)); break;
2422 case i_readAddrOffAddr: OP_AI_A(indexAddrOffAddrzh(r,x,y)); break;
2423 case i_writeAddrOffAddr: OP_AIA_(writeAddrOffAddrzh(x,y,z)); break;
2425 case i_indexFloatOffAddr: OP_AI_F(indexFloatOffAddrzh(r,x,y)); break;
2426 case i_readFloatOffAddr: OP_AI_F(indexFloatOffAddrzh(r,x,y)); break;
2427 case i_writeFloatOffAddr: OP_AIF_(writeFloatOffAddrzh(x,y,z)); break;
2429 case i_indexDoubleOffAddr: OP_AI_D(indexDoubleOffAddrzh(r,x,y)); break;
2430 case i_readDoubleOffAddr: OP_AI_D(indexDoubleOffAddrzh(r,x,y)); break;
2431 case i_writeDoubleOffAddr: OP_AID_(writeDoubleOffAddrzh(x,y,z)); break;
2433 case i_indexStableOffAddr: OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break;
2434 case i_readStableOffAddr: OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break;
2435 case i_writeStableOffAddr: OP_AIs_(writeStablePtrOffAddrzh(x,y,z)); break;
2437 case i_compareInteger:
2439 B* x = IntegerInsideByteArray(PopPtr());
2440 B* y = IntegerInsideByteArray(PopPtr());
2441 StgInt r = do_cmp(x,y);
2442 PushTaggedInt(r<0 ? -1 : (r>0 ? 1 : 0));
2445 case i_negateInteger: OP_Z_Z(neg); break;
2446 case i_plusInteger: OP_ZZ_Z(add); break;
2447 case i_minusInteger: OP_ZZ_Z(sub); break;
2448 case i_timesInteger: OP_ZZ_Z(mul); break;
2449 case i_quotRemInteger:
2451 B* x = IntegerInsideByteArray(PopPtr());
2452 B* y = IntegerInsideByteArray(PopPtr());
2453 int n = size_qrm(x,y);
2454 StgPtr q = CreateByteArrayToHoldInteger(n);
2455 StgPtr r = CreateByteArrayToHoldInteger(n);
2456 if (do_getsign(y)==0)
2457 return (raiseDiv0("quotRemInteger"));
2458 do_qrm(x,y,n,IntegerInsideByteArray(q),
2459 IntegerInsideByteArray(r));
2460 SloppifyIntegerEnd(q);
2461 SloppifyIntegerEnd(r);
2466 case i_intToInteger:
2468 int n = size_fromInt();
2469 StgPtr p = CreateByteArrayToHoldInteger(n);
2470 do_fromInt( PopTaggedInt(), n, IntegerInsideByteArray(p));
2474 case i_wordToInteger:
2476 int n = size_fromWord();
2477 StgPtr p = CreateByteArrayToHoldInteger(n);
2478 do_fromWord( PopTaggedWord(), n, IntegerInsideByteArray(p));
2482 case i_integerToInt: PushTaggedInt(do_toInt(
2483 IntegerInsideByteArray(PopPtr())
2487 case i_integerToWord: PushTaggedWord(do_toWord(
2488 IntegerInsideByteArray(PopPtr())
2492 case i_integerToFloat: PushTaggedFloat(do_toFloat(
2493 IntegerInsideByteArray(PopPtr())
2497 case i_integerToDouble: PushTaggedDouble(do_toDouble(
2498 IntegerInsideByteArray(PopPtr())
2502 case i_gtFloat: OP_FF_B(x>y); break;
2503 case i_geFloat: OP_FF_B(x>=y); break;
2504 case i_eqFloat: OP_FF_B(x==y); break;
2505 case i_neFloat: OP_FF_B(x!=y); break;
2506 case i_ltFloat: OP_FF_B(x<y); break;
2507 case i_leFloat: OP_FF_B(x<=y); break;
2508 case i_minFloat: OP__F(FLT_MIN); break;
2509 case i_maxFloat: OP__F(FLT_MAX); break;
2510 case i_radixFloat: OP__I(FLT_RADIX); break;
2511 case i_digitsFloat: OP__I(FLT_MANT_DIG); break;
2512 case i_minExpFloat: OP__I(FLT_MIN_EXP); break;
2513 case i_maxExpFloat: OP__I(FLT_MAX_EXP); break;
2514 case i_plusFloat: OP_FF_F(x+y); break;
2515 case i_minusFloat: OP_FF_F(x-y); break;
2516 case i_timesFloat: OP_FF_F(x*y); break;
2519 StgFloat x = PopTaggedFloat();
2520 StgFloat y = PopTaggedFloat();
2521 PushTaggedFloat(x/y);
2524 case i_negateFloat: OP_F_F(-x); break;
2525 case i_floatToInt: OP_F_I(x); break;
2526 case i_intToFloat: OP_I_F(x); break;
2527 case i_expFloat: OP_F_F(exp(x)); break;
2528 case i_logFloat: OP_F_F(log(x)); break;
2529 case i_sqrtFloat: OP_F_F(sqrt(x)); break;
2530 case i_sinFloat: OP_F_F(sin(x)); break;
2531 case i_cosFloat: OP_F_F(cos(x)); break;
2532 case i_tanFloat: OP_F_F(tan(x)); break;
2533 case i_asinFloat: OP_F_F(asin(x)); break;
2534 case i_acosFloat: OP_F_F(acos(x)); break;
2535 case i_atanFloat: OP_F_F(atan(x)); break;
2536 case i_sinhFloat: OP_F_F(sinh(x)); break;
2537 case i_coshFloat: OP_F_F(cosh(x)); break;
2538 case i_tanhFloat: OP_F_F(tanh(x)); break;
2539 case i_powerFloat: OP_FF_F(pow(x,y)); break;
2541 case i_encodeFloatZ:
2543 StgPtr sig = PopPtr();
2544 StgInt exp = PopTaggedInt();
2546 B__encodeFloat(IntegerInsideByteArray(sig), exp)
2550 case i_decodeFloatZ:
2552 StgFloat f = PopTaggedFloat();
2553 StgPtr sig = CreateByteArrayToHoldInteger(size_fltmantissa());
2555 B__decodeFloat(IntegerInsideByteArray(sig), &exp, f);
2561 case i_isNaNFloat: OP_F_B(isFloatNaN(x)); break;
2562 case i_isInfiniteFloat: OP_F_B(isFloatInfinite(x)); break;
2563 case i_isNegativeZeroFloat: OP_F_B(isFloatNegativeZero(x)); break;
2564 case i_isDenormalizedFloat: OP_F_B(isFloatDenormalized(x)); break;
2565 case i_gtDouble: OP_DD_B(x>y); break;
2566 case i_geDouble: OP_DD_B(x>=y); break;
2567 case i_eqDouble: OP_DD_B(x==y); break;
2568 case i_neDouble: OP_DD_B(x!=y); break;
2569 case i_ltDouble: OP_DD_B(x<y); break;
2570 case i_leDouble: OP_DD_B(x<=y) break;
2571 case i_minDouble: OP__D(DBL_MIN); break;
2572 case i_maxDouble: OP__D(DBL_MAX); break;
2573 case i_radixDouble: OP__I(FLT_RADIX); break;
2574 case i_digitsDouble: OP__I(DBL_MANT_DIG); break;
2575 case i_minExpDouble: OP__I(DBL_MIN_EXP); break;
2576 case i_maxExpDouble: OP__I(DBL_MAX_EXP); break;
2577 case i_plusDouble: OP_DD_D(x+y); break;
2578 case i_minusDouble: OP_DD_D(x-y); break;
2579 case i_timesDouble: OP_DD_D(x*y); break;
2580 case i_divideDouble:
2582 StgDouble x = PopTaggedDouble();
2583 StgDouble y = PopTaggedDouble();
2584 PushTaggedDouble(x/y);
2587 case i_negateDouble: OP_D_D(-x); break;
2588 case i_doubleToInt: OP_D_I(x); break;
2589 case i_intToDouble: OP_I_D(x); break;
2590 case i_doubleToFloat: OP_D_F(x); break;
2591 case i_floatToDouble: OP_F_F(x); break;
2592 case i_expDouble: OP_D_D(exp(x)); break;
2593 case i_logDouble: OP_D_D(log(x)); break;
2594 case i_sqrtDouble: OP_D_D(sqrt(x)); break;
2595 case i_sinDouble: OP_D_D(sin(x)); break;
2596 case i_cosDouble: OP_D_D(cos(x)); break;
2597 case i_tanDouble: OP_D_D(tan(x)); break;
2598 case i_asinDouble: OP_D_D(asin(x)); break;
2599 case i_acosDouble: OP_D_D(acos(x)); break;
2600 case i_atanDouble: OP_D_D(atan(x)); break;
2601 case i_sinhDouble: OP_D_D(sinh(x)); break;
2602 case i_coshDouble: OP_D_D(cosh(x)); break;
2603 case i_tanhDouble: OP_D_D(tanh(x)); break;
2604 case i_powerDouble: OP_DD_D(pow(x,y)); break;
2606 case i_encodeDoubleZ:
2608 StgPtr sig = PopPtr();
2609 StgInt exp = PopTaggedInt();
2611 B__encodeDouble(IntegerInsideByteArray(sig), exp)
2615 case i_decodeDoubleZ:
2617 StgDouble d = PopTaggedDouble();
2618 StgPtr sig = CreateByteArrayToHoldInteger(size_dblmantissa());
2620 B__decodeDouble(IntegerInsideByteArray(sig), &exp, d);
2626 case i_isNaNDouble: OP_D_B(isDoubleNaN(x)); break;
2627 case i_isInfiniteDouble: OP_D_B(isDoubleInfinite(x)); break;
2628 case i_isNegativeZeroDouble: OP_D_B(isDoubleNegativeZero(x)); break;
2629 case i_isDenormalizedDouble: OP_D_B(isDoubleDenormalized(x)); break;
2630 case i_isIEEEDouble:
2632 PushTaggedBool(rtsTrue);
2636 barf("Unrecognised primop1");
2643 /* For normal cases, return NULL and leave *return2 unchanged.
2644 To return the address of the next thing to enter,
2645 return the address of it and leave *return2 unchanged.
2646 To return a StgThreadReturnCode to the scheduler,
2647 set *return2 to it and return a non-NULL value.
2649 static void* enterBCO_primop2 ( int primop2code,
2650 int* /*StgThreadReturnCode* */ return2,
2655 /* A small concession: we need to allow ccalls,
2656 even in combined mode.
2658 if (primop2code != i_ccall_ccall_IO &&
2659 primop2code != i_ccall_stdcall_IO)
2660 barf("enterBCO_primop2 in combined mode");
2663 switch (primop2code) {
2664 case i_raise: /* raise#{err} */
2666 StgClosure* err = PopCPtr();
2667 return (raiseAnError(err));
2672 StgClosure* init = PopCPtr();
2674 = stgCast(StgMutVar*,allocate(sizeofW(StgMutVar)));
2675 SET_HDR(mv,&MUT_VAR_info,CCCS);
2677 PushPtr(stgCast(StgPtr,mv));
2682 StgMutVar* mv = stgCast(StgMutVar*,PopPtr());
2688 StgMutVar* mv = stgCast(StgMutVar*,PopPtr());
2689 StgClosure* value = PopCPtr();
2695 nat n = PopTaggedInt(); /* or Word?? */
2696 StgClosure* init = PopCPtr();
2697 StgWord size = sizeofW(StgMutArrPtrs) + n;
2700 = stgCast(StgMutArrPtrs*,allocate(size));
2701 SET_HDR(arr,&MUT_ARR_PTRS_info,CCCS);
2703 for (i = 0; i < n; ++i) {
2704 arr->payload[i] = init;
2706 PushPtr(stgCast(StgPtr,arr));
2712 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2713 nat i = PopTaggedInt(); /* or Word?? */
2714 StgWord n = arr->ptrs;
2716 return (raiseIndex("{index,read}Array"));
2718 PushCPtr(arr->payload[i]);
2723 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2724 nat i = PopTaggedInt(); /* or Word? */
2725 StgClosure* v = PopCPtr();
2726 StgWord n = arr->ptrs;
2728 return (raiseIndex("{index,read}Array"));
2730 arr->payload[i] = v;
2734 case i_sizeMutableArray:
2736 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2737 PushTaggedInt(arr->ptrs);
2740 case i_unsafeFreezeArray:
2742 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2743 SET_INFO(arr,&MUT_ARR_PTRS_FROZEN_info);
2744 PushPtr(stgCast(StgPtr,arr));
2747 case i_unsafeFreezeByteArray:
2749 /* Delightfully simple :-) */
2753 case i_sameMutableArray:
2754 case i_sameMutableByteArray:
2756 StgPtr x = PopPtr();
2757 StgPtr y = PopPtr();
2758 PushTaggedBool(x==y);
2762 case i_newByteArray:
2764 nat n = PopTaggedInt(); /* or Word?? */
2765 StgInt words = (n+sizeof(W_)-1)/sizeof(W_);
2766 StgWord size = sizeofW(StgArrWords) + words;
2767 StgArrWords* arr = stgCast(StgArrWords*,allocate(size));
2768 SET_HDR(arr,&ARR_WORDS_info,CCCS);
2772 for (i = 0; i < n; ++i) {
2773 arr->payload[i] = 0xdeadbeef;
2776 PushPtr(stgCast(StgPtr,arr));
2780 /* Most of these generate alignment warnings on Sparcs and similar architectures.
2781 * These are harmless and are caused by the cast to C* in BYTE_ARR_CTS.
2783 case i_indexCharArray:
2784 OP_mI_ty(Char,"indexCharArray", indexCharArrayzh(r,x,i)); break;
2785 case i_readCharArray:
2786 OP_mI_ty(Char,"readCharArray", readCharArrayzh(r,x,i)); break;
2787 case i_writeCharArray:
2788 OP_mIty_(Char,"writeCharArray", writeCharArrayzh(x,i,z)); break;
2790 case i_indexIntArray:
2791 OP_mI_ty(Int,"indexIntArray", indexIntArrayzh(r,x,i)); break;
2792 case i_readIntArray:
2793 OP_mI_ty(Int,"readIntArray", readIntArrayzh(r,x,i)); break;
2794 case i_writeIntArray:
2795 OP_mIty_(Int,"writeIntArray", writeIntArrayzh(x,i,z)); break;
2797 case i_indexAddrArray:
2798 OP_mI_ty(Addr,"indexAddrArray", indexAddrArrayzh(r,x,i)); break;
2799 case i_readAddrArray:
2800 OP_mI_ty(Addr,"readAddrArray", readAddrArrayzh(r,x,i)); break;
2801 case i_writeAddrArray:
2802 OP_mIty_(Addr,"writeAddrArray", writeAddrArrayzh(x,i,z)); break;
2804 case i_indexFloatArray:
2805 OP_mI_ty(Float,"indexFloatArray", indexFloatArrayzh(r,x,i)); break;
2806 case i_readFloatArray:
2807 OP_mI_ty(Float,"readFloatArray", readFloatArrayzh(r,x,i)); break;
2808 case i_writeFloatArray:
2809 OP_mIty_(Float,"writeFloatArray", writeFloatArrayzh(x,i,z)); break;
2811 case i_indexDoubleArray:
2812 OP_mI_ty(Double,"indexDoubleArray", indexDoubleArrayzh(r,x,i)); break;
2813 case i_readDoubleArray:
2814 OP_mI_ty(Double,"readDoubleArray", readDoubleArrayzh(r,x,i)); break;
2815 case i_writeDoubleArray:
2816 OP_mIty_(Double,"writeDoubleArray", writeDoubleArrayzh(x,i,z)); break;
2819 #ifdef PROVIDE_STABLE
2820 case i_indexStableArray:
2821 OP_mI_ty(StablePtr,"indexStableArray", indexStablePtrArrayzh(r,x,i)); break;
2822 case i_readStableArray:
2823 OP_mI_ty(StablePtr,"readStableArray", readStablePtrArrayzh(r,x,i)); break;
2824 case i_writeStableArray:
2825 OP_mIty_(StablePtr,"writeStableArray", writeStablePtrArrayzh(x,i,z)); break;
2831 #ifdef PROVIDE_COERCE
2832 case i_unsafeCoerce:
2834 /* Another nullop */
2838 #ifdef PROVIDE_PTREQUALITY
2839 case i_reallyUnsafePtrEquality:
2840 { /* identical to i_sameRef */
2841 StgPtr x = PopPtr();
2842 StgPtr y = PopPtr();
2843 PushTaggedBool(x==y);
2847 #ifdef PROVIDE_FOREIGN
2848 /* ForeignObj# operations */
2849 case i_makeForeignObj:
2851 StgForeignObj *result
2852 = stgCast(StgForeignObj*,allocate(sizeofW(StgForeignObj)));
2853 SET_HDR(result,&FOREIGN_info,CCCS);
2854 result -> data = PopTaggedAddr();
2855 PushPtr(stgCast(StgPtr,result));
2858 #endif /* PROVIDE_FOREIGN */
2863 = stgCast(StgWeak*,allocate(sizeofW(StgWeak)));
2864 SET_HDR(w, &WEAK_info, CCCS);
2866 w->value = PopCPtr();
2867 w->finaliser = PopCPtr();
2868 w->link = weak_ptr_list;
2870 IF_DEBUG(weak, fprintf(stderr,"New weak pointer at %p\n",w));
2871 PushPtr(stgCast(StgPtr,w));
2876 StgWeak *w = stgCast(StgWeak*,PopPtr());
2877 if (w->header.info == &WEAK_info) {
2878 PushCPtr(w->value); /* last result */
2879 PushTaggedInt(1); /* first result */
2881 PushPtr(stgCast(StgPtr,w));
2882 /* ToDo: error thunk would be better */
2887 #endif /* PROVIDE_WEAK */
2889 case i_makeStablePtr:
2891 StgPtr p = PopPtr();
2892 StgStablePtr sp = getStablePtr ( p );
2893 PushTaggedStablePtr(sp);
2896 case i_deRefStablePtr:
2899 StgStablePtr sp = PopTaggedStablePtr();
2900 p = deRefStablePtr(sp);
2904 case i_freeStablePtr:
2906 StgStablePtr sp = PopTaggedStablePtr();
2911 case i_createAdjThunkARCH:
2913 StgStablePtr stableptr = PopTaggedStablePtr();
2914 StgAddr typestr = PopTaggedAddr();
2915 StgChar callconv = PopTaggedChar();
2916 StgAddr adj_thunk = createAdjThunk(stableptr,typestr,callconv);
2917 PushTaggedAddr(adj_thunk);
2923 StgInt n = prog_argc;
2929 StgInt n = PopTaggedInt();
2930 StgAddr a = (StgAddr)prog_argv[n];
2937 StgMVar *mvar = stgCast(StgMVar*,allocate(sizeofW(StgMVar)));
2938 SET_INFO(mvar,&EMPTY_MVAR_info);
2939 mvar->head = mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
2940 mvar->value = stgCast(StgClosure*,&END_TSO_QUEUE_closure);
2941 PushPtr(stgCast(StgPtr,mvar));
2946 StgMVar *mvar = (StgMVar*)PopCPtr();
2947 if (GET_INFO(mvar) == &EMPTY_MVAR_info) {
2949 /* The MVar is empty. Attach ourselves to the TSO's
2952 if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
2953 mvar->head = cap->rCurrentTSO;
2955 mvar->tail->link = cap->rCurrentTSO;
2957 cap->rCurrentTSO->link = (StgTSO *)&END_TSO_QUEUE_closure;
2958 cap->rCurrentTSO->why_blocked = BlockedOnMVar;
2959 cap->rCurrentTSO->block_info.closure = (StgClosure *)mvar;
2960 mvar->tail = cap->rCurrentTSO;
2962 /* At this point, the top-of-stack holds the MVar,
2963 and underneath is the world token (). So the
2964 stack is in the same state as when primTakeMVar
2965 was entered (primTakeMVar is handwritten bytecode).
2966 Push obj, which is this BCO, and return to the
2967 scheduler. When the MVar is filled, the scheduler
2968 will re-enter primTakeMVar, with the args still on
2969 the top of the stack.
2971 PushCPtr((StgClosure*)(*bco));
2972 *return2 = ThreadBlocked;
2973 return (void*)(1+(char*)(NULL));
2976 PushCPtr(mvar->value);
2977 mvar->value = (StgClosure *)&END_TSO_QUEUE_closure;
2978 SET_INFO(mvar,&EMPTY_MVAR_info);
2984 StgMVar* mvar = stgCast(StgMVar*,PopPtr());
2985 StgClosure* value = PopCPtr();
2986 if (GET_INFO(mvar) == &FULL_MVAR_info) {
2987 return (makeErrorCall("putMVar {full MVar}"));
2989 /* wake up the first thread on the
2990 * queue, it will continue with the
2991 * takeMVar operation and mark the
2994 mvar->value = value;
2996 if (mvar->head != (StgTSO *)&END_TSO_QUEUE_closure) {
2997 ASSERT(mvar->head->why_blocked == BlockedOnMVar);
2998 mvar->head = unblockOne(mvar->head);
2999 if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
3000 mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
3004 /* unlocks the MVar in the SMP case */
3005 SET_INFO(mvar,&FULL_MVAR_info);
3007 /* yield for better communication performance */
3013 { /* identical to i_sameRef */
3014 StgMVar* x = (StgMVar*)PopPtr();
3015 StgMVar* y = (StgMVar*)PopPtr();
3016 PushTaggedBool(x==y);
3021 StgWord tid = cap->rCurrentTSO->id;
3022 PushTaggedWord(tid);
3025 case i_cmpThreadIds:
3027 StgWord tid1 = PopTaggedWord();
3028 StgWord tid2 = PopTaggedWord();
3029 if (tid1 < tid2) PushTaggedInt(-1);
3030 else if (tid1 > tid2) PushTaggedInt(1);
3031 else PushTaggedInt(0);
3036 StgClosure* closure;
3039 closure = PopCPtr();
3040 tso = createGenThread (RtsFlags.GcFlags.initialStkSize,closure);
3042 scheduleThread(tso);
3044 PushTaggedWord(tid);
3048 #ifdef PROVIDE_CONCURRENT
3051 StgTSO* tso = stgCast(StgTSO*,PopPtr());
3053 if (tso == cap->rCurrentTSO) { /* suicide */
3054 *return2 = ThreadFinished;
3055 return (void*)(1+(NULL));
3063 /* As PrimOps.h says: Hmm, I'll think about these later. */
3066 #endif /* PROVIDE_CONCURRENT */
3068 case i_ccall_ccall_Id:
3069 case i_ccall_ccall_IO:
3070 case i_ccall_stdcall_Id:
3071 case i_ccall_stdcall_IO:
3074 CFunDescriptor* descriptor;
3075 void (*funPtr)(void);
3077 descriptor = PopTaggedAddr();
3078 funPtr = PopTaggedAddr();
3079 cc = (primop2code == i_ccall_stdcall_Id ||
3080 primop2code == i_ccall_stdcall_IO)
3082 r = ccall(descriptor,funPtr,bco,cc,cap);
3085 return makeErrorCall(
3086 "unhandled type or too many args/results in ccall");
3088 barf("ccall not configured correctly for this platform");
3089 barf("unknown return code from ccall");
3092 barf("Unrecognised primop2");
3098 /* -----------------------------------------------------------------------------
3099 * ccall support code:
3100 * marshall moves args from C stack to Haskell stack
3101 * unmarshall moves args from Haskell stack to C stack
3102 * argSize calculates how much gSpace you need on the C stack
3103 * ---------------------------------------------------------------------------*/
3105 /* Pop arguments off the C stack and Push them onto the Hugs stack.
3106 * Used when preparing for C calling Haskell or in regSponse to
3107 * Haskell calling C.
3109 nat marshall(char arg_ty, void* arg)
3113 PushTaggedInt(*((int*)arg));
3114 return ARG_SIZE(INT_TAG);
3117 PushTaggedInteger(*((mpz_ptr*)arg));
3118 return ARG_SIZE(INTEGER_TAG);
3121 PushTaggedWord(*((unsigned int*)arg));
3122 return ARG_SIZE(WORD_TAG);
3124 PushTaggedChar(*((char*)arg));
3125 return ARG_SIZE(CHAR_TAG);
3127 PushTaggedFloat(*((float*)arg));
3128 return ARG_SIZE(FLOAT_TAG);
3130 PushTaggedDouble(*((double*)arg));
3131 return ARG_SIZE(DOUBLE_TAG);
3133 PushTaggedAddr(*((void**)arg));
3134 return ARG_SIZE(ADDR_TAG);
3136 PushTaggedStablePtr(*((StgStablePtr*)arg));
3137 return ARG_SIZE(STABLE_TAG);
3138 #ifdef PROVIDE_FOREIGN
3140 /* Not allowed in this direction - you have to
3141 * call makeForeignPtr explicitly
3143 barf("marshall: ForeignPtr#\n");
3148 /* Not allowed in this direction */
3149 barf("marshall: [Mutable]ByteArray#\n");
3152 barf("marshall: unrecognised arg type %d\n",arg_ty);
3157 /* Pop arguments off the Hugs stack and Push them onto the C stack.
3158 * Used when preparing for Haskell calling C or in regSponse to
3159 * C calling Haskell.
3161 nat unmarshall(char res_ty, void* res)
3165 *((int*)res) = PopTaggedInt();
3166 return ARG_SIZE(INT_TAG);
3169 *((mpz_ptr*)res) = PopTaggedInteger();
3170 return ARG_SIZE(INTEGER_TAG);
3173 *((unsigned int*)res) = PopTaggedWord();
3174 return ARG_SIZE(WORD_TAG);
3176 *((int*)res) = PopTaggedChar();
3177 return ARG_SIZE(CHAR_TAG);
3179 *((float*)res) = PopTaggedFloat();
3180 return ARG_SIZE(FLOAT_TAG);
3182 *((double*)res) = PopTaggedDouble();
3183 return ARG_SIZE(DOUBLE_TAG);
3185 *((void**)res) = PopTaggedAddr();
3186 return ARG_SIZE(ADDR_TAG);
3188 *((StgStablePtr*)res) = PopTaggedStablePtr();
3189 return ARG_SIZE(STABLE_TAG);
3190 #ifdef PROVIDE_FOREIGN
3193 StgForeignObj *result = stgCast(StgForeignObj*,PopPtr());
3194 *((void**)res) = result->data;
3195 return sizeofW(StgPtr);
3201 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
3202 *((void**)res) = stgCast(void*,&(arr->payload));
3203 return sizeofW(StgPtr);
3206 barf("unmarshall: unrecognised result type %d\n",res_ty);
3210 nat argSize( const char* ks )
3213 for( ; *ks != '\0'; ++ks) {
3216 sz += sizeof(StgWord) * ARG_SIZE(INT_TAG);
3220 sz += sizeof(StgWord) * ARG_SIZE(INTEGER_TAG);
3224 sz += sizeof(StgWord) * ARG_SIZE(WORD_TAG);
3227 sz += sizeof(StgWord) * ARG_SIZE(CHAR_TAG);
3230 sz += sizeof(StgWord) * ARG_SIZE(FLOAT_TAG);
3233 sz += sizeof(StgWord) * ARG_SIZE(DOUBLE_TAG);
3236 sz += sizeof(StgWord) * ARG_SIZE(ADDR_TAG);
3239 sz += sizeof(StgWord) * ARG_SIZE(STABLE_TAG);
3241 #ifdef PROVIDE_FOREIGN
3246 sz += sizeof(StgPtr);
3249 barf("argSize: unrecognised result type %d\n",*ks);
3257 /* -----------------------------------------------------------------------------
3258 * encode/decode Float/Double code for standalone Hugs
3259 * Code based on the HBC code (lib/fltcode.c) and more recently GHC
3260 * (ghc/rts/StgPrimFloat.c)
3261 * ---------------------------------------------------------------------------*/
3263 #if IEEE_FLOATING_POINT
3264 #define MY_DMINEXP ((DBL_MIN_EXP) - (DBL_MANT_DIG) - 1)
3265 /* DMINEXP is defined in values.h on Linux (for example) */
3266 #define DHIGHBIT 0x00100000
3267 #define DMSBIT 0x80000000
3269 #define MY_FMINEXP ((FLT_MIN_EXP) - (FLT_MANT_DIG) - 1)
3270 #define FHIGHBIT 0x00800000
3271 #define FMSBIT 0x80000000
3273 #error The following code doesnt work in a non-IEEE FP environment
3276 #ifdef WORDS_BIGENDIAN
3285 StgDouble B__encodeDouble (B* s, I_ e) /* result = s * 2^e */
3290 /* Convert a B to a double; knows a lot about internal rep! */
3291 for(r = 0.0, i = s->used-1; i >= 0; i--)
3292 r = (r * B_BASE_FLT) + s->stuff[i];
3294 /* Now raise to the exponent */
3295 if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
3298 /* handle the sign */
3299 if (s->sign < 0) r = -r;
3306 #if ! FLOATS_AS_DOUBLES
3307 StgFloat B__encodeFloat (B* s, I_ e) /* result = s * 2^e */
3312 /* Convert a B to a float; knows a lot about internal rep! */
3313 for(r = 0.0, i = s->used-1; i >= 0; i--)
3314 r = (r * B_BASE_FLT) + s->stuff[i];
3316 /* Now raise to the exponent */
3317 if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
3320 /* handle the sign */
3321 if (s->sign < 0) r = -r;
3325 #endif /* FLOATS_AS_DOUBLES */
3329 /* This only supports IEEE floating point */
3330 void B__decodeDouble (B* man, I_* exp, StgDouble dbl)
3332 /* Do some bit fiddling on IEEE */
3333 nat low, high; /* assuming 32 bit ints */
3335 union { double d; int i[2]; } u; /* assuming 32 bit ints, 64 bit double */
3337 u.d = dbl; /* grab chunks of the double */
3341 ASSERT(B_BASE == 256);
3343 /* Assume that the supplied B is the right size */
3346 if (low == 0 && (high & ~DMSBIT) == 0) {
3347 man->sign = man->used = 0;
3352 iexp = ((high >> 20) & 0x7ff) + MY_DMINEXP;
3356 if (iexp != MY_DMINEXP) /* don't add hidden bit to denorms */
3360 /* A denorm, normalize the mantissa */
3361 while (! (high & DHIGHBIT)) {
3371 man->stuff[7] = (((W_)high) >> 24) & 0xff;
3372 man->stuff[6] = (((W_)high) >> 16) & 0xff;
3373 man->stuff[5] = (((W_)high) >> 8) & 0xff;
3374 man->stuff[4] = (((W_)high) ) & 0xff;
3376 man->stuff[3] = (((W_)low) >> 24) & 0xff;
3377 man->stuff[2] = (((W_)low) >> 16) & 0xff;
3378 man->stuff[1] = (((W_)low) >> 8) & 0xff;
3379 man->stuff[0] = (((W_)low) ) & 0xff;
3381 if (sign < 0) man->sign = -1;
3383 do_renormalise(man);
3387 #if ! FLOATS_AS_DOUBLES
3388 void B__decodeFloat (B* man, I_* exp, StgFloat flt)
3390 /* Do some bit fiddling on IEEE */
3391 int high, sign; /* assuming 32 bit ints */
3392 union { float f; int i; } u; /* assuming 32 bit float and int */
3394 u.f = flt; /* grab the float */
3397 ASSERT(B_BASE == 256);
3399 /* Assume that the supplied B is the right size */
3402 if ((high & ~FMSBIT) == 0) {
3403 man->sign = man->used = 0;
3408 *exp = ((high >> 23) & 0xff) + MY_FMINEXP;
3412 if (*exp != MY_FMINEXP) /* don't add hidden bit to denorms */
3416 /* A denorm, normalize the mantissa */
3417 while (! (high & FHIGHBIT)) {
3422 man->stuff[3] = (((W_)high) >> 24) & 0xff;
3423 man->stuff[2] = (((W_)high) >> 16) & 0xff;
3424 man->stuff[1] = (((W_)high) >> 8) & 0xff;
3425 man->stuff[0] = (((W_)high) ) & 0xff;
3427 if (sign < 0) man->sign = -1;
3429 do_renormalise(man);
3432 #endif /* FLOATS_AS_DOUBLES */
3434 #endif /* INTERPRETER */