2 /* -----------------------------------------------------------------------------
5 * Copyright (c) 1994-1998.
7 * $RCSfile: Evaluator.c,v $
9 * $Date: 1999/11/18 16:02:18 $
10 * ---------------------------------------------------------------------------*/
20 #include "SchedAPI.h" /* for createGenThread */
21 #include "Schedule.h" /* for context_switch */
22 #include "Bytecodes.h"
23 #include "Assembler.h" /* for CFun stuff */
24 #include "ForeignCall.h"
25 #include "PrimOps.h" /* for __{encode,decode}{Float,Double} */
26 #include "Evaluator.h"
30 #include "Disassembler.h"
35 #include <math.h> /* These are for primops */
36 #include <limits.h> /* These are for primops */
37 #include <float.h> /* These are for primops */
39 #include <ieee754.h> /* These are for primops */
42 #ifdef STANDALONE_INTEGER
43 #include "sainteger.h"
45 #error Non-standalone integer not yet supported
48 /* An incredibly useful abbreviation.
49 * Interestingly, there are some uses of END_TSO_QUEUE_closure that
50 * can't use it because they use the closure at type StgClosure* or
51 * even StgPtr*. I suspect they should be changed. -- ADR
53 #define EndTSOQueue stgCast(StgTSO*,(void*)&END_TSO_QUEUE_closure)
55 /* These macros are rather delicate - read a good ANSI C book carefully
59 #define mycat(x,y) x##y
60 #define mycat2(x,y) mycat(x,y)
61 #define mycat3(x,y,z) mycat2(x,mycat2(y,z))
63 #if defined(__GNUC__) && !defined(DEBUG)
64 #define USE_GCC_LABELS 1
66 #define USE_GCC_LABELS 0
69 /* Make it possible for the evaluator to get hold of bytecode
70 for a given function by name. Useful but a hack. Sigh.
72 extern void* getHugs_AsmObject_for ( char* s );
75 /* --------------------------------------------------------------------------
76 * Crude profiling stuff (mainly to assess effect of optimiser)
77 * ------------------------------------------------------------------------*/
79 #ifdef CRUDE_PROFILING
88 struct { int /*StgVar*/ who;
96 CPRecord cpTab[M_CPTAB];
103 for (i = 0; i < M_CPTAB; i++)
104 cpTab[i].who = CP_NIL;
108 void cp_enter ( StgBCO* b )
112 int /*StgVar*/ v = b->stgexpr;
113 if ((void*)v == NULL) return;
122 h = (-v) % M_CPTAB; else
125 assert (h >= 0 && h < M_CPTAB);
126 while (cpTab[h].who != v && cpTab[h].who != CP_NIL) {
127 h++; if (h == M_CPTAB) h = 0;
130 if (cpTab[cpCurr].who == CP_NIL) {
131 cpTab[cpCurr].who = v;
132 if (!is_ret_cont) cpTab[cpCurr].enters = 1;
133 cpTab[cpCurr].bytes = cpTab[cpCurr].insns = 0;
135 if (cpInUse * 2 > M_CPTAB) {
136 fprintf(stderr, "\nCRUDE_PROFILING hash table is too full\n" );
140 if (!is_ret_cont) cpTab[cpCurr].enters++;
146 void cp_bill_words ( int nw )
148 if (cpCurr == CP_NIL) return;
149 cpTab[cpCurr].bytes += sizeof(StgWord)*nw;
153 void cp_bill_insns ( int ni )
155 if (cpCurr == CP_NIL) return;
156 cpTab[cpCurr].insns += ni;
160 static double percent ( double a, double b )
162 return (100.0 * a) / b;
166 void cp_show ( void )
168 int i, j, max, maxN, totE, totB, totI, cumE, cumB, cumI;
171 if (cpInUse == -1) return;
173 fflush(stdout);fflush(stderr);
176 totE = totB = totI = 0;
177 for (i = 0; i < M_CPTAB; i++) {
178 cpTab[i].twho = cpTab[i].who;
179 if (cpTab[i].who != CP_NIL) {
180 totE += cpTab[i].enters;
181 totB += cpTab[i].bytes;
182 totI += cpTab[i].insns;
187 "%6d (%7.3f M) enters, "
188 "%6d (%7.3f M) insns, "
189 "%6d (%7.3f M) bytes\n\n",
190 totE, totE/1000000.0, totI, totI/1000000.0, totB, totB/1000000.0 );
192 cumE = cumB = cumI = 0;
193 for (j = 0; j < 32; j++) {
196 for (i = 0; i < M_CPTAB; i++)
197 if (cpTab[i].who != CP_NIL &&
198 cpTab[i].enters > maxN) {
199 maxN = cpTab[i].enters;
202 if (max == -1) break;
204 cumE += cpTab[max].enters;
205 cumB += cpTab[max].bytes;
206 cumI += cpTab[max].insns;
208 strcpy(nm, maybeName(cpTab[max].who));
209 if (strcmp(nm, "(unknown)")==0)
210 sprintf ( nm, "id%d", -cpTab[max].who);
212 printf ( "%20s %7d es (%4.1f%%, %4.1f%% c) "
213 "%7d bs (%4.1f%%, %4.1f%% c) "
214 "%7d is (%4.1f%%, %4.1f%% c)\n",
216 cpTab[max].enters, percent(cpTab[max].enters,totE), percent(cumE,totE),
217 cpTab[max].bytes, percent(cpTab[max].bytes,totB), percent(cumB,totB),
218 cpTab[max].insns, percent(cpTab[max].insns,totI), percent(cumI,totI)
221 cpTab[max].twho = cpTab[max].who;
222 cpTab[max].who = CP_NIL;
225 for (i = 0; i < M_CPTAB; i++)
226 cpTab[i].who = cpTab[i].twho;
234 /* --------------------------------------------------------------------------
235 * Hugs Hooks - a bit of a hack
236 * ------------------------------------------------------------------------*/
238 void setRtsFlags( int x );
239 void setRtsFlags( int x )
241 unsigned int w = 0x12345678;
242 unsigned char* pw = (unsigned char *)&w;
245 *(int*)(&(RtsFlags.DebugFlags)) = x;
250 w2 |= (w1 && 0xFF); w2 <<= 8; w1 >>= 8;
251 w2 |= (w1 && 0xFF); w2 <<= 8; w1 >>= 8;
252 w2 |= (w1 && 0xFF); w2 <<= 8; w1 >>= 8;
253 w2 |= (w1 && 0xFF); w2 <<= 8; w1 >>= 8;
254 *(int*)(&(RtsFlags.DebugFlags)) = (int)w2;
259 /* --------------------------------------------------------------------------
260 * Entering-objects and bytecode interpreter part of evaluator
261 * ------------------------------------------------------------------------*/
263 /* The primop (and all other) parts of this evaluator operate upon the
264 machine state which lives in MainRegTable. enter is different:
265 to make its closure- and bytecode-interpreting loops go fast, some of that
266 state is pulled out into local vars (viz, registers, if we are lucky).
267 That means that we need to save(load) the local state at every exit(reentry)
268 into enter. That is, around every procedure call it makes. Blargh!
269 If you modify this code, __be warned__ it will fail in mysterious ways if
270 you fail to preserve this property.
272 Currently the pulled-out state is Sp in xSp, Su in xSu and SpLim in xSpLim.
273 The SSS macros saves the state back in MainRegTable, and LLL loads it from
274 MainRegTable. RETURN(v) does SSS and then returns v; all exits should
275 be via RETURN and not plain return.
277 Since xSp, xSu and xSpLim are local vars in enter, they are not visible
278 in procedures called from enter. To fix this, either (1) turn the
279 procedures into macros, so they get copied inline, or (2) bracket
280 the procedure call with SSS and LLL so that the local and global
281 machine states are synchronised for the duration of the call.
285 /* Forward decls ... */
286 static void* enterBCO_primop1 ( int );
287 static void* enterBCO_primop2 ( int , int* /*StgThreadReturnCode* */,
288 StgBCO**, Capability* );
289 static inline void PopUpdateFrame ( StgClosure* obj );
290 static inline void PopCatchFrame ( void );
291 static inline void PopSeqFrame ( void );
292 static inline void PopStopFrame( StgClosure* obj );
293 static inline void PushTaggedRealWorld( void );
294 /* static inline void PushTaggedInteger ( mpz_ptr ); */
295 static inline StgPtr grabHpUpd( nat size );
296 static inline StgPtr grabHpNonUpd( nat size );
297 static StgClosure* raiseAnError ( StgClosure* exception );
299 static int enterCountI = 0;
301 #ifdef STANDALONE_INTEGER
302 StgDouble B__encodeDouble (B* s, I_ e);
303 void B__decodeDouble (B* man, I_* exp, StgDouble dbl);
304 #if ! FLOATS_AS_DOUBLES
305 StgFloat B__encodeFloat (B* s, I_ e);
306 void B__decodeFloat (B* man, I_* exp, StgFloat flt);
307 StgPtr CreateByteArrayToHoldInteger ( int );
308 B* IntegerInsideByteArray ( StgPtr );
309 void SloppifyIntegerEnd ( StgPtr );
316 #define gSp MainRegTable.rSp
317 #define gSu MainRegTable.rSu
318 #define gSpLim MainRegTable.rSpLim
321 /* Macros to save/load local state. */
323 #define SSS { tSp=gSp = xSp; tSu=gSu = xSu; tSpLim=gSpLim = xSpLim; }
324 #define LLL { tSp=xSp = gSp; tSu=xSu = gSu; tSpLim=xSpLim = gSpLim; }
326 #define SSS { gSp = xSp; gSu = xSu; gSpLim = xSpLim; }
327 #define LLL { xSp = gSp; xSu = gSu; xSpLim = gSpLim; }
330 #define RETURN(vvv) { \
331 StgThreadReturnCode retVal=(vvv); \
333 cap->rCurrentTSO->sp = gSp; \
334 cap->rCurrentTSO->su = gSu; \
335 cap->rCurrentTSO->splim = gSpLim; \
340 /* Macros to operate directly on the pulled-out machine state.
341 These mirror some of the small procedures used in the primop code
342 below, except you have to be careful about side effects,
343 ie xPushPtr(xStackPtr(n)) won't work! It certainly isn't the
344 same as PushPtr(StackPtr(n)). Also note that (1) some of
345 the macros, in particular xPopTagged*, do not make the tag
346 sanity checks that their non-x cousins do, and (2) some of
347 the macros depend critically on the semantics of C comma
348 expressions to work properly.
350 #define xPushPtr(ppp) { xSp--; *xSp=(StgWord)(ppp); }
351 #define xPopPtr() ((StgPtr)(*xSp++))
353 #define xPushCPtr(ppp) { xSp--; *xSp=(StgWord)(ppp); }
354 #define xPopCPtr() ((StgClosure*)(*xSp++))
356 #define xPushWord(ppp) { xSp--; *xSp=(StgWord)(ppp); }
357 #define xPopWord() ((StgWord)(*xSp++))
359 #define xStackPtr(nnn) ((StgPtr)(*(xSp+(nnn))))
360 #define xStackWord(nnn) ((StgWord)(*(xSp+(nnn))))
361 #define xSetStackWord(iii,www) xSp[iii]=(StgWord)(www)
363 #define xPushTag(ttt) { xSp--; *xSp=(StgWord)(ttt); }
364 #define xPopTag(ttt) { StackTag t = (StackTag)(*xSp++); \
367 #define xPushTaggedInt(xxx) { xSp -= sizeofW(StgInt); \
368 *xSp = (xxx); xPushTag(INT_TAG); }
369 #define xTaggedStackInt(iii) ((StgInt)(*(xSp+1+(iii))))
370 #define xPopTaggedInt() ((xSp++,xSp+=sizeofW(StgInt), \
371 (StgInt)(*(xSp-sizeofW(StgInt)))))
373 #define xPushTaggedWord(xxx) { xSp -= sizeofW(StgWord); \
374 *xSp = (xxx); xPushTag(WORD_TAG); }
375 #define xTaggedStackWord(iii) ((StgWord)(*(xSp+1+(iii))))
376 #define xPopTaggedWord() ((xSp++,xSp+=sizeofW(StgWord), \
377 (StgWord)(*(xSp-sizeofW(StgWord)))))
379 #define xPushTaggedAddr(xxx) { xSp -= sizeofW(StgAddr); \
380 *xSp = (StgWord)(xxx); xPushTag(ADDR_TAG); }
381 #define xTaggedStackAddr(iii) ((StgAddr)(*(xSp+1+(iii))))
382 #define xPopTaggedAddr() ((xSp++,xSp+=sizeofW(StgAddr), \
383 (StgAddr)(*(xSp-sizeofW(StgAddr)))))
385 #define xPushTaggedStable(xxx) { xSp -= sizeofW(StgStablePtr); \
386 *xSp = (StgWord)(xxx); xPushTag(STABLE_TAG); }
387 #define xTaggedStackStable(iii) ((StgStablePtr)(*(xSp+1+(iii))))
388 #define xPopTaggedStable() ((xSp++,xSp+=sizeofW(StgStablePtr), \
389 (StgStablePtr)(*(xSp-sizeofW(StgStablePtr)))))
391 #define xPushTaggedChar(xxx) { xSp -= sizeofW(StgChar); \
392 *xSp = (StgWord)(xxx); xPushTag(CHAR_TAG); }
393 #define xTaggedStackChar(iii) ((StgChar)(*(xSp+1+(iii))))
394 #define xPopTaggedChar() ((xSp++,xSp+=sizeofW(StgChar), \
395 (StgChar)(*(xSp-sizeofW(StgChar)))))
397 #define xPushTaggedFloat(xxx) { xSp -= sizeofW(StgFloat); \
398 ASSIGN_FLT(xSp,xxx); xPushTag(FLOAT_TAG); }
399 #define xTaggedStackFloat(iii) PK_FLT(xSp+1+(iii))
400 #define xPopTaggedFloat() ((xSp++,xSp+=sizeofW(StgFloat), \
401 PK_FLT(xSp-sizeofW(StgFloat))))
403 #define xPushTaggedDouble(xxx) { xSp -= sizeofW(StgDouble); \
404 ASSIGN_DBL(xSp,xxx); xPushTag(DOUBLE_TAG); }
405 #define xTaggedStackDouble(iii) PK_DBL(xSp+1+(iii))
406 #define xPopTaggedDouble() ((xSp++,xSp+=sizeofW(StgDouble), \
407 PK_DBL(xSp-sizeofW(StgDouble))))
410 #define xPushUpdateFrame(target, xSp_offset) \
412 StgUpdateFrame *__frame; \
413 __frame = (StgUpdateFrame *)(xSp + (xSp_offset)) - 1; \
414 SET_INFO(__frame, (StgInfoTable *)&Upd_frame_info); \
415 __frame->link = xSu; \
416 __frame->updatee = (StgClosure *)(target); \
420 #define xPopUpdateFrame(ooo) \
422 /* NB: doesn't assume that Sp == Su */ \
423 IF_DEBUG(evaluator, \
424 fprintf(stderr, "Updating "); \
425 printPtr(stgCast(StgPtr,xSu->updatee)); \
426 fprintf(stderr, " with "); \
428 fprintf(stderr,"xSp = %p\txSu = %p\n\n", xSp, xSu); \
430 UPD_IND(xSu->updatee,ooo); \
431 xSp = stgCast(StgStackPtr,xSu) + sizeofW(StgUpdateFrame); \
437 /* Instruction stream macros */
438 #define BCO_INSTR_8 *bciPtr++
439 #define BCO_INSTR_16 ((bciPtr += 2, (*(bciPtr-2) << 8) + *(bciPtr-1)))
440 #define PC (bciPtr - &(bcoInstr(bco,0)))
443 /* State on entry to enter():
444 * - current thread is in cap->rCurrentTSO;
445 * - allocation area is in cap->rCurrentNursery & cap->rNursery
448 StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 )
450 /* use of register here is primarily to make it clear to compilers
451 that these entities are non-aliasable.
453 register StgPtr xSp; /* local state -- stack pointer */
454 register StgUpdateFrame* xSu; /* local state -- frame pointer */
455 register StgPtr xSpLim; /* local state -- stack lim pointer */
456 register StgClosure* obj; /* object currently under evaluation */
457 char eCount; /* enter counter, for context switching */
460 StgPtr tSp; StgUpdateFrame* tSu; StgPtr tSpLim;
463 gSp = cap->rCurrentTSO->sp;
464 gSu = cap->rCurrentTSO->su;
465 gSpLim = cap->rCurrentTSO->splim;
468 /* use the t values to check that Su/Sp/SpLim do not change unexpectedly */
469 tSp = gSp; tSu = gSu; tSpLim = gSpLim;
475 /* Load the local state from global state, and Party On, Dudes! */
476 /* From here onwards, we operate with the local state and
477 save/reload it as necessary.
486 assert(gSpLim == tSpLim);
490 ASSERT(xSpLim <= xSp && xSp <= stgCast(StgPtr,xSu));
492 "\n---------------------------------------------------------------\n");
493 fprintf(stderr,"(%d) Entering: ",enterCountI); printObj(obj);
494 fprintf(stderr,"xSp = %p\txSu = %p\n", xSp, xSu);
495 fprintf(stderr, "\n" );
496 printStack(xSp,cap->rCurrentTSO->stack+cap->rCurrentTSO->stack_size,xSu);
497 fprintf(stderr, "\n\n");
504 ((++eCount) & 0x0F) == 0
509 if (context_switch) {
510 xPushCPtr(obj); /* code to restart with */
511 RETURN(ThreadYielding);
515 switch ( get_itbl(obj)->type ) {
517 barf("Invalid object %p",obj);
521 /* ---------------------------------------------------- */
522 /* Start of the bytecode evaluator */
523 /* ---------------------------------------------------- */
526 # define Ins(x) &&l##x
527 static void *labs[] = { INSTRLIST };
529 # define LoopTopLabel
530 # define Case(x) l##x
531 # define Continue goto *labs[BCO_INSTR_8]
532 # define Dispatch Continue;
535 # define LoopTopLabel insnloop:
536 # define Case(x) case x
537 # define Continue goto insnloop
538 # define Dispatch switch (BCO_INSTR_8) {
539 # define EndDispatch }
542 register StgWord8* bciPtr; /* instruction pointer */
543 register StgBCO* bco = (StgBCO*)obj;
546 /* Don't need to SSS ... LLL around doYouWantToGC */
547 wantToGC = doYouWantToGC();
549 xPushCPtr((StgClosure*)bco); /* code to restart with */
550 RETURN(HeapOverflow);
558 bciPtr = &(bcoInstr(bco,0));
562 ASSERT((StgWord)(PC) < bco->n_instrs);
564 fprintf(stderr,"Sp = %p\tSu = %p\tpc = %d\t", xSp, xSu, PC);
568 fprintf(stderr,"\n");
569 for (i = 8; i >= 0; i--)
570 fprintf(stderr, "%d %p\n", i, (StgPtr)(*(gSp+i)));
572 fprintf(stderr,"\n");
577 SSS; cp_bill_insns(1); LLL;
582 Case(i_INTERNAL_ERROR):
583 barf("INTERNAL_ERROR at %p:%d",bco,PC-1);
585 barf("PANIC at %p:%d",bco,PC-1);
589 if (xSp - n < xSpLim) {
590 xPushCPtr((StgClosure*)bco); /* code to restart with */
591 RETURN(StackOverflow);
595 Case(i_STK_CHECK_big):
597 int n = BCO_INSTR_16;
598 if (xSp - n < xSpLim) {
599 xPushCPtr((StgClosure*)bco); /* code to restart with */
600 RETURN(StackOverflow);
607 if ((StgPtr*)(xSp + n) > (StgPtr*)xSu) {
608 StgWord words = (P_)xSu - xSp;
610 /* first build a PAP */
611 ASSERT((P_)xSu >= xSp); /* was (words >= 0) but that's always true */
612 if (words == 0) { /* optimisation */
613 /* Skip building the PAP and update with an indirection. */
616 /* In the evaluator, we avoid the need to do
617 * a heap check here by including the size of
618 * the PAP in the heap check we performed
619 * when we entered the BCO.
623 SSS; pap = (StgPAP*)grabHpNonUpd(PAP_sizeW(words)); LLL;
624 SET_HDR(pap,&PAP_info,CC_pap);
627 for (i = 0; i < (I_)words; ++i) {
628 payloadWord(pap,i) = xSp[i];
631 obj = stgCast(StgClosure*,pap);
634 /* now deal with "update frame" */
635 /* as an optimisation, we process all on top of stack */
636 /* instead of just the top one */
637 ASSERT(xSp==(P_)xSu);
639 switch (get_itbl(xSu)->type) {
641 /* Hit a catch frame during an arg satisfaction check,
642 * so the thing returning (1) has not thrown an
643 * exception, and (2) is of functional type. Just
644 * zap the catch frame and carry on down the stack
645 * (looking for more arguments, basically).
647 SSS; PopCatchFrame(); LLL;
650 xPopUpdateFrame(obj);
653 SSS; PopStopFrame(obj); LLL;
654 RETURN(ThreadFinished);
656 SSS; PopSeqFrame(); LLL;
657 ASSERT(xSp != (P_)xSu);
658 /* Hit a SEQ frame during an arg satisfaction check.
659 * So now return to bco_info which is under the
660 * SEQ frame. The following code is copied from a
661 * case RET_BCO further down. (The reason why we're
662 * here is that something of functional type has
663 * been seq-d on, and we're now returning to the
664 * algebraic-case-continuation which forced the
665 * evaluation in the first place.)
677 barf("Invalid update frame during argcheck");
679 } while (xSp==(P_)xSu);
687 int words = BCO_INSTR_8;
688 SSS; p = grabHpUpd(AP_sizeW(words)); LLL;
692 Case(i_ALLOC_CONSTR):
695 StgInfoTable* info = bcoConstAddr(bco,BCO_INSTR_8);
696 SSS; p = grabHpNonUpd(sizeW_fromITBL(info)); LLL;
697 SET_HDR((StgClosure*)p,info,??);
703 int x = BCO_INSTR_8; /* ToDo: Word not Int! */
705 StgAP_UPD* o = stgCast(StgAP_UPD*,xStackPtr(x));
706 SET_HDR(o,&AP_UPD_info,??);
708 o->fun = stgCast(StgClosure*,xPopPtr());
709 for(x=0; x < y; ++x) {
710 payloadWord(o,x) = xPopWord();
713 fprintf(stderr,"\tBuilt ");
715 printObj(stgCast(StgClosure*,o));
726 o = stgCast(StgAP_UPD*,xStackPtr(x));
727 SET_HDR(o,&AP_UPD_info,??);
729 o->fun = stgCast(StgClosure*,xPopPtr());
730 for(x=0; x < y; ++x) {
731 payloadWord(o,x) = xPopWord();
734 fprintf(stderr,"\tBuilt ");
736 printObj(stgCast(StgClosure*,o));
745 StgPAP* o = stgCast(StgPAP*,xStackPtr(x));
746 SET_HDR(o,&PAP_info,??);
748 o->fun = stgCast(StgClosure*,xPopPtr());
749 for(x=0; x < y; ++x) {
750 payloadWord(o,x) = xPopWord();
753 fprintf(stderr,"\tBuilt ");
755 printObj(stgCast(StgClosure*,o));
762 int offset = BCO_INSTR_8;
763 StgClosure* o = stgCast(StgClosure*,xStackPtr(offset));
764 const StgInfoTable* info = get_itbl(o);
765 nat p = info->layout.payload.ptrs;
766 nat np = info->layout.payload.nptrs;
768 for(i=0; i < p; ++i) {
769 payloadCPtr(o,i) = xPopCPtr();
771 for(i=0; i < np; ++i) {
772 payloadWord(o,p+i) = 0xdeadbeef;
775 fprintf(stderr,"\tBuilt ");
777 printObj(stgCast(StgClosure*,o));
784 int offset = BCO_INSTR_16;
785 StgClosure* o = stgCast(StgClosure*,xStackPtr(offset));
786 const StgInfoTable* info = get_itbl(o);
787 nat p = info->layout.payload.ptrs;
788 nat np = info->layout.payload.nptrs;
790 for(i=0; i < p; ++i) {
791 payloadCPtr(o,i) = xPopCPtr();
793 for(i=0; i < np; ++i) {
794 payloadWord(o,p+i) = 0xdeadbeef;
797 fprintf(stderr,"\tBuilt ");
799 printObj(stgCast(StgClosure*,o));
808 ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
809 /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
811 xSetStackWord(x+y,xStackWord(x));
821 ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
822 /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
824 xSetStackWord(x+y,xStackWord(x));
836 xPushPtr(bcoConstPtr(bco,BCO_INSTR_8));
837 xPushPtr(stgCast(StgPtr,&ret_bco_info));
842 int tag = BCO_INSTR_8;
843 StgWord offset = BCO_INSTR_16;
844 if (constrTag(stgCast(StgClosure*,xStackPtr(0))) != tag) {
851 StgClosure* o = stgCast(StgClosure*,xStackPtr(0));
852 const StgInfoTable* itbl = get_itbl(o);
853 int i = itbl->layout.payload.ptrs;
854 ASSERT( itbl->type == CONSTR
855 || itbl->type == CONSTR_STATIC
856 || itbl->type == CONSTR_NOCAF_STATIC
857 || itbl->type == CONSTR_1_0
858 || itbl->type == CONSTR_0_1
859 || itbl->type == CONSTR_2_0
860 || itbl->type == CONSTR_1_1
861 || itbl->type == CONSTR_0_2
864 xPushCPtr(payloadCPtr(o,i));
870 int n = BCO_INSTR_16;
871 StgPtr p = xStackPtr(n);
877 StgPtr p = xStackPtr(BCO_INSTR_8);
883 xPushPtr(stgCast(StgPtr,bcoConstPtr(bco,BCO_INSTR_8)));
888 int n = BCO_INSTR_16;
889 xPushPtr(stgCast(StgPtr,bcoConstPtr(bco,n)));
894 SSS; PushTaggedRealWorld(); LLL;
899 StgInt i = xTaggedStackInt(BCO_INSTR_8);
905 xPushTaggedInt(bcoConstInt(bco,BCO_INSTR_8));
911 SSS; o = (StgClosure*)grabHpNonUpd(Izh_sizeW); LLL;
912 SET_HDR(o,&Izh_con_info,??);
913 payloadWord(o,0) = xPopTaggedInt();
915 fprintf(stderr,"\tBuilt ");
917 printObj(stgCast(StgClosure*,o));
920 xPushPtr(stgCast(StgPtr,o));
925 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
926 /* ASSERT(isIntLike(con)); */
927 xPushTaggedInt(payloadWord(con,0));
932 StgWord offset = BCO_INSTR_16;
933 StgInt x = xPopTaggedInt();
934 StgInt y = xPopTaggedInt();
940 Case(i_CONST_INTEGER):
944 char* s = bcoConstAddr(bco,BCO_INSTR_8);
947 p = CreateByteArrayToHoldInteger(n);
948 do_fromStr ( s, n, IntegerInsideByteArray(p));
949 SloppifyIntegerEnd(p);
956 StgWord w = xTaggedStackWord(BCO_INSTR_8);
962 xPushTaggedWord(bcoConstWord(bco,BCO_INSTR_8));
968 SSS; o = (StgClosure*)grabHpNonUpd(Wzh_sizeW); LLL;
969 SET_HDR(o,&Wzh_con_info,??);
970 payloadWord(o,0) = xPopTaggedWord();
972 fprintf(stderr,"\tBuilt ");
974 printObj(stgCast(StgClosure*,o));
977 xPushPtr(stgCast(StgPtr,o));
982 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
983 /* ASSERT(isWordLike(con)); */
984 xPushTaggedWord(payloadWord(con,0));
989 StgAddr a = xTaggedStackAddr(BCO_INSTR_8);
995 xPushTaggedAddr(bcoConstAddr(bco,BCO_INSTR_8));
1001 SSS; o = (StgClosure*)grabHpNonUpd(Azh_sizeW); LLL;
1002 SET_HDR(o,&Azh_con_info,??);
1003 payloadPtr(o,0) = xPopTaggedAddr();
1005 fprintf(stderr,"\tBuilt ");
1007 printObj(stgCast(StgClosure*,o));
1010 xPushPtr(stgCast(StgPtr,o));
1013 Case(i_UNPACK_ADDR):
1015 StgClosure* con = (StgClosure*)xStackPtr(0);
1016 /* ASSERT(isAddrLike(con)); */
1017 xPushTaggedAddr(payloadPtr(con,0));
1022 StgChar c = xTaggedStackChar(BCO_INSTR_8);
1028 xPushTaggedChar(bcoConstChar(bco,BCO_INSTR_8));
1034 SSS; o = (StgClosure*)grabHpNonUpd(Czh_sizeW); LLL;
1035 SET_HDR(o,&Czh_con_info,??);
1036 payloadWord(o,0) = xPopTaggedChar();
1037 xPushPtr(stgCast(StgPtr,o));
1039 fprintf(stderr,"\tBuilt ");
1041 printObj(stgCast(StgClosure*,o));
1046 Case(i_UNPACK_CHAR):
1048 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1049 /* ASSERT(isCharLike(con)); */
1050 xPushTaggedChar(payloadWord(con,0));
1055 StgFloat f = xTaggedStackFloat(BCO_INSTR_8);
1056 xPushTaggedFloat(f);
1059 Case(i_CONST_FLOAT):
1061 xPushTaggedFloat(bcoConstFloat(bco,BCO_INSTR_8));
1067 SSS; o = (StgClosure*)grabHpNonUpd(Fzh_sizeW); LLL;
1068 SET_HDR(o,&Fzh_con_info,??);
1069 ASSIGN_FLT(&payloadWord(o,0),xPopTaggedFloat());
1071 fprintf(stderr,"\tBuilt ");
1073 printObj(stgCast(StgClosure*,o));
1076 xPushPtr(stgCast(StgPtr,o));
1079 Case(i_UNPACK_FLOAT):
1081 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1082 /* ASSERT(isFloatLike(con)); */
1083 xPushTaggedFloat(PK_FLT(&payloadWord(con,0)));
1088 StgDouble d = xTaggedStackDouble(BCO_INSTR_8);
1089 xPushTaggedDouble(d);
1092 Case(i_CONST_DOUBLE):
1094 xPushTaggedDouble(bcoConstDouble(bco,BCO_INSTR_8));
1097 Case(i_CONST_DOUBLE_big):
1099 int n = BCO_INSTR_16;
1100 xPushTaggedDouble(bcoConstDouble(bco,n));
1103 Case(i_PACK_DOUBLE):
1106 SSS; o = (StgClosure*)grabHpNonUpd(Dzh_sizeW); LLL;
1107 SET_HDR(o,&Dzh_con_info,??);
1108 ASSIGN_DBL(&payloadWord(o,0),xPopTaggedDouble());
1110 fprintf(stderr,"\tBuilt ");
1111 printObj(stgCast(StgClosure*,o));
1113 xPushPtr(stgCast(StgPtr,o));
1116 Case(i_UNPACK_DOUBLE):
1118 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1119 /* ASSERT(isDoubleLike(con)); */
1120 xPushTaggedDouble(PK_DBL(&payloadWord(con,0)));
1125 StgStablePtr s = xTaggedStackStable(BCO_INSTR_8);
1126 xPushTaggedStable(s);
1129 Case(i_PACK_STABLE):
1132 SSS; o = (StgClosure*)grabHpNonUpd(Stablezh_sizeW); LLL;
1133 SET_HDR(o,&StablePtr_con_info,??);
1134 payloadWord(o,0) = xPopTaggedStable();
1136 fprintf(stderr,"\tBuilt ");
1138 printObj(stgCast(StgClosure*,o));
1141 xPushPtr(stgCast(StgPtr,o));
1144 Case(i_UNPACK_STABLE):
1146 StgClosure* con = (StgClosure*)xStackPtr(0);
1147 /* ASSERT(isStableLike(con)); */
1148 xPushTaggedStable(payloadWord(con,0));
1156 SSS; p = enterBCO_primop1 ( i ); LLL;
1157 if (p) { obj = p; goto enterLoop; };
1162 int i, trc, pc_saved;
1165 trc = 12345678; /* Assume != any StgThreadReturnCode */
1170 p = enterBCO_primop2 ( i, &trc, &bco_tmp, cap );
1173 bciPtr = &(bcoInstr(bco,pc_saved));
1175 if (trc == 12345678) {
1176 /* we want to enter p */
1177 obj = p; goto enterLoop;
1179 /* trc is the the StgThreadReturnCode for this thread */
1180 RETURN((StgThreadReturnCode)trc);
1186 /* combined insns, created by peephole opt */
1189 int x = BCO_INSTR_8;
1190 int y = BCO_INSTR_8;
1191 ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
1192 /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
1199 xSetStackWord(x+y,xStackWord(x));
1209 p = xStackPtr(BCO_INSTR_8);
1211 p = xStackPtr(BCO_INSTR_8);
1218 xPushPtr(bcoConstPtr(bco,BCO_INSTR_8));
1219 xPushPtr(stgCast(StgPtr,&ret_bco_info));
1220 p = xStackPtr(BCO_INSTR_8);
1226 StgPtr retaddr = bcoConstPtr(bco,BCO_INSTR_8);
1227 StgPtr ptr = xStackPtr(BCO_INSTR_8);
1229 /* A shortcut. We're going to push the address of a
1230 return continuation, and then enter a variable, so
1231 that when the var is evaluated, we return to the
1232 continuation. The shortcut is: if the var is a
1233 constructor, don't bother to enter it. Instead,
1234 push the variable on the stack (since this is what
1235 the continuation expects) and jump directly to the
1238 if (get_itbl((StgClosure*)ptr)->type == CONSTR) {
1240 obj = (StgClosure*)retaddr;
1242 fprintf(stderr, "object to enter is a constructor -- "
1243 "jumping directly to return continuation\n" );
1248 /* This is the normal, non-short-cut route */
1250 xPushPtr(stgCast(StgPtr,&ret_bco_info));
1251 obj = (StgClosure*)ptr;
1256 Case(i_VAR_DOUBLE_big):
1257 Case(i_CONST_FLOAT_big):
1258 Case(i_VAR_FLOAT_big):
1259 Case(i_CONST_CHAR_big):
1260 Case(i_VAR_CHAR_big):
1261 Case(i_CONST_ADDR_big):
1262 Case(i_VAR_ADDR_big):
1263 Case(i_VAR_STABLE_big):
1264 Case(i_CONST_INTEGER_big):
1265 Case(i_CONST_INT_big):
1266 Case(i_VAR_INT_big):
1267 Case(i_VAR_WORD_big):
1268 Case(i_RETADDR_big):
1272 disInstr ( bco, PC );
1273 barf("\nUnrecognised instruction");
1277 barf("enterBCO: ran off end of loop");
1281 # undef LoopTopLabel
1287 /* ---------------------------------------------------- */
1288 /* End of the bytecode evaluator */
1289 /* ---------------------------------------------------- */
1293 StgBlockingQueue* bh;
1294 StgCAF* caf = (StgCAF*)obj;
1295 if (xSp - sizeofW(StgUpdateFrame) < xSpLim) {
1296 xPushCPtr(obj); /* code to restart with */
1297 RETURN(StackOverflow);
1299 /* ToDo: look for xSp==xSu && stackInt(0) == UPD_FRAME
1300 and insert an indirection immediately */
1301 SSS; bh = (StgBlockingQueue*)grabHpUpd(BLACKHOLE_sizeW()); LLL;
1302 SET_INFO(bh,&CAF_BLACKHOLE_info);
1303 bh->blocking_queue = EndTSOQueue;
1305 fprintf(stderr,"Created CAF_BLACKHOLE %p for CAF %p in evaluator\n",bh,caf));
1306 SET_INFO(caf,&CAF_ENTERED_info);
1307 caf->value = (StgClosure*)bh;
1308 if (caf->mut_link == NULL) {
1309 SSS; recordOldToNewPtrs((StgMutClosure*)caf); LLL;
1311 xPushUpdateFrame(bh,0);
1312 xSp -= sizeofW(StgUpdateFrame);
1313 caf->link = enteredCAFs;
1320 StgCAF* caf = (StgCAF*)obj;
1321 obj = caf->value; /* it's just a fancy indirection */
1327 case SE_CAF_BLACKHOLE:
1329 /* Let the scheduler figure out what to do :-) */
1330 cap->rCurrentTSO->whatNext = ThreadEnterGHC;
1332 RETURN(ThreadYielding);
1336 StgAP_UPD* ap = stgCast(StgAP_UPD*,obj);
1338 if (xSp - (i + sizeofW(StgUpdateFrame)) < xSpLim) {
1339 xPushCPtr(obj); /* code to restart with */
1340 RETURN(StackOverflow);
1342 /* ToDo: look for xSp==xSu && stackInt(0) == UPD_FRAME
1343 and insert an indirection immediately */
1344 xPushUpdateFrame(ap,0);
1345 xSp -= sizeofW(StgUpdateFrame);
1347 xPushWord(payloadWord(ap,i));
1350 #ifdef EAGER_BLACKHOLING
1351 #warn LAZY_BLACKHOLING is default for StgHugs
1352 #error Dont know if EAGER_BLACKHOLING works in StgHugs
1354 /* superfluous - but makes debugging easier */
1355 StgBlackHole* bh = stgCast(StgBlackHole*,ap);
1356 SET_INFO(bh,&BLACKHOLE_info);
1357 bh->blocking_queue = EndTSOQueue;
1359 fprintf(stderr,"Eagerly blackholed AP_UPD %p in evaluator\n",bh));
1362 #endif /* EAGER_BLACKHOLING */
1367 StgPAP* pap = stgCast(StgPAP*,obj);
1368 int i = pap->n_args; /* ToDo: stack check */
1369 /* ToDo: if PAP is in whnf, we can update any update frames
1373 xPushWord(payloadWord(pap,i));
1380 obj = stgCast(StgInd*,obj)->indirectee;
1385 obj = stgCast(StgIndOldGen*,obj)->indirectee;
1394 case CONSTR_INTLIKE:
1395 case CONSTR_CHARLIKE:
1397 case CONSTR_NOCAF_STATIC:
1400 switch (get_itbl(stgCast(StgClosure*,xSp))->type) {
1402 SSS; PopCatchFrame(); LLL;
1405 xPopUpdateFrame(obj);
1408 SSS; PopSeqFrame(); LLL;
1412 ASSERT(xSp==(P_)xSu);
1415 fprintf(stderr, "hit a STOP_FRAME\n");
1417 fprintf(stderr,"xSp = %p\txSu = %p\n", xSp, xSu);
1418 printStack(xSp,cap->rCurrentTSO->stack
1419 + cap->rCurrentTSO->stack_size,xSu);
1422 SSS; PopStopFrame(obj); LLL;
1423 RETURN(ThreadFinished);
1433 /* was: goto enterLoop;
1434 But we know that obj must be a bco now, so jump directly.
1437 case RET_SMALL: /* return to GHC */
1441 // barf("todo: RET_[VEC_]{BIG,SMALL}");
1443 belch("entered CONSTR with invalid continuation on stack");
1446 printObj(stgCast(StgClosure*,xSp));
1449 barf("bailing out");
1456 //fprintf(stderr, "enterCountI = %d\n", enterCountI);
1457 //fprintf(stderr, "entering unknown closure -- yielding to sched\n");
1460 cap->rCurrentTSO->whatNext = ThreadEnterGHC;
1461 xPushCPtr(obj); /* code to restart with */
1462 RETURN(ThreadYielding);
1465 barf("Ran off the end of enter - yoiks");
1482 #undef xSetStackWord
1485 #undef xPushTaggedInt
1486 #undef xPopTaggedInt
1487 #undef xTaggedStackInt
1488 #undef xPushTaggedWord
1489 #undef xPopTaggedWord
1490 #undef xTaggedStackWord
1491 #undef xPushTaggedAddr
1492 #undef xTaggedStackAddr
1493 #undef xPopTaggedAddr
1494 #undef xPushTaggedStable
1495 #undef xTaggedStackStable
1496 #undef xPopTaggedStable
1497 #undef xPushTaggedChar
1498 #undef xTaggedStackChar
1499 #undef xPopTaggedChar
1500 #undef xPushTaggedFloat
1501 #undef xTaggedStackFloat
1502 #undef xPopTaggedFloat
1503 #undef xPushTaggedDouble
1504 #undef xTaggedStackDouble
1505 #undef xPopTaggedDouble
1506 #undef xPopUpdateFrame
1507 #undef xPushUpdateFrame
1510 /* --------------------------------------------------------------------------
1511 * Supporting routines for primops
1512 * ------------------------------------------------------------------------*/
1514 static inline void PushTag ( StackTag t )
1516 inline void PushPtr ( StgPtr x )
1517 { *(--stgCast(StgPtr*,gSp)) = x; }
1518 static inline void PushCPtr ( StgClosure* x )
1519 { *(--stgCast(StgClosure**,gSp)) = x; }
1520 static inline void PushInt ( StgInt x )
1521 { *(--stgCast(StgInt*,gSp)) = x; }
1522 static inline void PushWord ( StgWord x )
1523 { *(--stgCast(StgWord*,gSp)) = x; }
1526 static inline void checkTag ( StackTag t1, StackTag t2 )
1527 { ASSERT(t1 == t2);}
1528 static inline void PopTag ( StackTag t )
1529 { checkTag(t,*(gSp++)); }
1530 inline StgPtr PopPtr ( void )
1531 { return *stgCast(StgPtr*,gSp)++; }
1532 static inline StgClosure* PopCPtr ( void )
1533 { return *stgCast(StgClosure**,gSp)++; }
1534 static inline StgInt PopInt ( void )
1535 { return *stgCast(StgInt*,gSp)++; }
1536 static inline StgWord PopWord ( void )
1537 { return *stgCast(StgWord*,gSp)++; }
1539 static inline StgPtr stackPtr ( StgStackOffset i )
1540 { return *stgCast(StgPtr*, gSp+i); }
1541 static inline StgInt stackInt ( StgStackOffset i )
1542 { return *stgCast(StgInt*, gSp+i); }
1543 static inline StgWord stackWord ( StgStackOffset i )
1544 { return *stgCast(StgWord*,gSp+i); }
1546 static inline void setStackWord ( StgStackOffset i, StgWord w )
1549 static inline void PushTaggedRealWorld( void )
1550 { PushTag(REALWORLD_TAG); }
1551 inline void PushTaggedInt ( StgInt x )
1552 { gSp -= sizeofW(StgInt); *gSp = x; PushTag(INT_TAG); }
1553 inline void PushTaggedWord ( StgWord x )
1554 { gSp -= sizeofW(StgWord); *gSp = x; PushTag(WORD_TAG); }
1555 inline void PushTaggedAddr ( StgAddr x )
1556 { gSp -= sizeofW(StgAddr); *gSp = (W_)x; PushTag(ADDR_TAG); }
1557 inline void PushTaggedChar ( StgChar x )
1558 { gSp -= sizeofW(StgChar); *gSp = stgCast(StgWord,x); PushTag(CHAR_TAG); }
1559 inline void PushTaggedFloat ( StgFloat x )
1560 { gSp -= sizeofW(StgFloat); ASSIGN_FLT(gSp,x); PushTag(FLOAT_TAG); }
1561 inline void PushTaggedDouble ( StgDouble x )
1562 { gSp -= sizeofW(StgDouble); ASSIGN_DBL(gSp,x); PushTag(DOUBLE_TAG); }
1563 inline void PushTaggedStablePtr ( StgStablePtr x )
1564 { gSp -= sizeofW(StgStablePtr); *gSp = x; PushTag(STABLE_TAG); }
1565 static inline void PushTaggedBool ( int x )
1566 { PushTaggedInt(x); }
1570 static inline void PopTaggedRealWorld ( void )
1571 { PopTag(REALWORLD_TAG); }
1572 inline StgInt PopTaggedInt ( void )
1573 { StgInt r; PopTag(INT_TAG); r = *stgCast(StgInt*, gSp);
1574 gSp += sizeofW(StgInt); return r;}
1575 inline StgWord PopTaggedWord ( void )
1576 { StgWord r; PopTag(WORD_TAG); r = *stgCast(StgWord*, gSp);
1577 gSp += sizeofW(StgWord); return r;}
1578 inline StgAddr PopTaggedAddr ( void )
1579 { StgAddr r; PopTag(ADDR_TAG); r = *stgCast(StgAddr*, gSp);
1580 gSp += sizeofW(StgAddr); return r;}
1581 inline StgChar PopTaggedChar ( void )
1582 { StgChar r; PopTag(CHAR_TAG); r = stgCast(StgChar, *gSp);
1583 gSp += sizeofW(StgChar); return r;}
1584 inline StgFloat PopTaggedFloat ( void )
1585 { StgFloat r; PopTag(FLOAT_TAG); r = PK_FLT(gSp);
1586 gSp += sizeofW(StgFloat); return r;}
1587 inline StgDouble PopTaggedDouble ( void )
1588 { StgDouble r; PopTag(DOUBLE_TAG); r = PK_DBL(gSp);
1589 gSp += sizeofW(StgDouble); return r;}
1590 inline StgStablePtr PopTaggedStablePtr ( void )
1591 { StgInt r; PopTag(STABLE_TAG); r = *stgCast(StgStablePtr*, gSp);
1592 gSp += sizeofW(StgStablePtr); return r;}
1596 static inline StgInt taggedStackInt ( StgStackOffset i )
1597 { checkTag(INT_TAG,gSp[i]); return *stgCast(StgInt*, gSp+1+i); }
1598 static inline StgWord taggedStackWord ( StgStackOffset i )
1599 { checkTag(WORD_TAG,gSp[i]); return *stgCast(StgWord*, gSp+1+i); }
1600 static inline StgAddr taggedStackAddr ( StgStackOffset i )
1601 { checkTag(ADDR_TAG,gSp[i]); return *stgCast(StgAddr*, gSp+1+i); }
1602 static inline StgChar taggedStackChar ( StgStackOffset i )
1603 { checkTag(CHAR_TAG,gSp[i]); return stgCast(StgChar, *(gSp+1+i)) ; }
1604 static inline StgFloat taggedStackFloat ( StgStackOffset i )
1605 { checkTag(FLOAT_TAG,gSp[i]); return PK_FLT(gSp+1+i); }
1606 static inline StgDouble taggedStackDouble ( StgStackOffset i )
1607 { checkTag(DOUBLE_TAG,gSp[i]); return PK_DBL(gSp+1+i); }
1608 static inline StgStablePtr taggedStackStable ( StgStackOffset i )
1609 { checkTag(STABLE_TAG,gSp[i]); return *stgCast(StgStablePtr*, gSp+1+i); }
1612 /* --------------------------------------------------------------------------
1615 * Should we allocate from a nursery or use the
1616 * doYouWantToGC/allocate interface? We'd already implemented a
1617 * nursery-style scheme when the doYouWantToGC/allocate interface
1619 * One reason to prefer the doYouWantToGC/allocate interface is to
1620 * support operations which allocate an unknown amount in the heap
1621 * (array ops, gmp ops, etc)
1622 * ------------------------------------------------------------------------*/
1624 static inline StgPtr grabHpUpd( nat size )
1626 ASSERT( size >= MIN_UPD_SIZE + sizeofW(StgHeader) );
1627 #ifdef CRUDE_PROFILING
1628 cp_bill_words ( size );
1630 return allocate(size);
1633 static inline StgPtr grabHpNonUpd( nat size )
1635 ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
1636 #ifdef CRUDE_PROFILING
1637 cp_bill_words ( size );
1639 return allocate(size);
1642 /* --------------------------------------------------------------------------
1643 * Manipulate "update frame" list:
1644 * o Update frames (based on stg_do_update and friends in Updates.hc)
1645 * o Error handling/catching (based on catchzh_fast and friends in Prims.hc)
1646 * o Seq frames (based on seq_frame_entry in Prims.hc)
1648 * ------------------------------------------------------------------------*/
1650 static inline void PopUpdateFrame ( StgClosure* obj )
1652 /* NB: doesn't assume that gSp == gSu */
1654 fprintf(stderr, "Updating ");
1655 printPtr(stgCast(StgPtr,gSu->updatee));
1656 fprintf(stderr, " with ");
1658 fprintf(stderr,"gSp = %p\tgSu = %p\n\n", gSp, gSu);
1660 #ifdef EAGER_BLACKHOLING
1661 #warn LAZY_BLACKHOLING is default for StgHugs
1662 #error Dont know if EAGER_BLACKHOLING works in StgHugs
1663 ASSERT(get_itbl(gSu->updatee)->type == BLACKHOLE
1664 || get_itbl(gSu->updatee)->type == SE_BLACKHOLE
1665 || get_itbl(gSu->updatee)->type == CAF_BLACKHOLE
1666 || get_itbl(gSu->updatee)->type == SE_CAF_BLACKHOLE
1668 #endif /* EAGER_BLACKHOLING */
1669 UPD_IND(gSu->updatee,obj);
1670 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgUpdateFrame);
1674 static inline void PopStopFrame ( StgClosure* obj )
1676 /* Move gSu just off the end of the stack, we're about to gSpam the
1677 * STOP_FRAME with the return value.
1679 gSu = stgCast(StgUpdateFrame*,gSp+1);
1680 *stgCast(StgClosure**,gSp) = obj;
1683 static inline void PushCatchFrame ( StgClosure* handler )
1686 /* ToDo: stack check! */
1687 gSp -= sizeofW(StgCatchFrame);
1688 fp = stgCast(StgCatchFrame*,gSp);
1689 SET_HDR(fp,(StgInfoTable*)&catch_frame_info,CCCS);
1690 fp->handler = handler;
1692 gSu = stgCast(StgUpdateFrame*,fp);
1695 static inline void PopCatchFrame ( void )
1697 /* NB: doesn't assume that gSp == gSu */
1698 /* fprintf(stderr,"Popping catch frame\n"); */
1699 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgCatchFrame);
1700 gSu = stgCast(StgCatchFrame*,gSu)->link;
1703 static inline void PushSeqFrame ( void )
1706 /* ToDo: stack check! */
1707 gSp -= sizeofW(StgSeqFrame);
1708 fp = stgCast(StgSeqFrame*,gSp);
1709 SET_HDR(fp,(StgInfoTable*)&seq_frame_info,CCCS);
1711 gSu = stgCast(StgUpdateFrame*,fp);
1714 static inline void PopSeqFrame ( void )
1716 /* NB: doesn't assume that gSp == gSu */
1717 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgSeqFrame);
1718 gSu = stgCast(StgSeqFrame*,gSu)->link;
1721 static inline StgClosure* raiseAnError ( StgClosure* exception )
1723 /* This closure represents the expression 'primRaise E' where E
1724 * is the exception raised (:: Exception).
1725 * It is used to overwrite all the
1726 * thunks which are currently under evaluation.
1728 HaskellObj primRaiseClosure
1729 = asmClosureOfObject(getHugs_AsmObject_for("primRaise"));
1730 HaskellObj reraiseClosure
1731 = rts_apply ( primRaiseClosure, exception );
1734 switch (get_itbl(gSu)->type) {
1736 UPD_IND(gSu->updatee,reraiseClosure);
1737 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgUpdateFrame);
1743 case CATCH_FRAME: /* found it! */
1745 StgCatchFrame* fp = stgCast(StgCatchFrame*,gSu);
1746 StgClosure *handler = fp->handler;
1748 gSp += sizeofW(StgCatchFrame); /* Pop */
1749 PushCPtr(exception);
1753 barf("raiseError: uncaught exception: STOP_FRAME");
1755 barf("raiseError: weird activation record");
1761 static StgClosure* makeErrorCall ( const char* msg )
1763 /* Note! the msg string should be allocated in a
1764 place which will not get freed -- preferably
1765 read-only data of the program. That's because
1766 the thunk we build here may linger indefinitely.
1767 (thinks: probably not so, but anyway ...)
1770 = asmClosureOfObject(getHugs_AsmObject_for("error"));
1772 = asmClosureOfObject(getHugs_AsmObject_for("primUnpackString"));
1774 = rts_apply ( unpack, rts_mkAddr ( (void*)msg ) );
1776 = rts_apply ( error, thunk );
1778 (StgClosure*) thunk;
1781 #define raiseIndex(where) makeErrorCall("Array index out of range in " where)
1782 #define raiseDiv0(where) makeErrorCall("Division by zero in " where)
1784 /* --------------------------------------------------------------------------
1786 * ------------------------------------------------------------------------*/
1788 #define OP_CC_B(e) \
1790 unsigned char x = PopTaggedChar(); \
1791 unsigned char y = PopTaggedChar(); \
1792 PushTaggedBool(e); \
1797 unsigned char x = PopTaggedChar(); \
1806 #define OP_IW_I(e) \
1808 StgInt x = PopTaggedInt(); \
1809 StgWord y = PopTaggedWord(); \
1813 #define OP_II_I(e) \
1815 StgInt x = PopTaggedInt(); \
1816 StgInt y = PopTaggedInt(); \
1820 #define OP_II_B(e) \
1822 StgInt x = PopTaggedInt(); \
1823 StgInt y = PopTaggedInt(); \
1824 PushTaggedBool(e); \
1829 PushTaggedAddr(e); \
1834 StgInt x = PopTaggedInt(); \
1835 PushTaggedAddr(e); \
1840 StgInt x = PopTaggedInt(); \
1846 PushTaggedChar(e); \
1851 StgInt x = PopTaggedInt(); \
1852 PushTaggedChar(e); \
1857 PushTaggedWord(e); \
1862 StgInt x = PopTaggedInt(); \
1863 PushTaggedWord(e); \
1868 StgInt x = PopTaggedInt(); \
1869 PushTaggedStablePtr(e); \
1874 PushTaggedFloat(e); \
1879 StgInt x = PopTaggedInt(); \
1880 PushTaggedFloat(e); \
1885 PushTaggedDouble(e); \
1890 StgInt x = PopTaggedInt(); \
1891 PushTaggedDouble(e); \
1894 #define OP_WW_B(e) \
1896 StgWord x = PopTaggedWord(); \
1897 StgWord y = PopTaggedWord(); \
1898 PushTaggedBool(e); \
1901 #define OP_WW_W(e) \
1903 StgWord x = PopTaggedWord(); \
1904 StgWord y = PopTaggedWord(); \
1905 PushTaggedWord(e); \
1910 StgWord x = PopTaggedWord(); \
1916 StgStablePtr x = PopTaggedStablePtr(); \
1922 StgWord x = PopTaggedWord(); \
1923 PushTaggedWord(e); \
1926 #define OP_AA_B(e) \
1928 StgAddr x = PopTaggedAddr(); \
1929 StgAddr y = PopTaggedAddr(); \
1930 PushTaggedBool(e); \
1934 StgAddr x = PopTaggedAddr(); \
1937 #define OP_AI_C(s) \
1939 StgAddr x = PopTaggedAddr(); \
1940 int y = PopTaggedInt(); \
1943 PushTaggedChar(r); \
1945 #define OP_AI_I(s) \
1947 StgAddr x = PopTaggedAddr(); \
1948 int y = PopTaggedInt(); \
1953 #define OP_AI_A(s) \
1955 StgAddr x = PopTaggedAddr(); \
1956 int y = PopTaggedInt(); \
1959 PushTaggedAddr(s); \
1961 #define OP_AI_F(s) \
1963 StgAddr x = PopTaggedAddr(); \
1964 int y = PopTaggedInt(); \
1967 PushTaggedFloat(r); \
1969 #define OP_AI_D(s) \
1971 StgAddr x = PopTaggedAddr(); \
1972 int y = PopTaggedInt(); \
1975 PushTaggedDouble(r); \
1977 #define OP_AI_s(s) \
1979 StgAddr x = PopTaggedAddr(); \
1980 int y = PopTaggedInt(); \
1983 PushTaggedStablePtr(r); \
1985 #define OP_AIC_(s) \
1987 StgAddr x = PopTaggedAddr(); \
1988 int y = PopTaggedInt(); \
1989 StgChar z = PopTaggedChar(); \
1992 #define OP_AII_(s) \
1994 StgAddr x = PopTaggedAddr(); \
1995 int y = PopTaggedInt(); \
1996 StgInt z = PopTaggedInt(); \
1999 #define OP_AIA_(s) \
2001 StgAddr x = PopTaggedAddr(); \
2002 int y = PopTaggedInt(); \
2003 StgAddr z = PopTaggedAddr(); \
2006 #define OP_AIF_(s) \
2008 StgAddr x = PopTaggedAddr(); \
2009 int y = PopTaggedInt(); \
2010 StgFloat z = PopTaggedFloat(); \
2013 #define OP_AID_(s) \
2015 StgAddr x = PopTaggedAddr(); \
2016 int y = PopTaggedInt(); \
2017 StgDouble z = PopTaggedDouble(); \
2020 #define OP_AIs_(s) \
2022 StgAddr x = PopTaggedAddr(); \
2023 int y = PopTaggedInt(); \
2024 StgStablePtr z = PopTaggedStablePtr(); \
2029 #define OP_FF_B(e) \
2031 StgFloat x = PopTaggedFloat(); \
2032 StgFloat y = PopTaggedFloat(); \
2033 PushTaggedBool(e); \
2036 #define OP_FF_F(e) \
2038 StgFloat x = PopTaggedFloat(); \
2039 StgFloat y = PopTaggedFloat(); \
2040 PushTaggedFloat(e); \
2045 StgFloat x = PopTaggedFloat(); \
2046 PushTaggedFloat(e); \
2051 StgFloat x = PopTaggedFloat(); \
2052 PushTaggedBool(e); \
2057 StgFloat x = PopTaggedFloat(); \
2063 StgFloat x = PopTaggedFloat(); \
2064 PushTaggedDouble(e); \
2067 #define OP_DD_B(e) \
2069 StgDouble x = PopTaggedDouble(); \
2070 StgDouble y = PopTaggedDouble(); \
2071 PushTaggedBool(e); \
2074 #define OP_DD_D(e) \
2076 StgDouble x = PopTaggedDouble(); \
2077 StgDouble y = PopTaggedDouble(); \
2078 PushTaggedDouble(e); \
2083 StgDouble x = PopTaggedDouble(); \
2084 PushTaggedBool(e); \
2089 StgDouble x = PopTaggedDouble(); \
2090 PushTaggedDouble(e); \
2095 StgDouble x = PopTaggedDouble(); \
2101 StgDouble x = PopTaggedDouble(); \
2102 PushTaggedFloat(e); \
2106 #ifdef STANDALONE_INTEGER
2107 StgPtr CreateByteArrayToHoldInteger ( int nbytes )
2109 StgInt words = (nbytes+sizeof(W_)-1)/sizeof(W_);
2110 StgWord size = sizeofW(StgArrWords) + words;
2111 StgArrWords* arr = (StgArrWords*)allocate(size);
2112 SET_HDR(arr,&ARR_WORDS_info,CCCS);
2114 ASSERT(nbytes <= arr->words * sizeof(W_));
2117 for (i = 0; i < words; ++i) {
2118 arr->payload[i] = 0xdeadbeef;
2120 { B* b = (B*) &(arr->payload[0]);
2121 b->used = b->sign = 0;
2127 B* IntegerInsideByteArray ( StgPtr arr0 )
2130 StgArrWords* arr = (StgArrWords*)arr0;
2131 ASSERT(GET_INFO(arr) == &ARR_WORDS_info);
2132 b = (B*) &(arr->payload[0]);
2136 void SloppifyIntegerEnd ( StgPtr arr0 )
2138 StgArrWords* arr = (StgArrWords*)arr0;
2139 B* b = (B*) & (arr->payload[0]);
2140 I_ nwunused = arr->words - sizeofW(B) - (b->used+sizeof(W_)-1)/sizeof(W_);
2141 if (nwunused >= ((I_)sizeofW(StgArrWords))) {
2143 b->size -= nwunused * sizeof(W_);
2144 if (b->size < b->used) b->size = b->used;
2147 arr->words -= nwunused;
2148 slop = (StgArrWords*)&(arr->payload[arr->words]);
2149 SET_HDR(slop,&ARR_WORDS_info,CCCS);
2150 slop->words = nwunused - sizeofW(StgArrWords);
2151 ASSERT( &(slop->payload[slop->words]) ==
2152 &(arr->payload[arr->words + nwunused]) );
2156 #define OP_Z_Z(op) \
2158 B* x = IntegerInsideByteArray(PopPtr()); \
2159 int n = mycat2(size_,op)(x); \
2160 StgPtr p = CreateByteArrayToHoldInteger(n); \
2161 mycat2(do_,op)(x,n,IntegerInsideByteArray(p)); \
2162 SloppifyIntegerEnd(p); \
2165 #define OP_ZZ_Z(op) \
2167 B* x = IntegerInsideByteArray(PopPtr()); \
2168 B* y = IntegerInsideByteArray(PopPtr()); \
2169 int n = mycat2(size_,op)(x,y); \
2170 StgPtr p = CreateByteArrayToHoldInteger(n); \
2171 mycat2(do_,op)(x,y,n,IntegerInsideByteArray(p)); \
2172 SloppifyIntegerEnd(p); \
2180 #define HEADER_mI(ty,where) \
2181 StgArrWords* x = stgCast(StgArrWords*,PopPtr()); \
2182 nat i = PopTaggedInt(); \
2183 if (i * sizeof(ty) + (sizeof(ty)) > sizeof(StgWord) * x->words) { \
2184 return (raiseIndex(where)); \
2186 #define OP_mI_ty(ty,where,s) \
2188 HEADER_mI(mycat2(Stg,ty),where) \
2189 { mycat2(Stg,ty) r; \
2191 mycat2(PushTagged,ty)(r); \
2194 #define OP_mIty_(ty,where,s) \
2196 HEADER_mI(mycat2(Stg,ty),where) \
2198 mycat2(Stg,ty) z = mycat2(PopTagged,ty)(); \
2204 void myStackCheck ( Capability* cap )
2206 /* fprintf(stderr, "myStackCheck\n"); */
2207 if (!(gSpLim <= gSp && gSp <= stgCast(StgPtr,gSu))) {
2208 fprintf(stderr, "myStackCheck: invalid initial gSp/gSu \n" );
2212 if (!(gSu >= cap->rCurrentTSO->stack
2213 && gSu <= cap->rCurrentTSO->stack
2214 + cap->rCurrentTSO->stack_size)) {
2215 fprintf ( stderr, "myStackCheck: gSu out of stack\n" );
2218 switch (get_itbl(stgCast(StgClosure*,gSu))->type) {
2220 gSu = (StgPtr) ((StgCatchFrame*)(gSu))->link;
2223 gSu = (StgPtr) ((StgUpdateFrame*)(gSu))->link;
2226 gSu = (StgPtr) ((StgSeqFrame*)(gSu))->link;
2231 fprintf(stderr, "myStackCheck: invalid activation record\n"); assert(0);
2238 /* --------------------------------------------------------------------------
2239 * Primop stuff for bytecode interpreter
2240 * ------------------------------------------------------------------------*/
2242 /* Returns & of the next thing to enter (if throwing an exception),
2243 or NULL in the normal case.
2245 static void* enterBCO_primop1 ( int primop1code )
2247 switch (primop1code) {
2248 case i_pushseqframe:
2250 StgClosure* c = PopCPtr();
2255 case i_pushcatchframe:
2257 StgClosure* e = PopCPtr();
2258 StgClosure* h = PopCPtr();
2264 case i_gtChar: OP_CC_B(x>y); break;
2265 case i_geChar: OP_CC_B(x>=y); break;
2266 case i_eqChar: OP_CC_B(x==y); break;
2267 case i_neChar: OP_CC_B(x!=y); break;
2268 case i_ltChar: OP_CC_B(x<y); break;
2269 case i_leChar: OP_CC_B(x<=y); break;
2270 case i_charToInt: OP_C_I(x); break;
2271 case i_intToChar: OP_I_C(x); break;
2273 case i_gtInt: OP_II_B(x>y); break;
2274 case i_geInt: OP_II_B(x>=y); break;
2275 case i_eqInt: OP_II_B(x==y); break;
2276 case i_neInt: OP_II_B(x!=y); break;
2277 case i_ltInt: OP_II_B(x<y); break;
2278 case i_leInt: OP_II_B(x<=y); break;
2279 case i_minInt: OP__I(INT_MIN); break;
2280 case i_maxInt: OP__I(INT_MAX); break;
2281 case i_plusInt: OP_II_I(x+y); break;
2282 case i_minusInt: OP_II_I(x-y); break;
2283 case i_timesInt: OP_II_I(x*y); break;
2286 int x = PopTaggedInt();
2287 int y = PopTaggedInt();
2289 return (raiseDiv0("quotInt"));
2291 /* ToDo: protect against minInt / -1 errors
2292 * (repeat for all other division primops) */
2298 int x = PopTaggedInt();
2299 int y = PopTaggedInt();
2301 return (raiseDiv0("remInt"));
2308 StgInt x = PopTaggedInt();
2309 StgInt y = PopTaggedInt();
2311 return (raiseDiv0("quotRemInt"));
2313 PushTaggedInt(x%y); /* last result */
2314 PushTaggedInt(x/y); /* first result */
2317 case i_negateInt: OP_I_I(-x); break;
2319 case i_andInt: OP_II_I(x&y); break;
2320 case i_orInt: OP_II_I(x|y); break;
2321 case i_xorInt: OP_II_I(x^y); break;
2322 case i_notInt: OP_I_I(~x); break;
2323 case i_shiftLInt: OP_II_I(x<<y); break;
2324 case i_shiftRAInt: OP_II_I(x>>y); break; /* ToDo */
2325 case i_shiftRLInt: OP_II_I(x>>y); break; /* ToDo */
2327 case i_gtWord: OP_WW_B(x>y); break;
2328 case i_geWord: OP_WW_B(x>=y); break;
2329 case i_eqWord: OP_WW_B(x==y); break;
2330 case i_neWord: OP_WW_B(x!=y); break;
2331 case i_ltWord: OP_WW_B(x<y); break;
2332 case i_leWord: OP_WW_B(x<=y); break;
2333 case i_minWord: OP__W(0); break;
2334 case i_maxWord: OP__W(UINT_MAX); break;
2335 case i_plusWord: OP_WW_W(x+y); break;
2336 case i_minusWord: OP_WW_W(x-y); break;
2337 case i_timesWord: OP_WW_W(x*y); break;
2340 StgWord x = PopTaggedWord();
2341 StgWord y = PopTaggedWord();
2343 return (raiseDiv0("quotWord"));
2345 PushTaggedWord(x/y);
2350 StgWord x = PopTaggedWord();
2351 StgWord y = PopTaggedWord();
2353 return (raiseDiv0("remWord"));
2355 PushTaggedWord(x%y);
2360 StgWord x = PopTaggedWord();
2361 StgWord y = PopTaggedWord();
2363 return (raiseDiv0("quotRemWord"));
2365 PushTaggedWord(x%y); /* last result */
2366 PushTaggedWord(x/y); /* first result */
2369 case i_negateWord: OP_W_W(-x); break;
2370 case i_andWord: OP_WW_W(x&y); break;
2371 case i_orWord: OP_WW_W(x|y); break;
2372 case i_xorWord: OP_WW_W(x^y); break;
2373 case i_notWord: OP_W_W(~x); break;
2374 case i_shiftLWord: OP_WW_W(x<<y); break;
2375 case i_shiftRAWord: OP_WW_W(x>>y); break; /* ToDo */
2376 case i_shiftRLWord: OP_WW_W(x>>y); break; /* ToDo */
2377 case i_intToWord: OP_I_W(x); break;
2378 case i_wordToInt: OP_W_I(x); break;
2380 case i_gtAddr: OP_AA_B(x>y); break;
2381 case i_geAddr: OP_AA_B(x>=y); break;
2382 case i_eqAddr: OP_AA_B(x==y); break;
2383 case i_neAddr: OP_AA_B(x!=y); break;
2384 case i_ltAddr: OP_AA_B(x<y); break;
2385 case i_leAddr: OP_AA_B(x<=y); break;
2386 case i_intToAddr: OP_I_A((StgAddr)x); break; /* ToDo */
2387 case i_addrToInt: OP_A_I((StgInt)x); break; /* ToDo */
2389 case i_intToStable: OP_I_s(x); break;
2390 case i_stableToInt: OP_s_I(x); break;
2392 case i_indexCharOffAddr: OP_AI_C(indexCharOffAddrzh(r,x,y)); break;
2393 case i_readCharOffAddr: OP_AI_C(indexCharOffAddrzh(r,x,y)); break;
2394 case i_writeCharOffAddr: OP_AIC_(writeCharOffAddrzh(x,y,z)); break;
2396 case i_indexIntOffAddr: OP_AI_I(indexIntOffAddrzh(r,x,y)); break;
2397 case i_readIntOffAddr: OP_AI_I(indexIntOffAddrzh(r,x,y)); break;
2398 case i_writeIntOffAddr: OP_AII_(writeIntOffAddrzh(x,y,z)); break;
2400 case i_indexAddrOffAddr: OP_AI_A(indexAddrOffAddrzh(r,x,y)); break;
2401 case i_readAddrOffAddr: OP_AI_A(indexAddrOffAddrzh(r,x,y)); break;
2402 case i_writeAddrOffAddr: OP_AIA_(writeAddrOffAddrzh(x,y,z)); break;
2404 case i_indexFloatOffAddr: OP_AI_F(indexFloatOffAddrzh(r,x,y)); break;
2405 case i_readFloatOffAddr: OP_AI_F(indexFloatOffAddrzh(r,x,y)); break;
2406 case i_writeFloatOffAddr: OP_AIF_(writeFloatOffAddrzh(x,y,z)); break;
2408 case i_indexDoubleOffAddr: OP_AI_D(indexDoubleOffAddrzh(r,x,y)); break;
2409 case i_readDoubleOffAddr: OP_AI_D(indexDoubleOffAddrzh(r,x,y)); break;
2410 case i_writeDoubleOffAddr: OP_AID_(writeDoubleOffAddrzh(x,y,z)); break;
2412 case i_indexStableOffAddr: OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break;
2413 case i_readStableOffAddr: OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break;
2414 case i_writeStableOffAddr: OP_AIs_(writeStablePtrOffAddrzh(x,y,z)); break;
2416 #ifdef STANDALONE_INTEGER
2417 case i_compareInteger:
2419 B* x = IntegerInsideByteArray(PopPtr());
2420 B* y = IntegerInsideByteArray(PopPtr());
2421 StgInt r = do_cmp(x,y);
2422 PushTaggedInt(r<0 ? -1 : (r>0 ? 1 : 0));
2425 case i_negateInteger: OP_Z_Z(neg); break;
2426 case i_plusInteger: OP_ZZ_Z(add); break;
2427 case i_minusInteger: OP_ZZ_Z(sub); break;
2428 case i_timesInteger: OP_ZZ_Z(mul); break;
2429 case i_quotRemInteger:
2431 B* x = IntegerInsideByteArray(PopPtr());
2432 B* y = IntegerInsideByteArray(PopPtr());
2433 int n = size_qrm(x,y);
2434 StgPtr q = CreateByteArrayToHoldInteger(n);
2435 StgPtr r = CreateByteArrayToHoldInteger(n);
2436 if (do_getsign(y)==0)
2437 return (raiseDiv0("quotRemInteger"));
2438 do_qrm(x,y,n,IntegerInsideByteArray(q),
2439 IntegerInsideByteArray(r));
2440 SloppifyIntegerEnd(q);
2441 SloppifyIntegerEnd(r);
2446 case i_intToInteger:
2448 int n = size_fromInt();
2449 StgPtr p = CreateByteArrayToHoldInteger(n);
2450 do_fromInt( PopTaggedInt(), n, IntegerInsideByteArray(p));
2454 case i_wordToInteger:
2456 int n = size_fromWord();
2457 StgPtr p = CreateByteArrayToHoldInteger(n);
2458 do_fromWord( PopTaggedWord(), n, IntegerInsideByteArray(p));
2462 case i_integerToInt: PushTaggedInt(do_toInt(
2463 IntegerInsideByteArray(PopPtr())
2467 case i_integerToWord: PushTaggedWord(do_toWord(
2468 IntegerInsideByteArray(PopPtr())
2472 case i_integerToFloat: PushTaggedFloat(do_toFloat(
2473 IntegerInsideByteArray(PopPtr())
2477 case i_integerToDouble: PushTaggedDouble(do_toDouble(
2478 IntegerInsideByteArray(PopPtr())
2482 #error Non-standalone integer not yet implemented
2483 #endif /* STANDALONE_INTEGER */
2485 case i_gtFloat: OP_FF_B(x>y); break;
2486 case i_geFloat: OP_FF_B(x>=y); break;
2487 case i_eqFloat: OP_FF_B(x==y); break;
2488 case i_neFloat: OP_FF_B(x!=y); break;
2489 case i_ltFloat: OP_FF_B(x<y); break;
2490 case i_leFloat: OP_FF_B(x<=y); break;
2491 case i_minFloat: OP__F(FLT_MIN); break;
2492 case i_maxFloat: OP__F(FLT_MAX); break;
2493 case i_radixFloat: OP__I(FLT_RADIX); break;
2494 case i_digitsFloat: OP__I(FLT_MANT_DIG); break;
2495 case i_minExpFloat: OP__I(FLT_MIN_EXP); break;
2496 case i_maxExpFloat: OP__I(FLT_MAX_EXP); break;
2497 case i_plusFloat: OP_FF_F(x+y); break;
2498 case i_minusFloat: OP_FF_F(x-y); break;
2499 case i_timesFloat: OP_FF_F(x*y); break;
2502 StgFloat x = PopTaggedFloat();
2503 StgFloat y = PopTaggedFloat();
2504 PushTaggedFloat(x/y);
2507 case i_negateFloat: OP_F_F(-x); break;
2508 case i_floatToInt: OP_F_I(x); break;
2509 case i_intToFloat: OP_I_F(x); break;
2510 case i_expFloat: OP_F_F(exp(x)); break;
2511 case i_logFloat: OP_F_F(log(x)); break;
2512 case i_sqrtFloat: OP_F_F(sqrt(x)); break;
2513 case i_sinFloat: OP_F_F(sin(x)); break;
2514 case i_cosFloat: OP_F_F(cos(x)); break;
2515 case i_tanFloat: OP_F_F(tan(x)); break;
2516 case i_asinFloat: OP_F_F(asin(x)); break;
2517 case i_acosFloat: OP_F_F(acos(x)); break;
2518 case i_atanFloat: OP_F_F(atan(x)); break;
2519 case i_sinhFloat: OP_F_F(sinh(x)); break;
2520 case i_coshFloat: OP_F_F(cosh(x)); break;
2521 case i_tanhFloat: OP_F_F(tanh(x)); break;
2522 case i_powerFloat: OP_FF_F(pow(x,y)); break;
2524 #ifdef STANDALONE_INTEGER
2525 case i_encodeFloatZ:
2527 StgPtr sig = PopPtr();
2528 StgInt exp = PopTaggedInt();
2530 B__encodeFloat(IntegerInsideByteArray(sig), exp)
2534 case i_decodeFloatZ:
2536 StgFloat f = PopTaggedFloat();
2537 StgPtr sig = CreateByteArrayToHoldInteger(size_fltmantissa());
2539 B__decodeFloat(IntegerInsideByteArray(sig), &exp, f);
2545 #error encode/decodeFloatZ not yet implemented for GHC ints
2547 case i_isNaNFloat: OP_F_B(isFloatNaN(x)); break;
2548 case i_isInfiniteFloat: OP_F_B(isFloatInfinite(x)); break;
2549 case i_isNegativeZeroFloat: OP_F_B(isFloatNegativeZero(x)); break;
2550 case i_isDenormalizedFloat: OP_F_B(isFloatDenormalized(x)); break;
2551 case i_gtDouble: OP_DD_B(x>y); break;
2552 case i_geDouble: OP_DD_B(x>=y); break;
2553 case i_eqDouble: OP_DD_B(x==y); break;
2554 case i_neDouble: OP_DD_B(x!=y); break;
2555 case i_ltDouble: OP_DD_B(x<y); break;
2556 case i_leDouble: OP_DD_B(x<=y) break;
2557 case i_minDouble: OP__D(DBL_MIN); break;
2558 case i_maxDouble: OP__D(DBL_MAX); break;
2559 case i_radixDouble: OP__I(FLT_RADIX); break;
2560 case i_digitsDouble: OP__I(DBL_MANT_DIG); break;
2561 case i_minExpDouble: OP__I(DBL_MIN_EXP); break;
2562 case i_maxExpDouble: OP__I(DBL_MAX_EXP); break;
2563 case i_plusDouble: OP_DD_D(x+y); break;
2564 case i_minusDouble: OP_DD_D(x-y); break;
2565 case i_timesDouble: OP_DD_D(x*y); break;
2566 case i_divideDouble:
2568 StgDouble x = PopTaggedDouble();
2569 StgDouble y = PopTaggedDouble();
2570 PushTaggedDouble(x/y);
2573 case i_negateDouble: OP_D_D(-x); break;
2574 case i_doubleToInt: OP_D_I(x); break;
2575 case i_intToDouble: OP_I_D(x); break;
2576 case i_doubleToFloat: OP_D_F(x); break;
2577 case i_floatToDouble: OP_F_F(x); break;
2578 case i_expDouble: OP_D_D(exp(x)); break;
2579 case i_logDouble: OP_D_D(log(x)); break;
2580 case i_sqrtDouble: OP_D_D(sqrt(x)); break;
2581 case i_sinDouble: OP_D_D(sin(x)); break;
2582 case i_cosDouble: OP_D_D(cos(x)); break;
2583 case i_tanDouble: OP_D_D(tan(x)); break;
2584 case i_asinDouble: OP_D_D(asin(x)); break;
2585 case i_acosDouble: OP_D_D(acos(x)); break;
2586 case i_atanDouble: OP_D_D(atan(x)); break;
2587 case i_sinhDouble: OP_D_D(sinh(x)); break;
2588 case i_coshDouble: OP_D_D(cosh(x)); break;
2589 case i_tanhDouble: OP_D_D(tanh(x)); break;
2590 case i_powerDouble: OP_DD_D(pow(x,y)); break;
2592 #ifdef STANDALONE_INTEGER
2593 case i_encodeDoubleZ:
2595 StgPtr sig = PopPtr();
2596 StgInt exp = PopTaggedInt();
2598 B__encodeDouble(IntegerInsideByteArray(sig), exp)
2602 case i_decodeDoubleZ:
2604 StgDouble d = PopTaggedDouble();
2605 StgPtr sig = CreateByteArrayToHoldInteger(size_dblmantissa());
2607 B__decodeDouble(IntegerInsideByteArray(sig), &exp, d);
2613 #error encode/decodeDoubleZ not yet implemented for GHC ints
2615 case i_isNaNDouble: OP_D_B(isDoubleNaN(x)); break;
2616 case i_isInfiniteDouble: OP_D_B(isDoubleInfinite(x)); break;
2617 case i_isNegativeZeroDouble: OP_D_B(isDoubleNegativeZero(x)); break;
2618 case i_isDenormalizedDouble: OP_D_B(isDoubleDenormalized(x)); break;
2619 case i_isIEEEDouble:
2621 PushTaggedBool(rtsTrue);
2625 barf("Unrecognised primop1");
2632 /* For normal cases, return NULL and leave *return2 unchanged.
2633 To return the address of the next thing to enter,
2634 return the address of it and leave *return2 unchanged.
2635 To return a StgThreadReturnCode to the scheduler,
2636 set *return2 to it and return a non-NULL value.
2638 static void* enterBCO_primop2 ( int primop2code,
2639 int* /*StgThreadReturnCode* */ return2,
2643 switch (primop2code) {
2644 case i_raise: /* raise#{err} */
2646 StgClosure* err = PopCPtr();
2647 return (raiseAnError(err));
2652 StgClosure* init = PopCPtr();
2654 = stgCast(StgMutVar*,allocate(sizeofW(StgMutVar)));
2655 SET_HDR(mv,&MUT_VAR_info,CCCS);
2657 PushPtr(stgCast(StgPtr,mv));
2662 StgMutVar* mv = stgCast(StgMutVar*,PopPtr());
2668 StgMutVar* mv = stgCast(StgMutVar*,PopPtr());
2669 StgClosure* value = PopCPtr();
2675 nat n = PopTaggedInt(); /* or Word?? */
2676 StgClosure* init = PopCPtr();
2677 StgWord size = sizeofW(StgMutArrPtrs) + n;
2680 = stgCast(StgMutArrPtrs*,allocate(size));
2681 SET_HDR(arr,&MUT_ARR_PTRS_info,CCCS);
2683 for (i = 0; i < n; ++i) {
2684 arr->payload[i] = init;
2686 PushPtr(stgCast(StgPtr,arr));
2692 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2693 nat i = PopTaggedInt(); /* or Word?? */
2694 StgWord n = arr->ptrs;
2696 return (raiseIndex("{index,read}Array"));
2698 PushCPtr(arr->payload[i]);
2703 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2704 nat i = PopTaggedInt(); /* or Word? */
2705 StgClosure* v = PopCPtr();
2706 StgWord n = arr->ptrs;
2708 return (raiseIndex("{index,read}Array"));
2710 arr->payload[i] = v;
2714 case i_sizeMutableArray:
2716 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2717 PushTaggedInt(arr->ptrs);
2720 case i_unsafeFreezeArray:
2722 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2723 SET_INFO(arr,&MUT_ARR_PTRS_FROZEN_info);
2724 PushPtr(stgCast(StgPtr,arr));
2727 case i_unsafeFreezeByteArray:
2729 /* Delightfully simple :-) */
2733 case i_sameMutableArray:
2734 case i_sameMutableByteArray:
2736 StgPtr x = PopPtr();
2737 StgPtr y = PopPtr();
2738 PushTaggedBool(x==y);
2742 case i_newByteArray:
2744 nat n = PopTaggedInt(); /* or Word?? */
2745 StgInt words = (n+sizeof(W_)-1)/sizeof(W_);
2746 StgWord size = sizeofW(StgArrWords) + words;
2747 StgArrWords* arr = stgCast(StgArrWords*,allocate(size));
2748 SET_HDR(arr,&ARR_WORDS_info,CCCS);
2752 for (i = 0; i < n; ++i) {
2753 arr->payload[i] = 0xdeadbeef;
2756 PushPtr(stgCast(StgPtr,arr));
2760 /* Most of these generate alignment warnings on Sparcs and similar architectures.
2761 * These are harmless and are caused by the cast to C* in BYTE_ARR_CTS.
2763 case i_indexCharArray:
2764 OP_mI_ty(Char,"indexCharArray", indexCharArrayzh(r,x,i)); break;
2765 case i_readCharArray:
2766 OP_mI_ty(Char,"readCharArray", readCharArrayzh(r,x,i)); break;
2767 case i_writeCharArray:
2768 OP_mIty_(Char,"writeCharArray", writeCharArrayzh(x,i,z)); break;
2770 case i_indexIntArray:
2771 OP_mI_ty(Int,"indexIntArray", indexIntArrayzh(r,x,i)); break;
2772 case i_readIntArray:
2773 OP_mI_ty(Int,"readIntArray", readIntArrayzh(r,x,i)); break;
2774 case i_writeIntArray:
2775 OP_mIty_(Int,"writeIntArray", writeIntArrayzh(x,i,z)); break;
2777 case i_indexAddrArray:
2778 OP_mI_ty(Addr,"indexAddrArray", indexAddrArrayzh(r,x,i)); break;
2779 case i_readAddrArray:
2780 OP_mI_ty(Addr,"readAddrArray", readAddrArrayzh(r,x,i)); break;
2781 case i_writeAddrArray:
2782 OP_mIty_(Addr,"writeAddrArray", writeAddrArrayzh(x,i,z)); break;
2784 case i_indexFloatArray:
2785 OP_mI_ty(Float,"indexFloatArray", indexFloatArrayzh(r,x,i)); break;
2786 case i_readFloatArray:
2787 OP_mI_ty(Float,"readFloatArray", readFloatArrayzh(r,x,i)); break;
2788 case i_writeFloatArray:
2789 OP_mIty_(Float,"writeFloatArray", writeFloatArrayzh(x,i,z)); break;
2791 case i_indexDoubleArray:
2792 OP_mI_ty(Double,"indexDoubleArray", indexDoubleArrayzh(r,x,i)); break;
2793 case i_readDoubleArray:
2794 OP_mI_ty(Double,"readDoubleArray", readDoubleArrayzh(r,x,i)); break;
2795 case i_writeDoubleArray:
2796 OP_mIty_(Double,"writeDoubleArray", writeDoubleArrayzh(x,i,z)); break;
2799 #ifdef PROVIDE_STABLE
2800 case i_indexStableArray:
2801 OP_mI_ty(StablePtr,"indexStableArray", indexStablePtrArrayzh(r,x,i)); break;
2802 case i_readStableArray:
2803 OP_mI_ty(StablePtr,"readStableArray", readStablePtrArrayzh(r,x,i)); break;
2804 case i_writeStableArray:
2805 OP_mIty_(StablePtr,"writeStableArray", writeStablePtrArrayzh(x,i,z)); break;
2811 #ifdef PROVIDE_COERCE
2812 case i_unsafeCoerce:
2814 /* Another nullop */
2818 #ifdef PROVIDE_PTREQUALITY
2819 case i_reallyUnsafePtrEquality:
2820 { /* identical to i_sameRef */
2821 StgPtr x = PopPtr();
2822 StgPtr y = PopPtr();
2823 PushTaggedBool(x==y);
2827 #ifdef PROVIDE_FOREIGN
2828 /* ForeignObj# operations */
2829 case i_makeForeignObj:
2831 StgForeignObj *result
2832 = stgCast(StgForeignObj*,allocate(sizeofW(StgForeignObj)));
2833 SET_HDR(result,&FOREIGN_info,CCCS);
2834 result -> data = PopTaggedAddr();
2835 PushPtr(stgCast(StgPtr,result));
2838 #endif /* PROVIDE_FOREIGN */
2843 = stgCast(StgWeak*,allocate(sizeofW(StgWeak)));
2844 SET_HDR(w, &WEAK_info, CCCS);
2846 w->value = PopCPtr();
2847 w->finaliser = PopCPtr();
2848 w->link = weak_ptr_list;
2850 IF_DEBUG(weak, fprintf(stderr,"New weak pointer at %p\n",w));
2851 PushPtr(stgCast(StgPtr,w));
2856 StgWeak *w = stgCast(StgWeak*,PopPtr());
2857 if (w->header.info == &WEAK_info) {
2858 PushCPtr(w->value); /* last result */
2859 PushTaggedInt(1); /* first result */
2861 PushPtr(stgCast(StgPtr,w));
2862 /* ToDo: error thunk would be better */
2867 #endif /* PROVIDE_WEAK */
2869 case i_makeStablePtr:
2871 StgPtr p = PopPtr();
2872 StgStablePtr sp = getStablePtr ( p );
2873 PushTaggedStablePtr(sp);
2876 case i_deRefStablePtr:
2879 StgStablePtr sp = PopTaggedStablePtr();
2880 p = deRefStablePtr(sp);
2884 case i_freeStablePtr:
2886 StgStablePtr sp = PopTaggedStablePtr();
2891 case i_createAdjThunkARCH:
2893 StgStablePtr stableptr = PopTaggedStablePtr();
2894 StgAddr typestr = PopTaggedAddr();
2895 StgChar callconv = PopTaggedChar();
2896 StgAddr adj_thunk = createAdjThunk(stableptr,typestr,callconv);
2897 PushTaggedAddr(adj_thunk);
2903 StgInt n = prog_argc;
2909 StgInt n = PopTaggedInt();
2910 StgAddr a = (StgAddr)prog_argv[n];
2917 StgMVar *mvar = stgCast(StgMVar*,allocate(sizeofW(StgMVar)));
2918 SET_INFO(mvar,&EMPTY_MVAR_info);
2919 mvar->head = mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
2920 mvar->value = stgCast(StgClosure*,&END_TSO_QUEUE_closure);
2921 PushPtr(stgCast(StgPtr,mvar));
2926 StgMVar *mvar = (StgMVar*)PopCPtr();
2927 if (GET_INFO(mvar) == &EMPTY_MVAR_info) {
2929 /* The MVar is empty. Attach ourselves to the TSO's
2932 if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
2933 mvar->head = cap->rCurrentTSO;
2935 mvar->tail->link = cap->rCurrentTSO;
2937 cap->rCurrentTSO->link = (StgTSO *)&END_TSO_QUEUE_closure;
2938 cap->rCurrentTSO->why_blocked = BlockedOnMVar;
2939 cap->rCurrentTSO->block_info.closure = (StgClosure *)mvar;
2940 mvar->tail = cap->rCurrentTSO;
2942 /* At this point, the top-of-stack holds the MVar,
2943 and underneath is the world token (). So the
2944 stack is in the same state as when primTakeMVar
2945 was entered (primTakeMVar is handwritten bytecode).
2946 Push obj, which is this BCO, and return to the
2947 scheduler. When the MVar is filled, the scheduler
2948 will re-enter primTakeMVar, with the args still on
2949 the top of the stack.
2951 PushCPtr((StgClosure*)(*bco));
2952 *return2 = ThreadBlocked;
2953 return (void*)(1+(NULL));
2956 PushCPtr(mvar->value);
2957 mvar->value = (StgClosure *)&END_TSO_QUEUE_closure;
2958 SET_INFO(mvar,&EMPTY_MVAR_info);
2964 StgMVar* mvar = stgCast(StgMVar*,PopPtr());
2965 StgClosure* value = PopCPtr();
2966 if (GET_INFO(mvar) == &FULL_MVAR_info) {
2967 return (makeErrorCall("putMVar {full MVar}"));
2969 /* wake up the first thread on the
2970 * queue, it will continue with the
2971 * takeMVar operation and mark the
2974 mvar->value = value;
2976 if (mvar->head != (StgTSO *)&END_TSO_QUEUE_closure) {
2977 ASSERT(mvar->head->why_blocked == BlockedOnMVar);
2978 mvar->head = unblockOne(mvar->head);
2979 if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
2980 mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
2984 /* unlocks the MVar in the SMP case */
2985 SET_INFO(mvar,&FULL_MVAR_info);
2987 /* yield for better communication performance */
2993 { /* identical to i_sameRef */
2994 StgMVar* x = (StgMVar*)PopPtr();
2995 StgMVar* y = (StgMVar*)PopPtr();
2996 PushTaggedBool(x==y);
3001 StgWord tid = cap->rCurrentTSO->id;
3002 PushTaggedWord(tid);
3005 case i_cmpThreadIds:
3007 StgWord tid1 = PopTaggedWord();
3008 StgWord tid2 = PopTaggedWord();
3009 if (tid1 < tid2) PushTaggedInt(-1);
3010 else if (tid1 > tid2) PushTaggedInt(1);
3011 else PushTaggedInt(0);
3016 StgClosure* closure;
3019 closure = PopCPtr();
3020 tso = createGenThread (RtsFlags.GcFlags.initialStkSize,closure);
3022 scheduleThread(tso);
3024 PushTaggedWord(tid);
3028 #ifdef PROVIDE_CONCURRENT
3031 StgTSO* tso = stgCast(StgTSO*,PopPtr());
3033 if (tso == cap->rCurrentTSO) { /* suicide */
3034 *return2 = ThreadFinished;
3035 return (void*)(1+(NULL));
3042 ToDo: another way out of the problem might be to add an explicit
3043 continuation to primTakeMVar: takeMVar v = primTakeMVar v takeMVar.
3044 The problem with this plan is that now I dont know how much to chop
3051 /* As PrimOps.h says: Hmm, I'll think about these later. */
3054 #endif /* PROVIDE_CONCURRENT */
3056 case i_ccall_ccall_Id:
3057 case i_ccall_ccall_IO:
3058 case i_ccall_stdcall_Id:
3059 case i_ccall_stdcall_IO:
3062 CFunDescriptor* descriptor = PopTaggedAddr();
3063 void (*funPtr)(void) = PopTaggedAddr();
3064 char cc = (primop2code == i_ccall_stdcall_Id ||
3065 primop2code == i_ccall_stdcall_IO)
3067 r = ccall(descriptor,funPtr,bco,cc,cap);
3070 return makeErrorCall(
3071 "unhandled type or too many args/results in ccall");
3073 barf("ccall not configured correctly for this platform");
3074 barf("unknown return code from ccall");
3077 barf("Unrecognised primop2");
3083 /* -----------------------------------------------------------------------------
3084 * ccall support code:
3085 * marshall moves args from C stack to Haskell stack
3086 * unmarshall moves args from Haskell stack to C stack
3087 * argSize calculates how much gSpace you need on the C stack
3088 * ---------------------------------------------------------------------------*/
3090 /* Pop arguments off the C stack and Push them onto the Hugs stack.
3091 * Used when preparing for C calling Haskell or in regSponse to
3092 * Haskell calling C.
3094 nat marshall(char arg_ty, void* arg)
3098 PushTaggedInt(*((int*)arg));
3099 return ARG_SIZE(INT_TAG);
3100 #ifdef TODO_STANDALONE_INTEGER
3102 PushTaggedInteger(*((mpz_ptr*)arg));
3103 return ARG_SIZE(INTEGER_TAG);
3106 PushTaggedWord(*((unsigned int*)arg));
3107 return ARG_SIZE(WORD_TAG);
3109 PushTaggedChar(*((char*)arg));
3110 return ARG_SIZE(CHAR_TAG);
3112 PushTaggedFloat(*((float*)arg));
3113 return ARG_SIZE(FLOAT_TAG);
3115 PushTaggedDouble(*((double*)arg));
3116 return ARG_SIZE(DOUBLE_TAG);
3118 PushTaggedAddr(*((void**)arg));
3119 return ARG_SIZE(ADDR_TAG);
3121 PushTaggedStablePtr(*((StgStablePtr*)arg));
3122 return ARG_SIZE(STABLE_TAG);
3123 #ifdef PROVIDE_FOREIGN
3125 /* Not allowed in this direction - you have to
3126 * call makeForeignPtr explicitly
3128 barf("marshall: ForeignPtr#\n");
3133 /* Not allowed in this direction */
3134 barf("marshall: [Mutable]ByteArray#\n");
3137 barf("marshall: unrecognised arg type %d\n",arg_ty);
3142 /* Pop arguments off the Hugs stack and Push them onto the C stack.
3143 * Used when preparing for Haskell calling C or in regSponse to
3144 * C calling Haskell.
3146 nat unmarshall(char res_ty, void* res)
3150 *((int*)res) = PopTaggedInt();
3151 return ARG_SIZE(INT_TAG);
3152 #ifdef TODO_STANDALONE_INTEGER
3154 *((mpz_ptr*)res) = PopTaggedInteger();
3155 return ARG_SIZE(INTEGER_TAG);
3158 *((unsigned int*)res) = PopTaggedWord();
3159 return ARG_SIZE(WORD_TAG);
3161 *((int*)res) = PopTaggedChar();
3162 return ARG_SIZE(CHAR_TAG);
3164 *((float*)res) = PopTaggedFloat();
3165 return ARG_SIZE(FLOAT_TAG);
3167 *((double*)res) = PopTaggedDouble();
3168 return ARG_SIZE(DOUBLE_TAG);
3170 *((void**)res) = PopTaggedAddr();
3171 return ARG_SIZE(ADDR_TAG);
3173 *((StgStablePtr*)res) = PopTaggedStablePtr();
3174 return ARG_SIZE(STABLE_TAG);
3175 #ifdef PROVIDE_FOREIGN
3178 StgForeignObj *result = stgCast(StgForeignObj*,PopPtr());
3179 *((void**)res) = result->data;
3180 return sizeofW(StgPtr);
3186 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
3187 *((void**)res) = stgCast(void*,&(arr->payload));
3188 return sizeofW(StgPtr);
3191 barf("unmarshall: unrecognised result type %d\n",res_ty);
3195 nat argSize( const char* ks )
3198 for( ; *ks != '\0'; ++ks) {
3201 sz += sizeof(StgWord) * ARG_SIZE(INT_TAG);
3203 #ifdef TODO_STANDALONE_INTEGER
3205 sz += sizeof(StgWord) * ARG_SIZE(INTEGER_TAG);
3209 sz += sizeof(StgWord) * ARG_SIZE(WORD_TAG);
3212 sz += sizeof(StgWord) * ARG_SIZE(CHAR_TAG);
3215 sz += sizeof(StgWord) * ARG_SIZE(FLOAT_TAG);
3218 sz += sizeof(StgWord) * ARG_SIZE(DOUBLE_TAG);
3221 sz += sizeof(StgWord) * ARG_SIZE(ADDR_TAG);
3224 sz += sizeof(StgWord) * ARG_SIZE(STABLE_TAG);
3226 #ifdef PROVIDE_FOREIGN
3231 sz += sizeof(StgPtr);
3234 barf("argSize: unrecognised result type %d\n",*ks);
3242 /* -----------------------------------------------------------------------------
3243 * encode/decode Float/Double code for standalone Hugs
3244 * Code based on the HBC code (lib/fltcode.c) and more recently GHC
3245 * (ghc/rts/StgPrimFloat.c)
3246 * ---------------------------------------------------------------------------*/
3248 #ifdef STANDALONE_INTEGER
3250 #if IEEE_FLOATING_POINT
3251 #define MY_DMINEXP ((DBL_MIN_EXP) - (DBL_MANT_DIG) - 1)
3252 /* DMINEXP is defined in values.h on Linux (for example) */
3253 #define DHIGHBIT 0x00100000
3254 #define DMSBIT 0x80000000
3256 #define MY_FMINEXP ((FLT_MIN_EXP) - (FLT_MANT_DIG) - 1)
3257 #define FHIGHBIT 0x00800000
3258 #define FMSBIT 0x80000000
3260 #error The following code doesnt work in a non-IEEE FP environment
3263 #ifdef WORDS_BIGENDIAN
3272 StgDouble B__encodeDouble (B* s, I_ e) /* result = s * 2^e */
3277 /* Convert a B to a double; knows a lot about internal rep! */
3278 for(r = 0.0, i = s->used-1; i >= 0; i--)
3279 r = (r * B_BASE_FLT) + s->stuff[i];
3281 /* Now raise to the exponent */
3282 if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
3285 /* handle the sign */
3286 if (s->sign < 0) r = -r;
3293 #if ! FLOATS_AS_DOUBLES
3294 StgFloat B__encodeFloat (B* s, I_ e) /* result = s * 2^e */
3299 /* Convert a B to a float; knows a lot about internal rep! */
3300 for(r = 0.0, i = s->used-1; i >= 0; i--)
3301 r = (r * B_BASE_FLT) + s->stuff[i];
3303 /* Now raise to the exponent */
3304 if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
3307 /* handle the sign */
3308 if (s->sign < 0) r = -r;
3312 #endif /* FLOATS_AS_DOUBLES */
3316 /* This only supports IEEE floating point */
3317 void B__decodeDouble (B* man, I_* exp, StgDouble dbl)
3319 /* Do some bit fiddling on IEEE */
3320 nat low, high; /* assuming 32 bit ints */
3322 union { double d; int i[2]; } u; /* assuming 32 bit ints, 64 bit double */
3324 u.d = dbl; /* grab chunks of the double */
3328 ASSERT(B_BASE == 256);
3330 /* Assume that the supplied B is the right size */
3333 if (low == 0 && (high & ~DMSBIT) == 0) {
3334 man->sign = man->used = 0;
3339 iexp = ((high >> 20) & 0x7ff) + MY_DMINEXP;
3343 if (iexp != MY_DMINEXP) /* don't add hidden bit to denorms */
3347 /* A denorm, normalize the mantissa */
3348 while (! (high & DHIGHBIT)) {
3358 man->stuff[7] = (((W_)high) >> 24) & 0xff;
3359 man->stuff[6] = (((W_)high) >> 16) & 0xff;
3360 man->stuff[5] = (((W_)high) >> 8) & 0xff;
3361 man->stuff[4] = (((W_)high) ) & 0xff;
3363 man->stuff[3] = (((W_)low) >> 24) & 0xff;
3364 man->stuff[2] = (((W_)low) >> 16) & 0xff;
3365 man->stuff[1] = (((W_)low) >> 8) & 0xff;
3366 man->stuff[0] = (((W_)low) ) & 0xff;
3368 if (sign < 0) man->sign = -1;
3370 do_renormalise(man);
3374 #if ! FLOATS_AS_DOUBLES
3375 void B__decodeFloat (B* man, I_* exp, StgFloat flt)
3377 /* Do some bit fiddling on IEEE */
3378 int high, sign; /* assuming 32 bit ints */
3379 union { float f; int i; } u; /* assuming 32 bit float and int */
3381 u.f = flt; /* grab the float */
3384 ASSERT(B_BASE == 256);
3386 /* Assume that the supplied B is the right size */
3389 if ((high & ~FMSBIT) == 0) {
3390 man->sign = man->used = 0;
3395 *exp = ((high >> 23) & 0xff) + MY_FMINEXP;
3399 if (*exp != MY_FMINEXP) /* don't add hidden bit to denorms */
3403 /* A denorm, normalize the mantissa */
3404 while (! (high & FHIGHBIT)) {
3409 man->stuff[3] = (((W_)high) >> 24) & 0xff;
3410 man->stuff[2] = (((W_)high) >> 16) & 0xff;
3411 man->stuff[1] = (((W_)high) >> 8) & 0xff;
3412 man->stuff[0] = (((W_)high) ) & 0xff;
3414 if (sign < 0) man->sign = -1;
3416 do_renormalise(man);
3419 #endif /* FLOATS_AS_DOUBLES */
3421 #endif /* STANDALONE_INTEGER */
3423 #endif /* INTERPRETER */