2 /* -----------------------------------------------------------------------------
5 * Copyright (c) 1994-1998.
7 * $RCSfile: Evaluator.c,v $
9 * $Date: 2000/03/13 13:00:00 $
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 */
46 /* An incredibly useful abbreviation.
47 * Interestingly, there are some uses of END_TSO_QUEUE_closure that
48 * can't use it because they use the closure at type StgClosure* or
49 * even StgPtr*. I suspect they should be changed. -- ADR
51 #define EndTSOQueue stgCast(StgTSO*,(void*)&END_TSO_QUEUE_closure)
53 /* These macros are rather delicate - read a good ANSI C book carefully
57 #define mycat(x,y) x##y
58 #define mycat2(x,y) mycat(x,y)
59 #define mycat3(x,y,z) mycat2(x,mycat2(y,z))
61 #if defined(__GNUC__) && !defined(DEBUG)
62 #define USE_GCC_LABELS 1
64 #define USE_GCC_LABELS 0
67 /* Make it possible for the evaluator to get hold of bytecode
68 for a given function by name. Useful but a hack. Sigh.
70 extern void* getHugs_AsmObject_for ( char* s );
71 extern int /*Bool*/ combined;
73 /* --------------------------------------------------------------------------
74 * Crude profiling stuff (mainly to assess effect of optimiser)
75 * ------------------------------------------------------------------------*/
77 #ifdef CRUDE_PROFILING
86 struct { int /*StgVar*/ who;
94 CPRecord cpTab[M_CPTAB];
101 for (i = 0; i < M_CPTAB; i++)
102 cpTab[i].who = CP_NIL;
106 void cp_enter ( StgBCO* b )
110 int /*StgVar*/ v = b->stgexpr;
111 if ((void*)v == NULL) return;
120 h = (-v) % M_CPTAB; else
123 assert (h >= 0 && h < M_CPTAB);
124 while (cpTab[h].who != v && cpTab[h].who != CP_NIL) {
125 h++; if (h == M_CPTAB) h = 0;
128 if (cpTab[cpCurr].who == CP_NIL) {
129 cpTab[cpCurr].who = v;
130 if (!is_ret_cont) cpTab[cpCurr].enters = 1;
131 cpTab[cpCurr].bytes = cpTab[cpCurr].insns = 0;
133 if (cpInUse * 2 > M_CPTAB) {
134 fprintf(stderr, "\nCRUDE_PROFILING hash table is too full\n" );
138 if (!is_ret_cont) cpTab[cpCurr].enters++;
144 void cp_bill_words ( int nw )
146 if (cpCurr == CP_NIL) return;
147 cpTab[cpCurr].bytes += sizeof(StgWord)*nw;
151 void cp_bill_insns ( int ni )
153 if (cpCurr == CP_NIL) return;
154 cpTab[cpCurr].insns += ni;
158 static double percent ( double a, double b )
160 return (100.0 * a) / b;
164 void cp_show ( void )
166 int i, j, max, maxN, totE, totB, totI, cumE, cumB, cumI;
169 if (cpInUse == -1) return;
171 fflush(stdout);fflush(stderr);
174 totE = totB = totI = 0;
175 for (i = 0; i < M_CPTAB; i++) {
176 cpTab[i].twho = cpTab[i].who;
177 if (cpTab[i].who != CP_NIL) {
178 totE += cpTab[i].enters;
179 totB += cpTab[i].bytes;
180 totI += cpTab[i].insns;
185 "%6d (%7.3f M) enters, "
186 "%6d (%7.3f M) insns, "
187 "%6d (%7.3f M) bytes\n\n",
188 totE, totE/1000000.0, totI, totI/1000000.0, totB, totB/1000000.0 );
190 cumE = cumB = cumI = 0;
191 for (j = 0; j < 32; j++) {
194 for (i = 0; i < M_CPTAB; i++)
195 if (cpTab[i].who != CP_NIL &&
196 cpTab[i].enters > maxN) {
197 maxN = cpTab[i].enters;
200 if (max == -1) break;
202 cumE += cpTab[max].enters;
203 cumB += cpTab[max].bytes;
204 cumI += cpTab[max].insns;
206 strcpy(nm, maybeName(cpTab[max].who));
207 if (strcmp(nm, "(unknown)")==0)
208 sprintf ( nm, "id%d", -cpTab[max].who);
210 printf ( "%20s %7d es (%4.1f%%, %4.1f%% c) "
211 "%7d bs (%4.1f%%, %4.1f%% c) "
212 "%7d is (%4.1f%%, %4.1f%% c)\n",
214 cpTab[max].enters, percent(cpTab[max].enters,totE), percent(cumE,totE),
215 cpTab[max].bytes, percent(cpTab[max].bytes,totB), percent(cumB,totB),
216 cpTab[max].insns, percent(cpTab[max].insns,totI), percent(cumI,totI)
219 cpTab[max].twho = cpTab[max].who;
220 cpTab[max].who = CP_NIL;
223 for (i = 0; i < M_CPTAB; i++)
224 cpTab[i].who = cpTab[i].twho;
232 /* --------------------------------------------------------------------------
233 * Hugs Hooks - a bit of a hack
234 * ------------------------------------------------------------------------*/
236 void setRtsFlags( int x );
237 void setRtsFlags( int x )
239 unsigned int w = 0x12345678;
240 unsigned char* pw = (unsigned char *)&w;
243 *(int*)(&(RtsFlags.DebugFlags)) = x;
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 w2 |= (w1 && 0xFF); w2 <<= 8; w1 >>= 8;
252 *(int*)(&(RtsFlags.DebugFlags)) = (int)w2;
257 /* --------------------------------------------------------------------------
258 * Entering-objects and bytecode interpreter part of evaluator
259 * ------------------------------------------------------------------------*/
261 /* The primop (and all other) parts of this evaluator operate upon the
262 machine state which lives in MainRegTable. enter is different:
263 to make its closure- and bytecode-interpreting loops go fast, some of that
264 state is pulled out into local vars (viz, registers, if we are lucky).
265 That means that we need to save(load) the local state at every exit(reentry)
266 into enter. That is, around every procedure call it makes. Blargh!
267 If you modify this code, __be warned__ it will fail in mysterious ways if
268 you fail to preserve this property.
270 Currently the pulled-out state is Sp in xSp, Su in xSu and SpLim in xSpLim.
271 The SSS macros saves the state back in MainRegTable, and LLL loads it from
272 MainRegTable. RETURN(v) does SSS and then returns v; all exits should
273 be via RETURN and not plain return.
275 Since xSp, xSu and xSpLim are local vars in enter, they are not visible
276 in procedures called from enter. To fix this, either (1) turn the
277 procedures into macros, so they get copied inline, or (2) bracket
278 the procedure call with SSS and LLL so that the local and global
279 machine states are synchronised for the duration of the call.
283 /* Forward decls ... */
284 static void* enterBCO_primop1 ( int );
285 static void* enterBCO_primop2 ( int , int* /*StgThreadReturnCode* */,
286 StgBCO**, Capability* );
287 static inline void PopUpdateFrame ( StgClosure* obj );
288 static inline void PopCatchFrame ( void );
289 static inline void PopSeqFrame ( void );
290 static inline void PopStopFrame( StgClosure* obj );
291 static inline void PushTaggedRealWorld( void );
292 /* static inline void PushTaggedInteger ( mpz_ptr ); */
293 static inline StgPtr grabHpUpd( nat size );
294 static inline StgPtr grabHpNonUpd( nat size );
295 static StgClosure* raiseAnError ( StgClosure* exception );
297 static int enterCountI = 0;
299 StgDouble B__encodeDouble (B* s, I_ e);
300 void B__decodeDouble (B* man, I_* exp, StgDouble dbl);
301 #if ! FLOATS_AS_DOUBLES
302 StgFloat B__encodeFloat (B* s, I_ e);
303 void B__decodeFloat (B* man, I_* exp, StgFloat flt);
304 StgPtr CreateByteArrayToHoldInteger ( int );
305 B* IntegerInsideByteArray ( StgPtr );
306 void SloppifyIntegerEnd ( StgPtr );
312 #define gSp MainRegTable.rSp
313 #define gSu MainRegTable.rSu
314 #define gSpLim MainRegTable.rSpLim
317 /* Macros to save/load local state. */
319 #define SSS { tSp=gSp = xSp; tSu=gSu = xSu; tSpLim=gSpLim = xSpLim; }
320 #define LLL { tSp=xSp = gSp; tSu=xSu = gSu; tSpLim=xSpLim = gSpLim; }
322 #define SSS { gSp = xSp; gSu = xSu; gSpLim = xSpLim; }
323 #define LLL { xSp = gSp; xSu = gSu; xSpLim = gSpLim; }
326 #define RETURN(vvv) { \
327 StgThreadReturnCode retVal=(vvv); \
329 cap->rCurrentTSO->sp = gSp; \
330 cap->rCurrentTSO->su = gSu; \
331 cap->rCurrentTSO->splim = gSpLim; \
336 /* Macros to operate directly on the pulled-out machine state.
337 These mirror some of the small procedures used in the primop code
338 below, except you have to be careful about side effects,
339 ie xPushPtr(xStackPtr(n)) won't work! It certainly isn't the
340 same as PushPtr(StackPtr(n)). Also note that (1) some of
341 the macros, in particular xPopTagged*, do not make the tag
342 sanity checks that their non-x cousins do, and (2) some of
343 the macros depend critically on the semantics of C comma
344 expressions to work properly.
346 #define xPushPtr(ppp) { xSp--; *xSp=(StgWord)(ppp); }
347 #define xPopPtr() ((StgPtr)(*xSp++))
349 #define xPushCPtr(ppp) { xSp--; *xSp=(StgWord)(ppp); }
350 #define xPopCPtr() ((StgClosure*)(*xSp++))
352 #define xPushWord(ppp) { xSp--; *xSp=(StgWord)(ppp); }
353 #define xPopWord() ((StgWord)(*xSp++))
355 #define xStackPtr(nnn) ((StgPtr)(*(xSp+(nnn))))
356 #define xStackWord(nnn) ((StgWord)(*(xSp+(nnn))))
357 #define xSetStackWord(iii,www) xSp[iii]=(StgWord)(www)
359 #define xPushTag(ttt) { xSp--; *xSp=(StgWord)(ttt); }
360 #define xPopTag(ttt) { StackTag t = (StackTag)(*xSp++); \
363 #define xPushTaggedInt(xxx) { xSp -= sizeofW(StgInt); \
364 *xSp = (xxx); xPushTag(INT_TAG); }
365 #define xTaggedStackInt(iii) ((StgInt)(*(xSp+1+(iii))))
366 #define xPopTaggedInt() ((xSp++,xSp+=sizeofW(StgInt), \
367 (StgInt)(*(xSp-sizeofW(StgInt)))))
369 #define xPushTaggedWord(xxx) { xSp -= sizeofW(StgWord); \
370 *xSp = (xxx); xPushTag(WORD_TAG); }
371 #define xTaggedStackWord(iii) ((StgWord)(*(xSp+1+(iii))))
372 #define xPopTaggedWord() ((xSp++,xSp+=sizeofW(StgWord), \
373 (StgWord)(*(xSp-sizeofW(StgWord)))))
375 #define xPushTaggedAddr(xxx) { xSp -= sizeofW(StgAddr); \
376 *xSp = (StgWord)(xxx); xPushTag(ADDR_TAG); }
377 #define xTaggedStackAddr(iii) ((StgAddr)(*(xSp+1+(iii))))
378 #define xPopTaggedAddr() ((xSp++,xSp+=sizeofW(StgAddr), \
379 (StgAddr)(*(xSp-sizeofW(StgAddr)))))
381 #define xPushTaggedStable(xxx) { xSp -= sizeofW(StgStablePtr); \
382 *xSp = (StgWord)(xxx); xPushTag(STABLE_TAG); }
383 #define xTaggedStackStable(iii) ((StgStablePtr)(*(xSp+1+(iii))))
384 #define xPopTaggedStable() ((xSp++,xSp+=sizeofW(StgStablePtr), \
385 (StgStablePtr)(*(xSp-sizeofW(StgStablePtr)))))
387 #define xPushTaggedChar(xxx) { xSp -= sizeofW(StgChar); \
388 *xSp = (StgWord)(xxx); xPushTag(CHAR_TAG); }
389 #define xTaggedStackChar(iii) ((StgChar)(*(xSp+1+(iii))))
390 #define xPopTaggedChar() ((xSp++,xSp+=sizeofW(StgChar), \
391 (StgChar)(*(xSp-sizeofW(StgChar)))))
393 #define xPushTaggedFloat(xxx) { xSp -= sizeofW(StgFloat); \
394 ASSIGN_FLT(xSp,xxx); xPushTag(FLOAT_TAG); }
395 #define xTaggedStackFloat(iii) PK_FLT(xSp+1+(iii))
396 #define xPopTaggedFloat() ((xSp++,xSp+=sizeofW(StgFloat), \
397 PK_FLT(xSp-sizeofW(StgFloat))))
399 #define xPushTaggedDouble(xxx) { xSp -= sizeofW(StgDouble); \
400 ASSIGN_DBL(xSp,xxx); xPushTag(DOUBLE_TAG); }
401 #define xTaggedStackDouble(iii) PK_DBL(xSp+1+(iii))
402 #define xPopTaggedDouble() ((xSp++,xSp+=sizeofW(StgDouble), \
403 PK_DBL(xSp-sizeofW(StgDouble))))
406 #define xPushUpdateFrame(target, xSp_offset) \
408 StgUpdateFrame *__frame; \
409 __frame = (StgUpdateFrame *)(xSp + (xSp_offset)) - 1; \
410 SET_INFO(__frame, (StgInfoTable *)&Upd_frame_info); \
411 __frame->link = xSu; \
412 __frame->updatee = (StgClosure *)(target); \
416 #define xPopUpdateFrame(ooo) \
418 /* NB: doesn't assume that Sp == Su */ \
419 IF_DEBUG(evaluator, \
420 fprintf(stderr, "Updating "); \
421 printPtr(stgCast(StgPtr,xSu->updatee)); \
422 fprintf(stderr, " with "); \
424 fprintf(stderr,"xSp = %p\txSu = %p\n\n", xSp, xSu); \
426 UPD_IND(xSu->updatee,ooo); \
427 xSp = stgCast(StgStackPtr,xSu) + sizeofW(StgUpdateFrame); \
433 /* Instruction stream macros */
434 #define BCO_INSTR_8 *bciPtr++
435 #define BCO_INSTR_16 ((bciPtr += 2, (*(bciPtr-2) << 8) + *(bciPtr-1)))
436 #define PC (bciPtr - &(bcoInstr(bco,0)))
439 /* State on entry to enter():
440 * - current thread is in cap->rCurrentTSO;
441 * - allocation area is in cap->rCurrentNursery & cap->rNursery
444 StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 )
446 /* use of register here is primarily to make it clear to compilers
447 that these entities are non-aliasable.
449 register StgPtr xSp; /* local state -- stack pointer */
450 register StgUpdateFrame* xSu; /* local state -- frame pointer */
451 register StgPtr xSpLim; /* local state -- stack lim pointer */
452 register StgClosure* obj; /* object currently under evaluation */
453 char eCount; /* enter counter, for context switching */
456 StgPtr tSp; StgUpdateFrame* tSu; StgPtr tSpLim;
459 gSp = cap->rCurrentTSO->sp;
460 gSu = cap->rCurrentTSO->su;
461 gSpLim = cap->rCurrentTSO->splim;
464 /* use the t values to check that Su/Sp/SpLim do not change unexpectedly */
465 tSp = gSp; tSu = gSu; tSpLim = gSpLim;
471 /* Load the local state from global state, and Party On, Dudes! */
472 /* From here onwards, we operate with the local state and
473 save/reload it as necessary.
482 assert(gSpLim == tSpLim);
486 ASSERT(xSpLim <= xSp && xSp <= stgCast(StgPtr,xSu));
488 "\n---------------------------------------------------------------\n");
489 fprintf(stderr,"(%d) Entering: ",enterCountI); printObj(obj);
490 fprintf(stderr,"xSp = %p\txSu = %p\n", xSp, xSu);
491 fprintf(stderr, "\n" );
492 printStack(xSp,cap->rCurrentTSO->stack+cap->rCurrentTSO->stack_size,xSu);
493 fprintf(stderr, "\n\n");
500 ((++eCount) & 0x0F) == 0
505 if (context_switch) {
506 xPushCPtr(obj); /* code to restart with */
507 RETURN(ThreadYielding);
511 switch ( get_itbl(obj)->type ) {
513 barf("Invalid object %p",obj);
517 /* ---------------------------------------------------- */
518 /* Start of the bytecode evaluator */
519 /* ---------------------------------------------------- */
522 # define Ins(x) &&l##x
523 static void *labs[] = { INSTRLIST };
525 # define LoopTopLabel
526 # define Case(x) l##x
527 # define Continue goto *labs[BCO_INSTR_8]
528 # define Dispatch Continue;
531 # define LoopTopLabel insnloop:
532 # define Case(x) case x
533 # define Continue goto insnloop
534 # define Dispatch switch (BCO_INSTR_8) {
535 # define EndDispatch }
538 register StgWord8* bciPtr; /* instruction pointer */
539 register StgBCO* bco = (StgBCO*)obj;
542 /* Don't need to SSS ... LLL around doYouWantToGC */
543 wantToGC = doYouWantToGC();
545 xPushCPtr((StgClosure*)bco); /* code to restart with */
546 RETURN(HeapOverflow);
554 bciPtr = &(bcoInstr(bco,0));
558 ASSERT((StgWord)(PC) < bco->n_instrs);
560 fprintf(stderr,"Sp = %p\tSu = %p\tpc = %d\t", xSp, xSu, PC);
564 fprintf(stderr,"\n");
565 for (i = 8; i >= 0; i--)
566 fprintf(stderr, "%d %p\n", i, (StgPtr)(*(gSp+i)));
568 fprintf(stderr,"\n");
573 SSS; cp_bill_insns(1); LLL;
578 Case(i_INTERNAL_ERROR):
579 barf("INTERNAL_ERROR at %p:%d",bco,PC-1);
581 barf("PANIC at %p:%d",bco,PC-1);
585 if (xSp - n < xSpLim) {
586 xPushCPtr((StgClosure*)bco); /* code to restart with */
587 RETURN(StackOverflow);
591 Case(i_STK_CHECK_big):
593 int n = BCO_INSTR_16;
594 if (xSp - n < xSpLim) {
595 xPushCPtr((StgClosure*)bco); /* code to restart with */
596 RETURN(StackOverflow);
603 if ((StgPtr*)(xSp + n) > (StgPtr*)xSu) {
604 StgWord words = (P_)xSu - xSp;
606 /* first build a PAP */
607 ASSERT((P_)xSu >= xSp); /* was (words >= 0) but that's always true */
608 if (words == 0) { /* optimisation */
609 /* Skip building the PAP and update with an indirection. */
612 /* In the evaluator, we avoid the need to do
613 * a heap check here by including the size of
614 * the PAP in the heap check we performed
615 * when we entered the BCO.
619 SSS; pap = (StgPAP*)grabHpNonUpd(PAP_sizeW(words)); LLL;
620 SET_HDR(pap,&PAP_info,CC_pap);
623 for (i = 0; i < (I_)words; ++i) {
624 payloadWord(pap,i) = xSp[i];
627 obj = stgCast(StgClosure*,pap);
630 /* now deal with "update frame" */
631 /* as an optimisation, we process all on top of stack */
632 /* instead of just the top one */
633 ASSERT(xSp==(P_)xSu);
635 switch (get_itbl(xSu)->type) {
637 /* Hit a catch frame during an arg satisfaction check,
638 * so the thing returning (1) has not thrown an
639 * exception, and (2) is of functional type. Just
640 * zap the catch frame and carry on down the stack
641 * (looking for more arguments, basically).
643 SSS; PopCatchFrame(); LLL;
646 xPopUpdateFrame(obj);
649 SSS; PopStopFrame(obj); LLL;
650 RETURN(ThreadFinished);
652 SSS; PopSeqFrame(); LLL;
653 ASSERT(xSp != (P_)xSu);
654 /* Hit a SEQ frame during an arg satisfaction check.
655 * So now return to bco_info which is under the
656 * SEQ frame. The following code is copied from a
657 * case RET_BCO further down. (The reason why we're
658 * here is that something of functional type has
659 * been seq-d on, and we're now returning to the
660 * algebraic-case-continuation which forced the
661 * evaluation in the first place.)
673 barf("Invalid update frame during argcheck");
675 } while (xSp==(P_)xSu);
683 int words = BCO_INSTR_8;
684 SSS; p = grabHpUpd(AP_sizeW(words)); LLL;
688 Case(i_ALLOC_CONSTR):
691 StgInfoTable* info = bcoConstAddr(bco,BCO_INSTR_8);
692 SSS; p = grabHpNonUpd(sizeW_fromITBL(info)); LLL;
693 SET_HDR((StgClosure*)p,info,??);
697 Case(i_ALLOC_CONSTR_big):
700 int x = BCO_INSTR_16;
701 StgInfoTable* info = bcoConstAddr(bco,x);
702 SSS; p = grabHpNonUpd(sizeW_fromITBL(info)); LLL;
703 SET_HDR((StgClosure*)p,info,??);
709 int x = BCO_INSTR_8; /* ToDo: Word not Int! */
711 StgAP_UPD* o = stgCast(StgAP_UPD*,xStackPtr(x));
712 SET_HDR(o,&AP_UPD_info,??);
714 o->fun = stgCast(StgClosure*,xPopPtr());
715 for(x=0; x < y; ++x) {
716 payloadWord(o,x) = xPopWord();
719 fprintf(stderr,"\tBuilt ");
721 printObj(stgCast(StgClosure*,o));
732 o = stgCast(StgAP_UPD*,xStackPtr(x));
733 SET_HDR(o,&AP_UPD_info,??);
735 o->fun = stgCast(StgClosure*,xPopPtr());
736 for(x=0; x < y; ++x) {
737 payloadWord(o,x) = xPopWord();
740 fprintf(stderr,"\tBuilt ");
742 printObj(stgCast(StgClosure*,o));
751 StgPAP* o = stgCast(StgPAP*,xStackPtr(x));
752 SET_HDR(o,&PAP_info,??);
754 o->fun = stgCast(StgClosure*,xPopPtr());
755 for(x=0; x < y; ++x) {
756 payloadWord(o,x) = xPopWord();
759 fprintf(stderr,"\tBuilt ");
761 printObj(stgCast(StgClosure*,o));
768 int offset = BCO_INSTR_8;
769 StgClosure* o = stgCast(StgClosure*,xStackPtr(offset));
770 const StgInfoTable* info = get_itbl(o);
771 nat p = info->layout.payload.ptrs;
772 nat np = info->layout.payload.nptrs;
774 for(i=0; i < p; ++i) {
775 payloadCPtr(o,i) = xPopCPtr();
777 for(i=0; i < np; ++i) {
778 payloadWord(o,p+i) = 0xdeadbeef;
781 fprintf(stderr,"\tBuilt ");
783 printObj(stgCast(StgClosure*,o));
790 int offset = BCO_INSTR_16;
791 StgClosure* o = stgCast(StgClosure*,xStackPtr(offset));
792 const StgInfoTable* info = get_itbl(o);
793 nat p = info->layout.payload.ptrs;
794 nat np = info->layout.payload.nptrs;
796 for(i=0; i < p; ++i) {
797 payloadCPtr(o,i) = xPopCPtr();
799 for(i=0; i < np; ++i) {
800 payloadWord(o,p+i) = 0xdeadbeef;
803 fprintf(stderr,"\tBuilt ");
805 printObj(stgCast(StgClosure*,o));
814 ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
815 /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
817 xSetStackWord(x+y,xStackWord(x));
827 ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
828 /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
830 xSetStackWord(x+y,xStackWord(x));
842 xPushPtr(bcoConstPtr(bco,BCO_INSTR_8));
843 xPushPtr(stgCast(StgPtr,&ret_bco_info));
848 int tag = BCO_INSTR_8;
849 StgWord offset = BCO_INSTR_16;
850 if (constrTag( (StgClosure*)xStackPtr(0) ) != tag) {
857 StgClosure* o = stgCast(StgClosure*,xStackPtr(0));
858 const StgInfoTable* itbl = get_itbl(o);
859 int i = itbl->layout.payload.ptrs;
860 ASSERT( itbl->type == CONSTR
861 || itbl->type == CONSTR_STATIC
862 || itbl->type == CONSTR_NOCAF_STATIC
863 || itbl->type == CONSTR_1_0
864 || itbl->type == CONSTR_0_1
865 || itbl->type == CONSTR_2_0
866 || itbl->type == CONSTR_1_1
867 || itbl->type == CONSTR_0_2
870 xPushCPtr(payloadCPtr(o,i));
876 int n = BCO_INSTR_16;
877 StgPtr p = xStackPtr(n);
883 StgPtr p = xStackPtr(BCO_INSTR_8);
889 xPushPtr(stgCast(StgPtr,bcoConstPtr(bco,BCO_INSTR_8)));
894 int n = BCO_INSTR_16;
895 xPushPtr(stgCast(StgPtr,bcoConstPtr(bco,n)));
900 SSS; PushTaggedRealWorld(); LLL;
905 StgInt i = xTaggedStackInt(BCO_INSTR_8);
911 xPushTaggedInt(bcoConstInt(bco,BCO_INSTR_8));
914 Case(i_CONST_INT_big):
916 int n = BCO_INSTR_16;
917 xPushTaggedInt(bcoConstInt(bco,n));
923 SSS; o = (StgClosure*)grabHpNonUpd(Izh_sizeW); LLL;
924 SET_HDR(o,&Izh_con_info,??);
925 payloadWord(o,0) = xPopTaggedInt();
927 fprintf(stderr,"\tBuilt ");
929 printObj(stgCast(StgClosure*,o));
932 xPushPtr(stgCast(StgPtr,o));
937 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
938 /* ASSERT(isIntLike(con)); */
939 xPushTaggedInt(payloadWord(con,0));
944 StgWord offset = BCO_INSTR_16;
945 StgInt x = xPopTaggedInt();
946 StgInt y = xPopTaggedInt();
952 Case(i_CONST_INTEGER):
956 char* s = bcoConstAddr(bco,BCO_INSTR_8);
959 p = CreateByteArrayToHoldInteger(n);
960 do_fromStr ( s, n, IntegerInsideByteArray(p));
961 SloppifyIntegerEnd(p);
968 StgWord w = xTaggedStackWord(BCO_INSTR_8);
974 xPushTaggedWord(bcoConstWord(bco,BCO_INSTR_8));
980 SSS; o = (StgClosure*)grabHpNonUpd(Wzh_sizeW); LLL;
981 SET_HDR(o,&Wzh_con_info,??);
982 payloadWord(o,0) = xPopTaggedWord();
984 fprintf(stderr,"\tBuilt ");
986 printObj(stgCast(StgClosure*,o));
989 xPushPtr(stgCast(StgPtr,o));
994 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
995 /* ASSERT(isWordLike(con)); */
996 xPushTaggedWord(payloadWord(con,0));
1001 StgAddr a = xTaggedStackAddr(BCO_INSTR_8);
1007 xPushTaggedAddr(bcoConstAddr(bco,BCO_INSTR_8));
1010 Case(i_CONST_ADDR_big):
1012 int n = BCO_INSTR_16;
1013 xPushTaggedAddr(bcoConstAddr(bco,n));
1019 SSS; o = (StgClosure*)grabHpNonUpd(Azh_sizeW); LLL;
1020 SET_HDR(o,&Azh_con_info,??);
1021 payloadPtr(o,0) = xPopTaggedAddr();
1023 fprintf(stderr,"\tBuilt ");
1025 printObj(stgCast(StgClosure*,o));
1028 xPushPtr(stgCast(StgPtr,o));
1031 Case(i_UNPACK_ADDR):
1033 StgClosure* con = (StgClosure*)xStackPtr(0);
1034 /* ASSERT(isAddrLike(con)); */
1035 xPushTaggedAddr(payloadPtr(con,0));
1040 StgChar c = xTaggedStackChar(BCO_INSTR_8);
1046 xPushTaggedChar(bcoConstChar(bco,BCO_INSTR_8));
1052 SSS; o = (StgClosure*)grabHpNonUpd(Czh_sizeW); LLL;
1053 SET_HDR(o,&Czh_con_info,??);
1054 payloadWord(o,0) = xPopTaggedChar();
1055 xPushPtr(stgCast(StgPtr,o));
1057 fprintf(stderr,"\tBuilt ");
1059 printObj(stgCast(StgClosure*,o));
1064 Case(i_UNPACK_CHAR):
1066 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1067 /* ASSERT(isCharLike(con)); */
1068 xPushTaggedChar(payloadWord(con,0));
1073 StgFloat f = xTaggedStackFloat(BCO_INSTR_8);
1074 xPushTaggedFloat(f);
1077 Case(i_CONST_FLOAT):
1079 xPushTaggedFloat(bcoConstFloat(bco,BCO_INSTR_8));
1085 SSS; o = (StgClosure*)grabHpNonUpd(Fzh_sizeW); LLL;
1086 SET_HDR(o,&Fzh_con_info,??);
1087 ASSIGN_FLT(&payloadWord(o,0),xPopTaggedFloat());
1089 fprintf(stderr,"\tBuilt ");
1091 printObj(stgCast(StgClosure*,o));
1094 xPushPtr(stgCast(StgPtr,o));
1097 Case(i_UNPACK_FLOAT):
1099 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1100 /* ASSERT(isFloatLike(con)); */
1101 xPushTaggedFloat(PK_FLT(&payloadWord(con,0)));
1106 StgDouble d = xTaggedStackDouble(BCO_INSTR_8);
1107 xPushTaggedDouble(d);
1110 Case(i_CONST_DOUBLE):
1112 xPushTaggedDouble(bcoConstDouble(bco,BCO_INSTR_8));
1115 Case(i_CONST_DOUBLE_big):
1117 int n = BCO_INSTR_16;
1118 xPushTaggedDouble(bcoConstDouble(bco,n));
1121 Case(i_PACK_DOUBLE):
1124 SSS; o = (StgClosure*)grabHpNonUpd(Dzh_sizeW); LLL;
1125 SET_HDR(o,&Dzh_con_info,??);
1126 ASSIGN_DBL(&payloadWord(o,0),xPopTaggedDouble());
1128 fprintf(stderr,"\tBuilt ");
1129 printObj(stgCast(StgClosure*,o));
1131 xPushPtr(stgCast(StgPtr,o));
1134 Case(i_UNPACK_DOUBLE):
1136 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1137 /* ASSERT(isDoubleLike(con)); */
1138 xPushTaggedDouble(PK_DBL(&payloadWord(con,0)));
1143 StgStablePtr s = xTaggedStackStable(BCO_INSTR_8);
1144 xPushTaggedStable(s);
1147 Case(i_PACK_STABLE):
1150 SSS; o = (StgClosure*)grabHpNonUpd(Stablezh_sizeW); LLL;
1151 SET_HDR(o,&StablePtr_con_info,??);
1152 payloadWord(o,0) = xPopTaggedStable();
1154 fprintf(stderr,"\tBuilt ");
1156 printObj(stgCast(StgClosure*,o));
1159 xPushPtr(stgCast(StgPtr,o));
1162 Case(i_UNPACK_STABLE):
1164 StgClosure* con = (StgClosure*)xStackPtr(0);
1165 /* ASSERT(isStableLike(con)); */
1166 xPushTaggedStable(payloadWord(con,0));
1174 SSS; p = enterBCO_primop1 ( i ); LLL;
1175 if (p) { obj = p; goto enterLoop; };
1180 int i, trc, pc_saved;
1183 trc = 12345678; /* Assume != any StgThreadReturnCode */
1188 p = enterBCO_primop2 ( i, &trc, &bco_tmp, cap );
1191 bciPtr = &(bcoInstr(bco,pc_saved));
1193 if (trc == 12345678) {
1194 /* we want to enter p */
1195 obj = p; goto enterLoop;
1197 /* trc is the the StgThreadReturnCode for this thread */
1198 RETURN((StgThreadReturnCode)trc);
1204 /* combined insns, created by peephole opt */
1207 int x = BCO_INSTR_8;
1208 int y = BCO_INSTR_8;
1209 ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
1210 /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
1217 xSetStackWord(x+y,xStackWord(x));
1227 p = xStackPtr(BCO_INSTR_8);
1229 p = xStackPtr(BCO_INSTR_8);
1236 xPushPtr(bcoConstPtr(bco,BCO_INSTR_8));
1237 xPushPtr(stgCast(StgPtr,&ret_bco_info));
1238 p = xStackPtr(BCO_INSTR_8);
1244 StgPtr retaddr = bcoConstPtr(bco,BCO_INSTR_8);
1245 StgPtr ptr = xStackPtr(BCO_INSTR_8);
1247 /* A shortcut. We're going to push the address of a
1248 return continuation, and then enter a variable, so
1249 that when the var is evaluated, we return to the
1250 continuation. The shortcut is: if the var is a
1251 constructor, don't bother to enter it. Instead,
1252 push the variable on the stack (since this is what
1253 the continuation expects) and jump directly to the
1256 if (get_itbl((StgClosure*)ptr)->type == CONSTR) {
1258 obj = (StgClosure*)retaddr;
1260 fprintf(stderr, "object to enter is a constructor -- "
1261 "jumping directly to return continuation\n" );
1266 /* This is the normal, non-short-cut route */
1268 xPushPtr(stgCast(StgPtr,&ret_bco_info));
1269 obj = (StgClosure*)ptr;
1274 Case(i_VAR_DOUBLE_big):
1275 Case(i_CONST_FLOAT_big):
1276 Case(i_VAR_FLOAT_big):
1277 Case(i_CONST_CHAR_big):
1278 Case(i_VAR_CHAR_big):
1279 Case(i_VAR_ADDR_big):
1280 Case(i_VAR_STABLE_big):
1281 Case(i_CONST_INTEGER_big):
1282 Case(i_VAR_INT_big):
1283 Case(i_VAR_WORD_big):
1284 Case(i_RETADDR_big):
1288 disInstr ( bco, PC );
1289 barf("\nUnrecognised instruction");
1293 barf("enterBCO: ran off end of loop");
1297 # undef LoopTopLabel
1303 /* ---------------------------------------------------- */
1304 /* End of the bytecode evaluator */
1305 /* ---------------------------------------------------- */
1309 StgBlockingQueue* bh;
1310 StgCAF* caf = (StgCAF*)obj;
1311 if (xSp - sizeofW(StgUpdateFrame) < xSpLim) {
1312 xPushCPtr(obj); /* code to restart with */
1313 RETURN(StackOverflow);
1315 /* ToDo: look for xSp==xSu && stackInt(0) == UPD_FRAME
1316 and insert an indirection immediately */
1317 SSS; bh = (StgBlockingQueue*)grabHpUpd(BLACKHOLE_sizeW()); LLL;
1318 SET_INFO(bh,&CAF_BLACKHOLE_info);
1319 bh->blocking_queue = EndTSOQueue;
1321 fprintf(stderr,"Created CAF_BLACKHOLE %p for CAF %p in evaluator\n",bh,caf));
1322 SET_INFO(caf,&CAF_ENTERED_info);
1323 caf->value = (StgClosure*)bh;
1324 if (caf->mut_link == NULL) {
1325 SSS; recordOldToNewPtrs((StgMutClosure*)caf); LLL;
1327 xPushUpdateFrame(bh,0);
1328 xSp -= sizeofW(StgUpdateFrame);
1329 caf->link = enteredCAFs;
1336 StgCAF* caf = (StgCAF*)obj;
1337 obj = caf->value; /* it's just a fancy indirection */
1343 case SE_CAF_BLACKHOLE:
1345 /* Let the scheduler figure out what to do :-) */
1346 cap->rCurrentTSO->whatNext = ThreadEnterGHC;
1348 RETURN(ThreadYielding);
1352 StgAP_UPD* ap = stgCast(StgAP_UPD*,obj);
1354 if (xSp - (i + sizeofW(StgUpdateFrame)) < xSpLim) {
1355 xPushCPtr(obj); /* code to restart with */
1356 RETURN(StackOverflow);
1358 /* ToDo: look for xSp==xSu && stackInt(0) == UPD_FRAME
1359 and insert an indirection immediately */
1360 xPushUpdateFrame(ap,0);
1361 xSp -= sizeofW(StgUpdateFrame);
1363 xPushWord(payloadWord(ap,i));
1366 #ifdef EAGER_BLACKHOLING
1367 #warn LAZY_BLACKHOLING is default for StgHugs
1368 #error Dont know if EAGER_BLACKHOLING works in StgHugs
1370 /* superfluous - but makes debugging easier */
1371 StgBlackHole* bh = stgCast(StgBlackHole*,ap);
1372 SET_INFO(bh,&BLACKHOLE_info);
1373 bh->blocking_queue = EndTSOQueue;
1375 fprintf(stderr,"Eagerly blackholed AP_UPD %p in evaluator\n",bh));
1378 #endif /* EAGER_BLACKHOLING */
1383 StgPAP* pap = stgCast(StgPAP*,obj);
1384 int i = pap->n_args; /* ToDo: stack check */
1385 /* ToDo: if PAP is in whnf, we can update any update frames
1389 xPushWord(payloadWord(pap,i));
1396 obj = stgCast(StgInd*,obj)->indirectee;
1401 obj = stgCast(StgIndOldGen*,obj)->indirectee;
1410 case CONSTR_INTLIKE:
1411 case CONSTR_CHARLIKE:
1413 case CONSTR_NOCAF_STATIC:
1416 switch (get_itbl(stgCast(StgClosure*,xSp))->type) {
1418 SSS; PopCatchFrame(); LLL;
1421 xPopUpdateFrame(obj);
1424 SSS; PopSeqFrame(); LLL;
1428 ASSERT(xSp==(P_)xSu);
1431 fprintf(stderr, "hit a STOP_FRAME\n");
1433 fprintf(stderr,"xSp = %p\txSu = %p\n", xSp, xSu);
1434 printStack(xSp,cap->rCurrentTSO->stack
1435 + cap->rCurrentTSO->stack_size,xSu);
1438 SSS; PopStopFrame(obj); LLL;
1439 RETURN(ThreadFinished);
1449 /* was: goto enterLoop;
1450 But we know that obj must be a bco now, so jump directly.
1453 case RET_SMALL: /* return to GHC */
1457 cap->rCurrentTSO->whatNext = ThreadEnterGHC;
1459 RETURN(ThreadYielding);
1461 belch("entered CONSTR with invalid continuation on stack");
1464 printObj(stgCast(StgClosure*,xSp));
1467 barf("bailing out");
1474 //fprintf(stderr, "enterCountI = %d\n", enterCountI);
1475 //fprintf(stderr, "entering unknown closure -- yielding to sched\n");
1478 cap->rCurrentTSO->whatNext = ThreadEnterGHC;
1479 xPushCPtr(obj); /* code to restart with */
1480 RETURN(ThreadYielding);
1483 barf("Ran off the end of enter - yoiks");
1500 #undef xSetStackWord
1503 #undef xPushTaggedInt
1504 #undef xPopTaggedInt
1505 #undef xTaggedStackInt
1506 #undef xPushTaggedWord
1507 #undef xPopTaggedWord
1508 #undef xTaggedStackWord
1509 #undef xPushTaggedAddr
1510 #undef xTaggedStackAddr
1511 #undef xPopTaggedAddr
1512 #undef xPushTaggedStable
1513 #undef xTaggedStackStable
1514 #undef xPopTaggedStable
1515 #undef xPushTaggedChar
1516 #undef xTaggedStackChar
1517 #undef xPopTaggedChar
1518 #undef xPushTaggedFloat
1519 #undef xTaggedStackFloat
1520 #undef xPopTaggedFloat
1521 #undef xPushTaggedDouble
1522 #undef xTaggedStackDouble
1523 #undef xPopTaggedDouble
1524 #undef xPopUpdateFrame
1525 #undef xPushUpdateFrame
1528 /* --------------------------------------------------------------------------
1529 * Supporting routines for primops
1530 * ------------------------------------------------------------------------*/
1532 static inline void PushTag ( StackTag t )
1534 inline void PushPtr ( StgPtr x )
1535 { *(--stgCast(StgPtr*,gSp)) = x; }
1536 static inline void PushCPtr ( StgClosure* x )
1537 { *(--stgCast(StgClosure**,gSp)) = x; }
1538 static inline void PushInt ( StgInt x )
1539 { *(--stgCast(StgInt*,gSp)) = x; }
1540 static inline void PushWord ( StgWord x )
1541 { *(--stgCast(StgWord*,gSp)) = x; }
1544 static inline void checkTag ( StackTag t1, StackTag t2 )
1545 { ASSERT(t1 == t2);}
1546 static inline void PopTag ( StackTag t )
1547 { checkTag(t,*(gSp++)); }
1548 inline StgPtr PopPtr ( void )
1549 { return *stgCast(StgPtr*,gSp)++; }
1550 static inline StgClosure* PopCPtr ( void )
1551 { return *stgCast(StgClosure**,gSp)++; }
1552 static inline StgInt PopInt ( void )
1553 { return *stgCast(StgInt*,gSp)++; }
1554 static inline StgWord PopWord ( void )
1555 { return *stgCast(StgWord*,gSp)++; }
1557 static inline StgPtr stackPtr ( StgStackOffset i )
1558 { return *stgCast(StgPtr*, gSp+i); }
1559 static inline StgInt stackInt ( StgStackOffset i )
1560 { return *stgCast(StgInt*, gSp+i); }
1561 static inline StgWord stackWord ( StgStackOffset i )
1562 { return *stgCast(StgWord*,gSp+i); }
1564 static inline void setStackWord ( StgStackOffset i, StgWord w )
1567 static inline void PushTaggedRealWorld( void )
1568 { PushTag(REALWORLD_TAG); }
1569 inline void PushTaggedInt ( StgInt x )
1570 { gSp -= sizeofW(StgInt); *gSp = x; PushTag(INT_TAG); }
1571 inline void PushTaggedWord ( StgWord x )
1572 { gSp -= sizeofW(StgWord); *gSp = x; PushTag(WORD_TAG); }
1573 inline void PushTaggedAddr ( StgAddr x )
1574 { gSp -= sizeofW(StgAddr); *gSp = (W_)x; PushTag(ADDR_TAG); }
1575 inline void PushTaggedChar ( StgChar x )
1576 { gSp -= sizeofW(StgChar); *gSp = stgCast(StgWord,x); PushTag(CHAR_TAG); }
1577 inline void PushTaggedFloat ( StgFloat x )
1578 { gSp -= sizeofW(StgFloat); ASSIGN_FLT(gSp,x); PushTag(FLOAT_TAG); }
1579 inline void PushTaggedDouble ( StgDouble x )
1580 { gSp -= sizeofW(StgDouble); ASSIGN_DBL(gSp,x); PushTag(DOUBLE_TAG); }
1581 inline void PushTaggedStablePtr ( StgStablePtr x )
1582 { gSp -= sizeofW(StgStablePtr); *gSp = x; PushTag(STABLE_TAG); }
1583 static inline void PushTaggedBool ( int x )
1584 { PushTaggedInt(x); }
1588 static inline void PopTaggedRealWorld ( void )
1589 { PopTag(REALWORLD_TAG); }
1590 inline StgInt PopTaggedInt ( void )
1591 { StgInt r; PopTag(INT_TAG); r = *stgCast(StgInt*, gSp);
1592 gSp += sizeofW(StgInt); return r;}
1593 inline StgWord PopTaggedWord ( void )
1594 { StgWord r; PopTag(WORD_TAG); r = *stgCast(StgWord*, gSp);
1595 gSp += sizeofW(StgWord); return r;}
1596 inline StgAddr PopTaggedAddr ( void )
1597 { StgAddr r; PopTag(ADDR_TAG); r = *stgCast(StgAddr*, gSp);
1598 gSp += sizeofW(StgAddr); return r;}
1599 inline StgChar PopTaggedChar ( void )
1600 { StgChar r; PopTag(CHAR_TAG); r = stgCast(StgChar, *gSp);
1601 gSp += sizeofW(StgChar); return r;}
1602 inline StgFloat PopTaggedFloat ( void )
1603 { StgFloat r; PopTag(FLOAT_TAG); r = PK_FLT(gSp);
1604 gSp += sizeofW(StgFloat); return r;}
1605 inline StgDouble PopTaggedDouble ( void )
1606 { StgDouble r; PopTag(DOUBLE_TAG); r = PK_DBL(gSp);
1607 gSp += sizeofW(StgDouble); return r;}
1608 inline StgStablePtr PopTaggedStablePtr ( void )
1609 { StgInt r; PopTag(STABLE_TAG); r = *stgCast(StgStablePtr*, gSp);
1610 gSp += sizeofW(StgStablePtr); return r;}
1614 static inline StgInt taggedStackInt ( StgStackOffset i )
1615 { checkTag(INT_TAG,gSp[i]); return *stgCast(StgInt*, gSp+1+i); }
1616 static inline StgWord taggedStackWord ( StgStackOffset i )
1617 { checkTag(WORD_TAG,gSp[i]); return *stgCast(StgWord*, gSp+1+i); }
1618 static inline StgAddr taggedStackAddr ( StgStackOffset i )
1619 { checkTag(ADDR_TAG,gSp[i]); return *stgCast(StgAddr*, gSp+1+i); }
1620 static inline StgChar taggedStackChar ( StgStackOffset i )
1621 { checkTag(CHAR_TAG,gSp[i]); return stgCast(StgChar, *(gSp+1+i)) ; }
1622 static inline StgFloat taggedStackFloat ( StgStackOffset i )
1623 { checkTag(FLOAT_TAG,gSp[i]); return PK_FLT(gSp+1+i); }
1624 static inline StgDouble taggedStackDouble ( StgStackOffset i )
1625 { checkTag(DOUBLE_TAG,gSp[i]); return PK_DBL(gSp+1+i); }
1626 static inline StgStablePtr taggedStackStable ( StgStackOffset i )
1627 { checkTag(STABLE_TAG,gSp[i]); return *stgCast(StgStablePtr*, gSp+1+i); }
1630 /* --------------------------------------------------------------------------
1633 * Should we allocate from a nursery or use the
1634 * doYouWantToGC/allocate interface? We'd already implemented a
1635 * nursery-style scheme when the doYouWantToGC/allocate interface
1637 * One reason to prefer the doYouWantToGC/allocate interface is to
1638 * support operations which allocate an unknown amount in the heap
1639 * (array ops, gmp ops, etc)
1640 * ------------------------------------------------------------------------*/
1642 static inline StgPtr grabHpUpd( nat size )
1644 ASSERT( size >= MIN_UPD_SIZE + sizeofW(StgHeader) );
1645 #ifdef CRUDE_PROFILING
1646 cp_bill_words ( size );
1648 return allocate(size);
1651 static inline StgPtr grabHpNonUpd( nat size )
1653 ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
1654 #ifdef CRUDE_PROFILING
1655 cp_bill_words ( size );
1657 return allocate(size);
1660 /* --------------------------------------------------------------------------
1661 * Manipulate "update frame" list:
1662 * o Update frames (based on stg_do_update and friends in Updates.hc)
1663 * o Error handling/catching (based on catchzh_fast and friends in Prims.hc)
1664 * o Seq frames (based on seq_frame_entry in Prims.hc)
1666 * ------------------------------------------------------------------------*/
1668 static inline void PopUpdateFrame ( StgClosure* obj )
1670 /* NB: doesn't assume that gSp == gSu */
1672 fprintf(stderr, "Updating ");
1673 printPtr(stgCast(StgPtr,gSu->updatee));
1674 fprintf(stderr, " with ");
1676 fprintf(stderr,"gSp = %p\tgSu = %p\n\n", gSp, gSu);
1678 #ifdef EAGER_BLACKHOLING
1679 #warn LAZY_BLACKHOLING is default for StgHugs
1680 #error Dont know if EAGER_BLACKHOLING works in StgHugs
1681 ASSERT(get_itbl(gSu->updatee)->type == BLACKHOLE
1682 || get_itbl(gSu->updatee)->type == SE_BLACKHOLE
1683 || get_itbl(gSu->updatee)->type == CAF_BLACKHOLE
1684 || get_itbl(gSu->updatee)->type == SE_CAF_BLACKHOLE
1686 #endif /* EAGER_BLACKHOLING */
1687 UPD_IND(gSu->updatee,obj);
1688 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgUpdateFrame);
1692 static inline void PopStopFrame ( StgClosure* obj )
1694 /* Move gSu just off the end of the stack, we're about to gSpam the
1695 * STOP_FRAME with the return value.
1697 gSu = stgCast(StgUpdateFrame*,gSp+1);
1698 *stgCast(StgClosure**,gSp) = obj;
1701 static inline void PushCatchFrame ( StgClosure* handler )
1704 /* ToDo: stack check! */
1705 gSp -= sizeofW(StgCatchFrame);
1706 fp = stgCast(StgCatchFrame*,gSp);
1707 SET_HDR(fp,(StgInfoTable*)&catch_frame_info,CCCS);
1708 fp->handler = handler;
1710 gSu = stgCast(StgUpdateFrame*,fp);
1713 static inline void PopCatchFrame ( void )
1715 /* NB: doesn't assume that gSp == gSu */
1716 /* fprintf(stderr,"Popping catch frame\n"); */
1717 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgCatchFrame);
1718 gSu = stgCast(StgCatchFrame*,gSu)->link;
1721 static inline void PushSeqFrame ( void )
1724 /* ToDo: stack check! */
1725 gSp -= sizeofW(StgSeqFrame);
1726 fp = stgCast(StgSeqFrame*,gSp);
1727 SET_HDR(fp,(StgInfoTable*)&seq_frame_info,CCCS);
1729 gSu = stgCast(StgUpdateFrame*,fp);
1732 static inline void PopSeqFrame ( void )
1734 /* NB: doesn't assume that gSp == gSu */
1735 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgSeqFrame);
1736 gSu = stgCast(StgSeqFrame*,gSu)->link;
1739 static inline StgClosure* raiseAnError ( StgClosure* exception )
1741 /* This closure represents the expression 'primRaise E' where E
1742 * is the exception raised (:: Exception).
1743 * It is used to overwrite all the
1744 * thunks which are currently under evaluation.
1746 HaskellObj primRaiseClosure
1747 = asmClosureOfObject(getHugs_AsmObject_for("primRaise"));
1748 HaskellObj reraiseClosure
1749 = rts_apply ( primRaiseClosure, exception );
1752 switch (get_itbl(gSu)->type) {
1754 UPD_IND(gSu->updatee,reraiseClosure);
1755 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgUpdateFrame);
1761 case CATCH_FRAME: /* found it! */
1763 StgCatchFrame* fp = stgCast(StgCatchFrame*,gSu);
1764 StgClosure *handler = fp->handler;
1766 gSp += sizeofW(StgCatchFrame); /* Pop */
1767 PushCPtr(exception);
1771 barf("raiseError: uncaught exception: STOP_FRAME");
1773 barf("raiseError: weird activation record");
1779 static StgClosure* makeErrorCall ( const char* msg )
1781 /* Note! the msg string should be allocated in a
1782 place which will not get freed -- preferably
1783 read-only data of the program. That's because
1784 the thunk we build here may linger indefinitely.
1785 (thinks: probably not so, but anyway ...)
1788 = asmClosureOfObject(getHugs_AsmObject_for("error"));
1790 = asmClosureOfObject(getHugs_AsmObject_for("hugsprimUnpackString"));
1792 = rts_apply ( unpack, rts_mkAddr ( (void*)msg ) );
1794 = rts_apply ( error, thunk );
1796 (StgClosure*) thunk;
1799 #define raiseIndex(where) makeErrorCall("Array index out of range in " where)
1800 #define raiseDiv0(where) makeErrorCall("Division by zero in " where)
1802 /* --------------------------------------------------------------------------
1804 * ------------------------------------------------------------------------*/
1806 #define OP_CC_B(e) \
1808 unsigned char x = PopTaggedChar(); \
1809 unsigned char y = PopTaggedChar(); \
1810 PushTaggedBool(e); \
1815 unsigned char x = PopTaggedChar(); \
1824 #define OP_IW_I(e) \
1826 StgInt x = PopTaggedInt(); \
1827 StgWord y = PopTaggedWord(); \
1831 #define OP_II_I(e) \
1833 StgInt x = PopTaggedInt(); \
1834 StgInt y = PopTaggedInt(); \
1838 #define OP_II_B(e) \
1840 StgInt x = PopTaggedInt(); \
1841 StgInt y = PopTaggedInt(); \
1842 PushTaggedBool(e); \
1847 PushTaggedAddr(e); \
1852 StgInt x = PopTaggedInt(); \
1853 PushTaggedAddr(e); \
1858 StgInt x = PopTaggedInt(); \
1864 PushTaggedChar(e); \
1869 StgInt x = PopTaggedInt(); \
1870 PushTaggedChar(e); \
1875 PushTaggedWord(e); \
1880 StgInt x = PopTaggedInt(); \
1881 PushTaggedWord(e); \
1886 StgInt x = PopTaggedInt(); \
1887 PushTaggedStablePtr(e); \
1892 PushTaggedFloat(e); \
1897 StgInt x = PopTaggedInt(); \
1898 PushTaggedFloat(e); \
1903 PushTaggedDouble(e); \
1908 StgInt x = PopTaggedInt(); \
1909 PushTaggedDouble(e); \
1912 #define OP_WW_B(e) \
1914 StgWord x = PopTaggedWord(); \
1915 StgWord y = PopTaggedWord(); \
1916 PushTaggedBool(e); \
1919 #define OP_WW_W(e) \
1921 StgWord x = PopTaggedWord(); \
1922 StgWord y = PopTaggedWord(); \
1923 PushTaggedWord(e); \
1928 StgWord x = PopTaggedWord(); \
1934 StgStablePtr x = PopTaggedStablePtr(); \
1940 StgWord x = PopTaggedWord(); \
1941 PushTaggedWord(e); \
1944 #define OP_AA_B(e) \
1946 StgAddr x = PopTaggedAddr(); \
1947 StgAddr y = PopTaggedAddr(); \
1948 PushTaggedBool(e); \
1952 StgAddr x = PopTaggedAddr(); \
1955 #define OP_AI_C(s) \
1957 StgAddr x = PopTaggedAddr(); \
1958 int y = PopTaggedInt(); \
1961 PushTaggedChar(r); \
1963 #define OP_AI_I(s) \
1965 StgAddr x = PopTaggedAddr(); \
1966 int y = PopTaggedInt(); \
1971 #define OP_AI_A(s) \
1973 StgAddr x = PopTaggedAddr(); \
1974 int y = PopTaggedInt(); \
1977 PushTaggedAddr(s); \
1979 #define OP_AI_F(s) \
1981 StgAddr x = PopTaggedAddr(); \
1982 int y = PopTaggedInt(); \
1985 PushTaggedFloat(r); \
1987 #define OP_AI_D(s) \
1989 StgAddr x = PopTaggedAddr(); \
1990 int y = PopTaggedInt(); \
1993 PushTaggedDouble(r); \
1995 #define OP_AI_s(s) \
1997 StgAddr x = PopTaggedAddr(); \
1998 int y = PopTaggedInt(); \
2001 PushTaggedStablePtr(r); \
2003 #define OP_AIC_(s) \
2005 StgAddr x = PopTaggedAddr(); \
2006 int y = PopTaggedInt(); \
2007 StgChar z = PopTaggedChar(); \
2010 #define OP_AII_(s) \
2012 StgAddr x = PopTaggedAddr(); \
2013 int y = PopTaggedInt(); \
2014 StgInt z = PopTaggedInt(); \
2017 #define OP_AIA_(s) \
2019 StgAddr x = PopTaggedAddr(); \
2020 int y = PopTaggedInt(); \
2021 StgAddr z = PopTaggedAddr(); \
2024 #define OP_AIF_(s) \
2026 StgAddr x = PopTaggedAddr(); \
2027 int y = PopTaggedInt(); \
2028 StgFloat z = PopTaggedFloat(); \
2031 #define OP_AID_(s) \
2033 StgAddr x = PopTaggedAddr(); \
2034 int y = PopTaggedInt(); \
2035 StgDouble z = PopTaggedDouble(); \
2038 #define OP_AIs_(s) \
2040 StgAddr x = PopTaggedAddr(); \
2041 int y = PopTaggedInt(); \
2042 StgStablePtr z = PopTaggedStablePtr(); \
2047 #define OP_FF_B(e) \
2049 StgFloat x = PopTaggedFloat(); \
2050 StgFloat y = PopTaggedFloat(); \
2051 PushTaggedBool(e); \
2054 #define OP_FF_F(e) \
2056 StgFloat x = PopTaggedFloat(); \
2057 StgFloat y = PopTaggedFloat(); \
2058 PushTaggedFloat(e); \
2063 StgFloat x = PopTaggedFloat(); \
2064 PushTaggedFloat(e); \
2069 StgFloat x = PopTaggedFloat(); \
2070 PushTaggedBool(e); \
2075 StgFloat x = PopTaggedFloat(); \
2081 StgFloat x = PopTaggedFloat(); \
2082 PushTaggedDouble(e); \
2085 #define OP_DD_B(e) \
2087 StgDouble x = PopTaggedDouble(); \
2088 StgDouble y = PopTaggedDouble(); \
2089 PushTaggedBool(e); \
2092 #define OP_DD_D(e) \
2094 StgDouble x = PopTaggedDouble(); \
2095 StgDouble y = PopTaggedDouble(); \
2096 PushTaggedDouble(e); \
2101 StgDouble x = PopTaggedDouble(); \
2102 PushTaggedBool(e); \
2107 StgDouble x = PopTaggedDouble(); \
2108 PushTaggedDouble(e); \
2113 StgDouble x = PopTaggedDouble(); \
2119 StgDouble x = PopTaggedDouble(); \
2120 PushTaggedFloat(e); \
2124 StgPtr CreateByteArrayToHoldInteger ( int nbytes )
2126 StgWord words = (nbytes+sizeof(W_)-1)/sizeof(W_);
2127 StgWord size = sizeofW(StgArrWords) + words;
2128 StgArrWords* arr = (StgArrWords*)allocate(size);
2129 SET_HDR(arr,&ARR_WORDS_info,CCCS);
2131 ASSERT((W_)nbytes <= arr->words * sizeof(W_));
2134 for (i = 0; i < words; ++i) {
2135 arr->payload[i] = 0xdeadbeef;
2137 { B* b = (B*) &(arr->payload[0]);
2138 b->used = b->sign = 0;
2144 B* IntegerInsideByteArray ( StgPtr arr0 )
2147 StgArrWords* arr = (StgArrWords*)arr0;
2148 ASSERT(GET_INFO(arr) == &ARR_WORDS_info);
2149 b = (B*) &(arr->payload[0]);
2153 void SloppifyIntegerEnd ( StgPtr arr0 )
2155 StgArrWords* arr = (StgArrWords*)arr0;
2156 B* b = (B*) & (arr->payload[0]);
2157 I_ nwunused = arr->words - sizeofW(B) - (b->used+sizeof(W_)-1)/sizeof(W_);
2158 if (nwunused >= ((I_)sizeofW(StgArrWords))) {
2160 b->size -= nwunused * sizeof(W_);
2161 if (b->size < b->used) b->size = b->used;
2164 arr->words -= nwunused;
2165 slop = (StgArrWords*)&(arr->payload[arr->words]);
2166 SET_HDR(slop,&ARR_WORDS_info,CCCS);
2167 slop->words = nwunused - sizeofW(StgArrWords);
2168 ASSERT( &(slop->payload[slop->words]) ==
2169 &(arr->payload[arr->words + nwunused]) );
2173 #define OP_Z_Z(op) \
2175 B* x = IntegerInsideByteArray(PopPtr()); \
2176 int n = mycat2(size_,op)(x); \
2177 StgPtr p = CreateByteArrayToHoldInteger(n); \
2178 mycat2(do_,op)(x,n,IntegerInsideByteArray(p)); \
2179 SloppifyIntegerEnd(p); \
2182 #define OP_ZZ_Z(op) \
2184 B* x = IntegerInsideByteArray(PopPtr()); \
2185 B* y = IntegerInsideByteArray(PopPtr()); \
2186 int n = mycat2(size_,op)(x,y); \
2187 StgPtr p = CreateByteArrayToHoldInteger(n); \
2188 mycat2(do_,op)(x,y,n,IntegerInsideByteArray(p)); \
2189 SloppifyIntegerEnd(p); \
2196 #define HEADER_mI(ty,where) \
2197 StgArrWords* x = stgCast(StgArrWords*,PopPtr()); \
2198 nat i = PopTaggedInt(); \
2199 if (i * sizeof(ty) + (sizeof(ty)) > sizeof(StgWord) * x->words) { \
2200 return (raiseIndex(where)); \
2202 #define OP_mI_ty(ty,where,s) \
2204 HEADER_mI(mycat2(Stg,ty),where) \
2205 { mycat2(Stg,ty) r; \
2207 mycat2(PushTagged,ty)(r); \
2210 #define OP_mIty_(ty,where,s) \
2212 HEADER_mI(mycat2(Stg,ty),where) \
2214 mycat2(Stg,ty) z = mycat2(PopTagged,ty)(); \
2220 static void myStackCheck ( Capability* cap )
2222 /* fprintf(stderr, "myStackCheck\n"); */
2223 if (!(gSpLim <= gSp && gSp <= stgCast(StgPtr,gSu))) {
2224 fprintf(stderr, "myStackCheck: invalid initial gSp/gSu \n" );
2228 if (!( (P_)gSu >= (P_)cap->rCurrentTSO->stack
2230 (P_)gSu <= (P_)(cap->rCurrentTSO->stack
2231 + cap->rCurrentTSO->stack_size))) {
2232 fprintf ( stderr, "myStackCheck: gSu out of stack\n" );
2235 switch (get_itbl(stgCast(StgClosure*,gSu))->type) {
2237 gSu = (StgUpdateFrame*) ((StgCatchFrame*)(gSu))->link;
2240 gSu = (StgUpdateFrame*) ((StgUpdateFrame*)(gSu))->link;
2243 gSu = (StgUpdateFrame*) ((StgSeqFrame*)(gSu))->link;
2248 fprintf(stderr, "myStackCheck: invalid activation record\n"); assert(0);
2255 /* --------------------------------------------------------------------------
2256 * Primop stuff for bytecode interpreter
2257 * ------------------------------------------------------------------------*/
2259 /* Returns & of the next thing to enter (if throwing an exception),
2260 or NULL in the normal case.
2262 static void* enterBCO_primop1 ( int primop1code )
2265 barf("enterBCO_primop1 in combined mode");
2267 switch (primop1code) {
2268 case i_pushseqframe:
2270 StgClosure* c = PopCPtr();
2275 case i_pushcatchframe:
2277 StgClosure* e = PopCPtr();
2278 StgClosure* h = PopCPtr();
2284 case i_gtChar: OP_CC_B(x>y); break;
2285 case i_geChar: OP_CC_B(x>=y); break;
2286 case i_eqChar: OP_CC_B(x==y); break;
2287 case i_neChar: OP_CC_B(x!=y); break;
2288 case i_ltChar: OP_CC_B(x<y); break;
2289 case i_leChar: OP_CC_B(x<=y); break;
2290 case i_charToInt: OP_C_I(x); break;
2291 case i_intToChar: OP_I_C(x); break;
2293 case i_gtInt: OP_II_B(x>y); break;
2294 case i_geInt: OP_II_B(x>=y); break;
2295 case i_eqInt: OP_II_B(x==y); break;
2296 case i_neInt: OP_II_B(x!=y); break;
2297 case i_ltInt: OP_II_B(x<y); break;
2298 case i_leInt: OP_II_B(x<=y); break;
2299 case i_minInt: OP__I(INT_MIN); break;
2300 case i_maxInt: OP__I(INT_MAX); break;
2301 case i_plusInt: OP_II_I(x+y); break;
2302 case i_minusInt: OP_II_I(x-y); break;
2303 case i_timesInt: OP_II_I(x*y); break;
2306 int x = PopTaggedInt();
2307 int y = PopTaggedInt();
2309 return (raiseDiv0("quotInt"));
2311 /* ToDo: protect against minInt / -1 errors
2312 * (repeat for all other division primops) */
2318 int x = PopTaggedInt();
2319 int y = PopTaggedInt();
2321 return (raiseDiv0("remInt"));
2328 StgInt x = PopTaggedInt();
2329 StgInt y = PopTaggedInt();
2331 return (raiseDiv0("quotRemInt"));
2333 PushTaggedInt(x%y); /* last result */
2334 PushTaggedInt(x/y); /* first result */
2337 case i_negateInt: OP_I_I(-x); break;
2339 case i_andInt: OP_II_I(x&y); break;
2340 case i_orInt: OP_II_I(x|y); break;
2341 case i_xorInt: OP_II_I(x^y); break;
2342 case i_notInt: OP_I_I(~x); break;
2343 case i_shiftLInt: OP_II_I(x<<y); break;
2344 case i_shiftRAInt: OP_II_I(x>>y); break; /* ToDo */
2345 case i_shiftRLInt: OP_II_I(x>>y); break; /* ToDo */
2347 case i_gtWord: OP_WW_B(x>y); break;
2348 case i_geWord: OP_WW_B(x>=y); break;
2349 case i_eqWord: OP_WW_B(x==y); break;
2350 case i_neWord: OP_WW_B(x!=y); break;
2351 case i_ltWord: OP_WW_B(x<y); break;
2352 case i_leWord: OP_WW_B(x<=y); break;
2353 case i_minWord: OP__W(0); break;
2354 case i_maxWord: OP__W(UINT_MAX); break;
2355 case i_plusWord: OP_WW_W(x+y); break;
2356 case i_minusWord: OP_WW_W(x-y); break;
2357 case i_timesWord: OP_WW_W(x*y); break;
2360 StgWord x = PopTaggedWord();
2361 StgWord y = PopTaggedWord();
2363 return (raiseDiv0("quotWord"));
2365 PushTaggedWord(x/y);
2370 StgWord x = PopTaggedWord();
2371 StgWord y = PopTaggedWord();
2373 return (raiseDiv0("remWord"));
2375 PushTaggedWord(x%y);
2380 StgWord x = PopTaggedWord();
2381 StgWord y = PopTaggedWord();
2383 return (raiseDiv0("quotRemWord"));
2385 PushTaggedWord(x%y); /* last result */
2386 PushTaggedWord(x/y); /* first result */
2389 case i_negateWord: OP_W_W(-x); break;
2390 case i_andWord: OP_WW_W(x&y); break;
2391 case i_orWord: OP_WW_W(x|y); break;
2392 case i_xorWord: OP_WW_W(x^y); break;
2393 case i_notWord: OP_W_W(~x); break;
2394 case i_shiftLWord: OP_WW_W(x<<y); break;
2395 case i_shiftRAWord: OP_WW_W(x>>y); break; /* ToDo */
2396 case i_shiftRLWord: OP_WW_W(x>>y); break; /* ToDo */
2397 case i_intToWord: OP_I_W(x); break;
2398 case i_wordToInt: OP_W_I(x); break;
2400 case i_gtAddr: OP_AA_B(x>y); break;
2401 case i_geAddr: OP_AA_B(x>=y); break;
2402 case i_eqAddr: OP_AA_B(x==y); break;
2403 case i_neAddr: OP_AA_B(x!=y); break;
2404 case i_ltAddr: OP_AA_B(x<y); break;
2405 case i_leAddr: OP_AA_B(x<=y); break;
2406 case i_intToAddr: OP_I_A((StgAddr)x); break; /* ToDo */
2407 case i_addrToInt: OP_A_I((StgInt)x); break; /* ToDo */
2409 case i_intToStable: OP_I_s(x); break;
2410 case i_stableToInt: OP_s_I(x); break;
2412 case i_indexCharOffAddr: OP_AI_C(indexCharOffAddrzh(r,x,y)); break;
2413 case i_readCharOffAddr: OP_AI_C(indexCharOffAddrzh(r,x,y)); break;
2414 case i_writeCharOffAddr: OP_AIC_(writeCharOffAddrzh(x,y,z)); break;
2416 case i_indexIntOffAddr: OP_AI_I(indexIntOffAddrzh(r,x,y)); break;
2417 case i_readIntOffAddr: OP_AI_I(indexIntOffAddrzh(r,x,y)); break;
2418 case i_writeIntOffAddr: OP_AII_(writeIntOffAddrzh(x,y,z)); break;
2420 case i_indexAddrOffAddr: OP_AI_A(indexAddrOffAddrzh(r,x,y)); break;
2421 case i_readAddrOffAddr: OP_AI_A(indexAddrOffAddrzh(r,x,y)); break;
2422 case i_writeAddrOffAddr: OP_AIA_(writeAddrOffAddrzh(x,y,z)); break;
2424 case i_indexFloatOffAddr: OP_AI_F(indexFloatOffAddrzh(r,x,y)); break;
2425 case i_readFloatOffAddr: OP_AI_F(indexFloatOffAddrzh(r,x,y)); break;
2426 case i_writeFloatOffAddr: OP_AIF_(writeFloatOffAddrzh(x,y,z)); break;
2428 case i_indexDoubleOffAddr: OP_AI_D(indexDoubleOffAddrzh(r,x,y)); break;
2429 case i_readDoubleOffAddr: OP_AI_D(indexDoubleOffAddrzh(r,x,y)); break;
2430 case i_writeDoubleOffAddr: OP_AID_(writeDoubleOffAddrzh(x,y,z)); break;
2432 case i_indexStableOffAddr: OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break;
2433 case i_readStableOffAddr: OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break;
2434 case i_writeStableOffAddr: OP_AIs_(writeStablePtrOffAddrzh(x,y,z)); break;
2436 case i_compareInteger:
2438 B* x = IntegerInsideByteArray(PopPtr());
2439 B* y = IntegerInsideByteArray(PopPtr());
2440 StgInt r = do_cmp(x,y);
2441 PushTaggedInt(r<0 ? -1 : (r>0 ? 1 : 0));
2444 case i_negateInteger: OP_Z_Z(neg); break;
2445 case i_plusInteger: OP_ZZ_Z(add); break;
2446 case i_minusInteger: OP_ZZ_Z(sub); break;
2447 case i_timesInteger: OP_ZZ_Z(mul); break;
2448 case i_quotRemInteger:
2450 B* x = IntegerInsideByteArray(PopPtr());
2451 B* y = IntegerInsideByteArray(PopPtr());
2452 int n = size_qrm(x,y);
2453 StgPtr q = CreateByteArrayToHoldInteger(n);
2454 StgPtr r = CreateByteArrayToHoldInteger(n);
2455 if (do_getsign(y)==0)
2456 return (raiseDiv0("quotRemInteger"));
2457 do_qrm(x,y,n,IntegerInsideByteArray(q),
2458 IntegerInsideByteArray(r));
2459 SloppifyIntegerEnd(q);
2460 SloppifyIntegerEnd(r);
2465 case i_intToInteger:
2467 int n = size_fromInt();
2468 StgPtr p = CreateByteArrayToHoldInteger(n);
2469 do_fromInt( PopTaggedInt(), n, IntegerInsideByteArray(p));
2473 case i_wordToInteger:
2475 int n = size_fromWord();
2476 StgPtr p = CreateByteArrayToHoldInteger(n);
2477 do_fromWord( PopTaggedWord(), n, IntegerInsideByteArray(p));
2481 case i_integerToInt: PushTaggedInt(do_toInt(
2482 IntegerInsideByteArray(PopPtr())
2486 case i_integerToWord: PushTaggedWord(do_toWord(
2487 IntegerInsideByteArray(PopPtr())
2491 case i_integerToFloat: PushTaggedFloat(do_toFloat(
2492 IntegerInsideByteArray(PopPtr())
2496 case i_integerToDouble: PushTaggedDouble(do_toDouble(
2497 IntegerInsideByteArray(PopPtr())
2501 case i_gtFloat: OP_FF_B(x>y); break;
2502 case i_geFloat: OP_FF_B(x>=y); break;
2503 case i_eqFloat: OP_FF_B(x==y); break;
2504 case i_neFloat: OP_FF_B(x!=y); break;
2505 case i_ltFloat: OP_FF_B(x<y); break;
2506 case i_leFloat: OP_FF_B(x<=y); break;
2507 case i_minFloat: OP__F(FLT_MIN); break;
2508 case i_maxFloat: OP__F(FLT_MAX); break;
2509 case i_radixFloat: OP__I(FLT_RADIX); break;
2510 case i_digitsFloat: OP__I(FLT_MANT_DIG); break;
2511 case i_minExpFloat: OP__I(FLT_MIN_EXP); break;
2512 case i_maxExpFloat: OP__I(FLT_MAX_EXP); break;
2513 case i_plusFloat: OP_FF_F(x+y); break;
2514 case i_minusFloat: OP_FF_F(x-y); break;
2515 case i_timesFloat: OP_FF_F(x*y); break;
2518 StgFloat x = PopTaggedFloat();
2519 StgFloat y = PopTaggedFloat();
2520 PushTaggedFloat(x/y);
2523 case i_negateFloat: OP_F_F(-x); break;
2524 case i_floatToInt: OP_F_I(x); break;
2525 case i_intToFloat: OP_I_F(x); break;
2526 case i_expFloat: OP_F_F(exp(x)); break;
2527 case i_logFloat: OP_F_F(log(x)); break;
2528 case i_sqrtFloat: OP_F_F(sqrt(x)); break;
2529 case i_sinFloat: OP_F_F(sin(x)); break;
2530 case i_cosFloat: OP_F_F(cos(x)); break;
2531 case i_tanFloat: OP_F_F(tan(x)); break;
2532 case i_asinFloat: OP_F_F(asin(x)); break;
2533 case i_acosFloat: OP_F_F(acos(x)); break;
2534 case i_atanFloat: OP_F_F(atan(x)); break;
2535 case i_sinhFloat: OP_F_F(sinh(x)); break;
2536 case i_coshFloat: OP_F_F(cosh(x)); break;
2537 case i_tanhFloat: OP_F_F(tanh(x)); break;
2538 case i_powerFloat: OP_FF_F(pow(x,y)); break;
2540 case i_encodeFloatZ:
2542 StgPtr sig = PopPtr();
2543 StgInt exp = PopTaggedInt();
2545 B__encodeFloat(IntegerInsideByteArray(sig), exp)
2549 case i_decodeFloatZ:
2551 StgFloat f = PopTaggedFloat();
2552 StgPtr sig = CreateByteArrayToHoldInteger(size_fltmantissa());
2554 B__decodeFloat(IntegerInsideByteArray(sig), &exp, f);
2560 case i_isNaNFloat: OP_F_B(isFloatNaN(x)); break;
2561 case i_isInfiniteFloat: OP_F_B(isFloatInfinite(x)); break;
2562 case i_isNegativeZeroFloat: OP_F_B(isFloatNegativeZero(x)); break;
2563 case i_isDenormalizedFloat: OP_F_B(isFloatDenormalized(x)); break;
2564 case i_gtDouble: OP_DD_B(x>y); break;
2565 case i_geDouble: OP_DD_B(x>=y); break;
2566 case i_eqDouble: OP_DD_B(x==y); break;
2567 case i_neDouble: OP_DD_B(x!=y); break;
2568 case i_ltDouble: OP_DD_B(x<y); break;
2569 case i_leDouble: OP_DD_B(x<=y) break;
2570 case i_minDouble: OP__D(DBL_MIN); break;
2571 case i_maxDouble: OP__D(DBL_MAX); break;
2572 case i_radixDouble: OP__I(FLT_RADIX); break;
2573 case i_digitsDouble: OP__I(DBL_MANT_DIG); break;
2574 case i_minExpDouble: OP__I(DBL_MIN_EXP); break;
2575 case i_maxExpDouble: OP__I(DBL_MAX_EXP); break;
2576 case i_plusDouble: OP_DD_D(x+y); break;
2577 case i_minusDouble: OP_DD_D(x-y); break;
2578 case i_timesDouble: OP_DD_D(x*y); break;
2579 case i_divideDouble:
2581 StgDouble x = PopTaggedDouble();
2582 StgDouble y = PopTaggedDouble();
2583 PushTaggedDouble(x/y);
2586 case i_negateDouble: OP_D_D(-x); break;
2587 case i_doubleToInt: OP_D_I(x); break;
2588 case i_intToDouble: OP_I_D(x); break;
2589 case i_doubleToFloat: OP_D_F(x); break;
2590 case i_floatToDouble: OP_F_F(x); break;
2591 case i_expDouble: OP_D_D(exp(x)); break;
2592 case i_logDouble: OP_D_D(log(x)); break;
2593 case i_sqrtDouble: OP_D_D(sqrt(x)); break;
2594 case i_sinDouble: OP_D_D(sin(x)); break;
2595 case i_cosDouble: OP_D_D(cos(x)); break;
2596 case i_tanDouble: OP_D_D(tan(x)); break;
2597 case i_asinDouble: OP_D_D(asin(x)); break;
2598 case i_acosDouble: OP_D_D(acos(x)); break;
2599 case i_atanDouble: OP_D_D(atan(x)); break;
2600 case i_sinhDouble: OP_D_D(sinh(x)); break;
2601 case i_coshDouble: OP_D_D(cosh(x)); break;
2602 case i_tanhDouble: OP_D_D(tanh(x)); break;
2603 case i_powerDouble: OP_DD_D(pow(x,y)); break;
2605 case i_encodeDoubleZ:
2607 StgPtr sig = PopPtr();
2608 StgInt exp = PopTaggedInt();
2610 B__encodeDouble(IntegerInsideByteArray(sig), exp)
2614 case i_decodeDoubleZ:
2616 StgDouble d = PopTaggedDouble();
2617 StgPtr sig = CreateByteArrayToHoldInteger(size_dblmantissa());
2619 B__decodeDouble(IntegerInsideByteArray(sig), &exp, d);
2625 case i_isNaNDouble: OP_D_B(isDoubleNaN(x)); break;
2626 case i_isInfiniteDouble: OP_D_B(isDoubleInfinite(x)); break;
2627 case i_isNegativeZeroDouble: OP_D_B(isDoubleNegativeZero(x)); break;
2628 case i_isDenormalizedDouble: OP_D_B(isDoubleDenormalized(x)); break;
2629 case i_isIEEEDouble:
2631 PushTaggedBool(rtsTrue);
2635 barf("Unrecognised primop1");
2642 /* For normal cases, return NULL and leave *return2 unchanged.
2643 To return the address of the next thing to enter,
2644 return the address of it and leave *return2 unchanged.
2645 To return a StgThreadReturnCode to the scheduler,
2646 set *return2 to it and return a non-NULL value.
2648 static void* enterBCO_primop2 ( int primop2code,
2649 int* /*StgThreadReturnCode* */ return2,
2654 /* A small concession: we need to allow ccalls,
2655 even in combined mode.
2657 if (primop2code != i_ccall_ccall_IO &&
2658 primop2code != i_ccall_stdcall_IO)
2659 barf("enterBCO_primop2 in combined mode");
2662 switch (primop2code) {
2663 case i_raise: /* raise#{err} */
2665 StgClosure* err = PopCPtr();
2666 return (raiseAnError(err));
2671 StgClosure* init = PopCPtr();
2673 = stgCast(StgMutVar*,allocate(sizeofW(StgMutVar)));
2674 SET_HDR(mv,&MUT_VAR_info,CCCS);
2676 PushPtr(stgCast(StgPtr,mv));
2681 StgMutVar* mv = stgCast(StgMutVar*,PopPtr());
2687 StgMutVar* mv = stgCast(StgMutVar*,PopPtr());
2688 StgClosure* value = PopCPtr();
2694 nat n = PopTaggedInt(); /* or Word?? */
2695 StgClosure* init = PopCPtr();
2696 StgWord size = sizeofW(StgMutArrPtrs) + n;
2699 = stgCast(StgMutArrPtrs*,allocate(size));
2700 SET_HDR(arr,&MUT_ARR_PTRS_info,CCCS);
2702 for (i = 0; i < n; ++i) {
2703 arr->payload[i] = init;
2705 PushPtr(stgCast(StgPtr,arr));
2711 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2712 nat i = PopTaggedInt(); /* or Word?? */
2713 StgWord n = arr->ptrs;
2715 return (raiseIndex("{index,read}Array"));
2717 PushCPtr(arr->payload[i]);
2722 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2723 nat i = PopTaggedInt(); /* or Word? */
2724 StgClosure* v = PopCPtr();
2725 StgWord n = arr->ptrs;
2727 return (raiseIndex("{index,read}Array"));
2729 arr->payload[i] = v;
2733 case i_sizeMutableArray:
2735 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2736 PushTaggedInt(arr->ptrs);
2739 case i_unsafeFreezeArray:
2741 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2742 SET_INFO(arr,&MUT_ARR_PTRS_FROZEN_info);
2743 PushPtr(stgCast(StgPtr,arr));
2746 case i_unsafeFreezeByteArray:
2748 /* Delightfully simple :-) */
2752 case i_sameMutableArray:
2753 case i_sameMutableByteArray:
2755 StgPtr x = PopPtr();
2756 StgPtr y = PopPtr();
2757 PushTaggedBool(x==y);
2761 case i_newByteArray:
2763 nat n = PopTaggedInt(); /* or Word?? */
2764 StgInt words = (n+sizeof(W_)-1)/sizeof(W_);
2765 StgWord size = sizeofW(StgArrWords) + words;
2766 StgArrWords* arr = stgCast(StgArrWords*,allocate(size));
2767 SET_HDR(arr,&ARR_WORDS_info,CCCS);
2771 for (i = 0; i < n; ++i) {
2772 arr->payload[i] = 0xdeadbeef;
2775 PushPtr(stgCast(StgPtr,arr));
2779 /* Most of these generate alignment warnings on Sparcs and similar architectures.
2780 * These are harmless and are caused by the cast to C* in BYTE_ARR_CTS.
2782 case i_indexCharArray:
2783 OP_mI_ty(Char,"indexCharArray", indexCharArrayzh(r,x,i)); break;
2784 case i_readCharArray:
2785 OP_mI_ty(Char,"readCharArray", readCharArrayzh(r,x,i)); break;
2786 case i_writeCharArray:
2787 OP_mIty_(Char,"writeCharArray", writeCharArrayzh(x,i,z)); break;
2789 case i_indexIntArray:
2790 OP_mI_ty(Int,"indexIntArray", indexIntArrayzh(r,x,i)); break;
2791 case i_readIntArray:
2792 OP_mI_ty(Int,"readIntArray", readIntArrayzh(r,x,i)); break;
2793 case i_writeIntArray:
2794 OP_mIty_(Int,"writeIntArray", writeIntArrayzh(x,i,z)); break;
2796 case i_indexAddrArray:
2797 OP_mI_ty(Addr,"indexAddrArray", indexAddrArrayzh(r,x,i)); break;
2798 case i_readAddrArray:
2799 OP_mI_ty(Addr,"readAddrArray", readAddrArrayzh(r,x,i)); break;
2800 case i_writeAddrArray:
2801 OP_mIty_(Addr,"writeAddrArray", writeAddrArrayzh(x,i,z)); break;
2803 case i_indexFloatArray:
2804 OP_mI_ty(Float,"indexFloatArray", indexFloatArrayzh(r,x,i)); break;
2805 case i_readFloatArray:
2806 OP_mI_ty(Float,"readFloatArray", readFloatArrayzh(r,x,i)); break;
2807 case i_writeFloatArray:
2808 OP_mIty_(Float,"writeFloatArray", writeFloatArrayzh(x,i,z)); break;
2810 case i_indexDoubleArray:
2811 OP_mI_ty(Double,"indexDoubleArray", indexDoubleArrayzh(r,x,i)); break;
2812 case i_readDoubleArray:
2813 OP_mI_ty(Double,"readDoubleArray", readDoubleArrayzh(r,x,i)); break;
2814 case i_writeDoubleArray:
2815 OP_mIty_(Double,"writeDoubleArray", writeDoubleArrayzh(x,i,z)); break;
2818 #ifdef PROVIDE_STABLE
2819 case i_indexStableArray:
2820 OP_mI_ty(StablePtr,"indexStableArray", indexStablePtrArrayzh(r,x,i)); break;
2821 case i_readStableArray:
2822 OP_mI_ty(StablePtr,"readStableArray", readStablePtrArrayzh(r,x,i)); break;
2823 case i_writeStableArray:
2824 OP_mIty_(StablePtr,"writeStableArray", writeStablePtrArrayzh(x,i,z)); break;
2830 #ifdef PROVIDE_COERCE
2831 case i_unsafeCoerce:
2833 /* Another nullop */
2837 #ifdef PROVIDE_PTREQUALITY
2838 case i_reallyUnsafePtrEquality:
2839 { /* identical to i_sameRef */
2840 StgPtr x = PopPtr();
2841 StgPtr y = PopPtr();
2842 PushTaggedBool(x==y);
2846 #ifdef PROVIDE_FOREIGN
2847 /* ForeignObj# operations */
2848 case i_makeForeignObj:
2850 StgForeignObj *result
2851 = stgCast(StgForeignObj*,allocate(sizeofW(StgForeignObj)));
2852 SET_HDR(result,&FOREIGN_info,CCCS);
2853 result -> data = PopTaggedAddr();
2854 PushPtr(stgCast(StgPtr,result));
2857 #endif /* PROVIDE_FOREIGN */
2862 = stgCast(StgWeak*,allocate(sizeofW(StgWeak)));
2863 SET_HDR(w, &WEAK_info, CCCS);
2865 w->value = PopCPtr();
2866 w->finaliser = PopCPtr();
2867 w->link = weak_ptr_list;
2869 IF_DEBUG(weak, fprintf(stderr,"New weak pointer at %p\n",w));
2870 PushPtr(stgCast(StgPtr,w));
2875 StgWeak *w = stgCast(StgWeak*,PopPtr());
2876 if (w->header.info == &WEAK_info) {
2877 PushCPtr(w->value); /* last result */
2878 PushTaggedInt(1); /* first result */
2880 PushPtr(stgCast(StgPtr,w));
2881 /* ToDo: error thunk would be better */
2886 #endif /* PROVIDE_WEAK */
2888 case i_makeStablePtr:
2890 StgPtr p = PopPtr();
2891 StgStablePtr sp = getStablePtr ( p );
2892 PushTaggedStablePtr(sp);
2895 case i_deRefStablePtr:
2898 StgStablePtr sp = PopTaggedStablePtr();
2899 p = deRefStablePtr(sp);
2903 case i_freeStablePtr:
2905 StgStablePtr sp = PopTaggedStablePtr();
2910 case i_createAdjThunkARCH:
2912 StgStablePtr stableptr = PopTaggedStablePtr();
2913 StgAddr typestr = PopTaggedAddr();
2914 StgChar callconv = PopTaggedChar();
2915 StgAddr adj_thunk = createAdjThunk(stableptr,typestr,callconv);
2916 PushTaggedAddr(adj_thunk);
2922 StgInt n = prog_argc;
2928 StgInt n = PopTaggedInt();
2929 StgAddr a = (StgAddr)prog_argv[n];
2936 StgMVar *mvar = stgCast(StgMVar*,allocate(sizeofW(StgMVar)));
2937 SET_INFO(mvar,&EMPTY_MVAR_info);
2938 mvar->head = mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
2939 mvar->value = stgCast(StgClosure*,&END_TSO_QUEUE_closure);
2940 PushPtr(stgCast(StgPtr,mvar));
2945 StgMVar *mvar = (StgMVar*)PopCPtr();
2946 if (GET_INFO(mvar) == &EMPTY_MVAR_info) {
2948 /* The MVar is empty. Attach ourselves to the TSO's
2951 if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
2952 mvar->head = cap->rCurrentTSO;
2954 mvar->tail->link = cap->rCurrentTSO;
2956 cap->rCurrentTSO->link = (StgTSO *)&END_TSO_QUEUE_closure;
2957 cap->rCurrentTSO->why_blocked = BlockedOnMVar;
2958 cap->rCurrentTSO->block_info.closure = (StgClosure *)mvar;
2959 mvar->tail = cap->rCurrentTSO;
2961 /* At this point, the top-of-stack holds the MVar,
2962 and underneath is the world token (). So the
2963 stack is in the same state as when primTakeMVar
2964 was entered (primTakeMVar is handwritten bytecode).
2965 Push obj, which is this BCO, and return to the
2966 scheduler. When the MVar is filled, the scheduler
2967 will re-enter primTakeMVar, with the args still on
2968 the top of the stack.
2970 PushCPtr((StgClosure*)(*bco));
2971 *return2 = ThreadBlocked;
2972 return (void*)(1+(char*)(NULL));
2975 PushCPtr(mvar->value);
2976 mvar->value = (StgClosure *)&END_TSO_QUEUE_closure;
2977 SET_INFO(mvar,&EMPTY_MVAR_info);
2983 StgMVar* mvar = stgCast(StgMVar*,PopPtr());
2984 StgClosure* value = PopCPtr();
2985 if (GET_INFO(mvar) == &FULL_MVAR_info) {
2986 return (makeErrorCall("putMVar {full MVar}"));
2988 /* wake up the first thread on the
2989 * queue, it will continue with the
2990 * takeMVar operation and mark the
2993 mvar->value = value;
2995 if (mvar->head != (StgTSO *)&END_TSO_QUEUE_closure) {
2996 ASSERT(mvar->head->why_blocked == BlockedOnMVar);
2997 mvar->head = unblockOne(mvar->head);
2998 if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
2999 mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
3003 /* unlocks the MVar in the SMP case */
3004 SET_INFO(mvar,&FULL_MVAR_info);
3006 /* yield for better communication performance */
3012 { /* identical to i_sameRef */
3013 StgMVar* x = (StgMVar*)PopPtr();
3014 StgMVar* y = (StgMVar*)PopPtr();
3015 PushTaggedBool(x==y);
3020 StgWord tid = cap->rCurrentTSO->id;
3021 PushTaggedWord(tid);
3024 case i_cmpThreadIds:
3026 StgWord tid1 = PopTaggedWord();
3027 StgWord tid2 = PopTaggedWord();
3028 if (tid1 < tid2) PushTaggedInt(-1);
3029 else if (tid1 > tid2) PushTaggedInt(1);
3030 else PushTaggedInt(0);
3035 StgClosure* closure;
3038 closure = PopCPtr();
3039 tso = createGenThread (RtsFlags.GcFlags.initialStkSize,closure);
3041 scheduleThread(tso);
3043 PushTaggedWord(tid);
3047 #ifdef PROVIDE_CONCURRENT
3050 StgTSO* tso = stgCast(StgTSO*,PopPtr());
3052 if (tso == cap->rCurrentTSO) { /* suicide */
3053 *return2 = ThreadFinished;
3054 return (void*)(1+(NULL));
3062 /* As PrimOps.h says: Hmm, I'll think about these later. */
3065 #endif /* PROVIDE_CONCURRENT */
3067 case i_ccall_ccall_Id:
3068 case i_ccall_ccall_IO:
3069 case i_ccall_stdcall_Id:
3070 case i_ccall_stdcall_IO:
3073 CFunDescriptor* descriptor;
3074 void (*funPtr)(void);
3076 descriptor = PopTaggedAddr();
3077 funPtr = PopTaggedAddr();
3078 cc = (primop2code == i_ccall_stdcall_Id ||
3079 primop2code == i_ccall_stdcall_IO)
3081 r = ccall(descriptor,funPtr,bco,cc,cap);
3084 return makeErrorCall(
3085 "unhandled type or too many args/results in ccall");
3087 barf("ccall not configured correctly for this platform");
3088 barf("unknown return code from ccall");
3091 barf("Unrecognised primop2");
3097 /* -----------------------------------------------------------------------------
3098 * ccall support code:
3099 * marshall moves args from C stack to Haskell stack
3100 * unmarshall moves args from Haskell stack to C stack
3101 * argSize calculates how much gSpace you need on the C stack
3102 * ---------------------------------------------------------------------------*/
3104 /* Pop arguments off the C stack and Push them onto the Hugs stack.
3105 * Used when preparing for C calling Haskell or in regSponse to
3106 * Haskell calling C.
3108 nat marshall(char arg_ty, void* arg)
3112 PushTaggedInt(*((int*)arg));
3113 return ARG_SIZE(INT_TAG);
3116 PushTaggedInteger(*((mpz_ptr*)arg));
3117 return ARG_SIZE(INTEGER_TAG);
3120 PushTaggedWord(*((unsigned int*)arg));
3121 return ARG_SIZE(WORD_TAG);
3123 PushTaggedChar(*((char*)arg));
3124 return ARG_SIZE(CHAR_TAG);
3126 PushTaggedFloat(*((float*)arg));
3127 return ARG_SIZE(FLOAT_TAG);
3129 PushTaggedDouble(*((double*)arg));
3130 return ARG_SIZE(DOUBLE_TAG);
3132 PushTaggedAddr(*((void**)arg));
3133 return ARG_SIZE(ADDR_TAG);
3135 PushTaggedStablePtr(*((StgStablePtr*)arg));
3136 return ARG_SIZE(STABLE_TAG);
3137 #ifdef PROVIDE_FOREIGN
3139 /* Not allowed in this direction - you have to
3140 * call makeForeignPtr explicitly
3142 barf("marshall: ForeignPtr#\n");
3147 /* Not allowed in this direction */
3148 barf("marshall: [Mutable]ByteArray#\n");
3151 barf("marshall: unrecognised arg type %d\n",arg_ty);
3156 /* Pop arguments off the Hugs stack and Push them onto the C stack.
3157 * Used when preparing for Haskell calling C or in regSponse to
3158 * C calling Haskell.
3160 nat unmarshall(char res_ty, void* res)
3164 *((int*)res) = PopTaggedInt();
3165 return ARG_SIZE(INT_TAG);
3168 *((mpz_ptr*)res) = PopTaggedInteger();
3169 return ARG_SIZE(INTEGER_TAG);
3172 *((unsigned int*)res) = PopTaggedWord();
3173 return ARG_SIZE(WORD_TAG);
3175 *((int*)res) = PopTaggedChar();
3176 return ARG_SIZE(CHAR_TAG);
3178 *((float*)res) = PopTaggedFloat();
3179 return ARG_SIZE(FLOAT_TAG);
3181 *((double*)res) = PopTaggedDouble();
3182 return ARG_SIZE(DOUBLE_TAG);
3184 *((void**)res) = PopTaggedAddr();
3185 return ARG_SIZE(ADDR_TAG);
3187 *((StgStablePtr*)res) = PopTaggedStablePtr();
3188 return ARG_SIZE(STABLE_TAG);
3189 #ifdef PROVIDE_FOREIGN
3192 StgForeignObj *result = stgCast(StgForeignObj*,PopPtr());
3193 *((void**)res) = result->data;
3194 return sizeofW(StgPtr);
3200 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
3201 *((void**)res) = stgCast(void*,&(arr->payload));
3202 return sizeofW(StgPtr);
3205 barf("unmarshall: unrecognised result type %d\n",res_ty);
3209 nat argSize( const char* ks )
3212 for( ; *ks != '\0'; ++ks) {
3215 sz += sizeof(StgWord) * ARG_SIZE(INT_TAG);
3219 sz += sizeof(StgWord) * ARG_SIZE(INTEGER_TAG);
3223 sz += sizeof(StgWord) * ARG_SIZE(WORD_TAG);
3226 sz += sizeof(StgWord) * ARG_SIZE(CHAR_TAG);
3229 sz += sizeof(StgWord) * ARG_SIZE(FLOAT_TAG);
3232 sz += sizeof(StgWord) * ARG_SIZE(DOUBLE_TAG);
3235 sz += sizeof(StgWord) * ARG_SIZE(ADDR_TAG);
3238 sz += sizeof(StgWord) * ARG_SIZE(STABLE_TAG);
3240 #ifdef PROVIDE_FOREIGN
3245 sz += sizeof(StgPtr);
3248 barf("argSize: unrecognised result type %d\n",*ks);
3256 /* -----------------------------------------------------------------------------
3257 * encode/decode Float/Double code for standalone Hugs
3258 * Code based on the HBC code (lib/fltcode.c) and more recently GHC
3259 * (ghc/rts/StgPrimFloat.c)
3260 * ---------------------------------------------------------------------------*/
3262 #if IEEE_FLOATING_POINT
3263 #define MY_DMINEXP ((DBL_MIN_EXP) - (DBL_MANT_DIG) - 1)
3264 /* DMINEXP is defined in values.h on Linux (for example) */
3265 #define DHIGHBIT 0x00100000
3266 #define DMSBIT 0x80000000
3268 #define MY_FMINEXP ((FLT_MIN_EXP) - (FLT_MANT_DIG) - 1)
3269 #define FHIGHBIT 0x00800000
3270 #define FMSBIT 0x80000000
3272 #error The following code doesnt work in a non-IEEE FP environment
3275 #ifdef WORDS_BIGENDIAN
3284 StgDouble B__encodeDouble (B* s, I_ e) /* result = s * 2^e */
3289 /* Convert a B to a double; knows a lot about internal rep! */
3290 for(r = 0.0, i = s->used-1; i >= 0; i--)
3291 r = (r * B_BASE_FLT) + s->stuff[i];
3293 /* Now raise to the exponent */
3294 if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
3297 /* handle the sign */
3298 if (s->sign < 0) r = -r;
3305 #if ! FLOATS_AS_DOUBLES
3306 StgFloat B__encodeFloat (B* s, I_ e) /* result = s * 2^e */
3311 /* Convert a B to a float; knows a lot about internal rep! */
3312 for(r = 0.0, i = s->used-1; i >= 0; i--)
3313 r = (r * B_BASE_FLT) + s->stuff[i];
3315 /* Now raise to the exponent */
3316 if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
3319 /* handle the sign */
3320 if (s->sign < 0) r = -r;
3324 #endif /* FLOATS_AS_DOUBLES */
3328 /* This only supports IEEE floating point */
3329 void B__decodeDouble (B* man, I_* exp, StgDouble dbl)
3331 /* Do some bit fiddling on IEEE */
3332 nat low, high; /* assuming 32 bit ints */
3334 union { double d; int i[2]; } u; /* assuming 32 bit ints, 64 bit double */
3336 u.d = dbl; /* grab chunks of the double */
3340 ASSERT(B_BASE == 256);
3342 /* Assume that the supplied B is the right size */
3345 if (low == 0 && (high & ~DMSBIT) == 0) {
3346 man->sign = man->used = 0;
3351 iexp = ((high >> 20) & 0x7ff) + MY_DMINEXP;
3355 if (iexp != MY_DMINEXP) /* don't add hidden bit to denorms */
3359 /* A denorm, normalize the mantissa */
3360 while (! (high & DHIGHBIT)) {
3370 man->stuff[7] = (((W_)high) >> 24) & 0xff;
3371 man->stuff[6] = (((W_)high) >> 16) & 0xff;
3372 man->stuff[5] = (((W_)high) >> 8) & 0xff;
3373 man->stuff[4] = (((W_)high) ) & 0xff;
3375 man->stuff[3] = (((W_)low) >> 24) & 0xff;
3376 man->stuff[2] = (((W_)low) >> 16) & 0xff;
3377 man->stuff[1] = (((W_)low) >> 8) & 0xff;
3378 man->stuff[0] = (((W_)low) ) & 0xff;
3380 if (sign < 0) man->sign = -1;
3382 do_renormalise(man);
3386 #if ! FLOATS_AS_DOUBLES
3387 void B__decodeFloat (B* man, I_* exp, StgFloat flt)
3389 /* Do some bit fiddling on IEEE */
3390 int high, sign; /* assuming 32 bit ints */
3391 union { float f; int i; } u; /* assuming 32 bit float and int */
3393 u.f = flt; /* grab the float */
3396 ASSERT(B_BASE == 256);
3398 /* Assume that the supplied B is the right size */
3401 if ((high & ~FMSBIT) == 0) {
3402 man->sign = man->used = 0;
3407 *exp = ((high >> 23) & 0xff) + MY_FMINEXP;
3411 if (*exp != MY_FMINEXP) /* don't add hidden bit to denorms */
3415 /* A denorm, normalize the mantissa */
3416 while (! (high & FHIGHBIT)) {
3421 man->stuff[3] = (((W_)high) >> 24) & 0xff;
3422 man->stuff[2] = (((W_)high) >> 16) & 0xff;
3423 man->stuff[1] = (((W_)high) >> 8) & 0xff;
3424 man->stuff[0] = (((W_)high) ) & 0xff;
3426 if (sign < 0) man->sign = -1;
3428 do_renormalise(man);
3431 #endif /* FLOATS_AS_DOUBLES */
3433 #endif /* INTERPRETER */