2 /* -----------------------------------------------------------------------------
5 * Copyright (c) 1994-1998.
7 * $RCSfile: Evaluator.c,v $
9 * $Date: 1999/11/12 17:50:04 $
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* errObj );
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");
507 if (context_switch) {
508 xPushCPtr(obj); /* code to restart with */
509 RETURN(ThreadYielding);
513 switch ( get_itbl(obj)->type ) {
515 barf("Invalid object %p",obj);
519 /* ---------------------------------------------------- */
520 /* Start of the bytecode evaluator */
521 /* ---------------------------------------------------- */
524 # define Ins(x) &&l##x
525 static void *labs[] = { INSTRLIST };
527 # define LoopTopLabel
528 # define Case(x) l##x
529 # define Continue goto *labs[BCO_INSTR_8]
530 # define Dispatch Continue;
533 # define LoopTopLabel insnloop:
534 # define Case(x) case x
535 # define Continue goto insnloop
536 # define Dispatch switch (BCO_INSTR_8) {
537 # define EndDispatch }
540 register StgWord8* bciPtr; /* instruction pointer */
541 register StgBCO* bco = (StgBCO*)obj;
544 /* Don't need to SSS ... LLL around doYouWantToGC */
545 wantToGC = doYouWantToGC();
547 xPushCPtr((StgClosure*)bco); /* code to restart with */
548 RETURN(HeapOverflow);
556 bciPtr = &(bcoInstr(bco,0));
560 ASSERT((StgWord)(PC) < bco->n_instrs);
562 fprintf(stderr,"Sp = %p\tSu = %p\tpc = %d\t", xSp, xSu, PC);
566 fprintf(stderr,"\n");
567 for (i = 8; i >= 0; i--)
568 fprintf(stderr, "%d %p\n", i, (StgPtr)(*(gSp+i)));
570 fprintf(stderr,"\n");
575 SSS; cp_bill_insns(1); LLL;
580 Case(i_INTERNAL_ERROR):
581 barf("INTERNAL_ERROR at %p:%d",bco,PC-1);
583 barf("PANIC at %p:%d",bco,PC-1);
587 if (xSp - n < xSpLim) {
588 xPushCPtr((StgClosure*)bco); /* code to restart with */
589 RETURN(StackOverflow);
593 Case(i_STK_CHECK_big):
595 int n = BCO_INSTR_16;
596 if (xSp - n < xSpLim) {
597 xPushCPtr((StgClosure*)bco); /* code to restart with */
598 RETURN(StackOverflow);
605 if ((StgPtr*)(xSp + n) > (StgPtr*)xSu) {
606 StgWord words = (P_)xSu - xSp;
608 /* first build a PAP */
609 ASSERT((P_)xSu >= xSp); /* was (words >= 0) but that's always true */
610 if (words == 0) { /* optimisation */
611 /* Skip building the PAP and update with an indirection. */
614 /* In the evaluator, we avoid the need to do
615 * a heap check here by including the size of
616 * the PAP in the heap check we performed
617 * when we entered the BCO.
621 SSS; pap = (StgPAP*)grabHpNonUpd(PAP_sizeW(words)); LLL;
622 SET_HDR(pap,&PAP_info,CC_pap);
625 for (i = 0; i < (I_)words; ++i) {
626 payloadWord(pap,i) = xSp[i];
629 obj = stgCast(StgClosure*,pap);
632 /* now deal with "update frame" */
633 /* as an optimisation, we process all on top of stack */
634 /* instead of just the top one */
635 ASSERT(xSp==(P_)xSu);
637 switch (get_itbl(xSu)->type) {
639 /* Hit a catch frame during an arg satisfaction check,
640 * so the thing returning (1) has not thrown an
641 * exception, and (2) is of functional type. Just
642 * zap the catch frame and carry on down the stack
643 * (looking for more arguments, basically).
645 SSS; PopCatchFrame(); LLL;
648 xPopUpdateFrame(obj);
651 SSS; PopStopFrame(obj); LLL;
652 RETURN(ThreadFinished);
654 SSS; PopSeqFrame(); LLL;
655 ASSERT(xSp != (P_)xSu);
656 /* Hit a SEQ frame during an arg satisfaction check.
657 * So now return to bco_info which is under the
658 * SEQ frame. The following code is copied from a
659 * case RET_BCO further down. (The reason why we're
660 * here is that something of functional type has
661 * been seq-d on, and we're now returning to the
662 * algebraic-case-continuation which forced the
663 * evaluation in the first place.)
675 barf("Invalid update frame during argcheck");
677 } while (xSp==(P_)xSu);
685 int words = BCO_INSTR_8;
686 SSS; p = grabHpUpd(AP_sizeW(words)); LLL;
690 Case(i_ALLOC_CONSTR):
693 StgInfoTable* info = bcoConstAddr(bco,BCO_INSTR_8);
694 SSS; p = grabHpNonUpd(sizeW_fromITBL(info)); LLL;
695 SET_HDR((StgClosure*)p,info,??);
701 int x = BCO_INSTR_8; /* ToDo: Word not Int! */
703 StgAP_UPD* o = stgCast(StgAP_UPD*,xStackPtr(x));
704 SET_HDR(o,&AP_UPD_info,??);
706 o->fun = stgCast(StgClosure*,xPopPtr());
707 for(x=0; x < y; ++x) {
708 payloadWord(o,x) = xPopWord();
711 fprintf(stderr,"\tBuilt ");
713 printObj(stgCast(StgClosure*,o));
724 o = stgCast(StgAP_UPD*,xStackPtr(x));
725 SET_HDR(o,&AP_UPD_info,??);
727 o->fun = stgCast(StgClosure*,xPopPtr());
728 for(x=0; x < y; ++x) {
729 payloadWord(o,x) = xPopWord();
732 fprintf(stderr,"\tBuilt ");
734 printObj(stgCast(StgClosure*,o));
743 StgPAP* o = stgCast(StgPAP*,xStackPtr(x));
744 SET_HDR(o,&PAP_info,??);
746 o->fun = stgCast(StgClosure*,xPopPtr());
747 for(x=0; x < y; ++x) {
748 payloadWord(o,x) = xPopWord();
751 fprintf(stderr,"\tBuilt ");
753 printObj(stgCast(StgClosure*,o));
760 int offset = BCO_INSTR_8;
761 StgClosure* o = stgCast(StgClosure*,xStackPtr(offset));
762 const StgInfoTable* info = get_itbl(o);
763 nat p = info->layout.payload.ptrs;
764 nat np = info->layout.payload.nptrs;
766 for(i=0; i < p; ++i) {
767 payloadCPtr(o,i) = xPopCPtr();
769 for(i=0; i < np; ++i) {
770 payloadWord(o,p+i) = 0xdeadbeef;
773 fprintf(stderr,"\tBuilt ");
775 printObj(stgCast(StgClosure*,o));
782 int offset = BCO_INSTR_16;
783 StgClosure* o = stgCast(StgClosure*,xStackPtr(offset));
784 const StgInfoTable* info = get_itbl(o);
785 nat p = info->layout.payload.ptrs;
786 nat np = info->layout.payload.nptrs;
788 for(i=0; i < p; ++i) {
789 payloadCPtr(o,i) = xPopCPtr();
791 for(i=0; i < np; ++i) {
792 payloadWord(o,p+i) = 0xdeadbeef;
795 fprintf(stderr,"\tBuilt ");
797 printObj(stgCast(StgClosure*,o));
806 ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
807 /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
809 xSetStackWord(x+y,xStackWord(x));
819 ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
820 /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
822 xSetStackWord(x+y,xStackWord(x));
834 xPushPtr(bcoConstPtr(bco,BCO_INSTR_8));
835 xPushPtr(stgCast(StgPtr,&ret_bco_info));
840 int tag = BCO_INSTR_8;
841 StgWord offset = BCO_INSTR_16;
842 if (constrTag(stgCast(StgClosure*,xStackPtr(0))) != tag) {
849 StgClosure* o = stgCast(StgClosure*,xStackPtr(0));
850 const StgInfoTable* itbl = get_itbl(o);
851 int i = itbl->layout.payload.ptrs;
852 ASSERT( itbl->type == CONSTR
853 || itbl->type == CONSTR_STATIC
854 || itbl->type == CONSTR_NOCAF_STATIC
855 || itbl->type == CONSTR_1_0
856 || itbl->type == CONSTR_0_1
857 || itbl->type == CONSTR_2_0
858 || itbl->type == CONSTR_1_1
859 || itbl->type == CONSTR_0_2
862 xPushCPtr(payloadCPtr(o,i));
868 int n = BCO_INSTR_16;
869 StgPtr p = xStackPtr(n);
875 StgPtr p = xStackPtr(BCO_INSTR_8);
881 xPushPtr(stgCast(StgPtr,bcoConstPtr(bco,BCO_INSTR_8)));
886 int n = BCO_INSTR_16;
887 xPushPtr(stgCast(StgPtr,bcoConstPtr(bco,n)));
892 SSS; PushTaggedRealWorld(); LLL;
897 StgInt i = xTaggedStackInt(BCO_INSTR_8);
903 xPushTaggedInt(bcoConstInt(bco,BCO_INSTR_8));
909 SSS; o = (StgClosure*)grabHpNonUpd(Izh_sizeW); LLL;
910 SET_HDR(o,&Izh_con_info,??);
911 payloadWord(o,0) = xPopTaggedInt();
913 fprintf(stderr,"\tBuilt ");
915 printObj(stgCast(StgClosure*,o));
918 xPushPtr(stgCast(StgPtr,o));
923 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
924 /* ASSERT(isIntLike(con)); */
925 xPushTaggedInt(payloadWord(con,0));
930 StgWord offset = BCO_INSTR_16;
931 StgInt x = xPopTaggedInt();
932 StgInt y = xPopTaggedInt();
938 Case(i_CONST_INTEGER):
942 char* s = bcoConstAddr(bco,BCO_INSTR_8);
945 p = CreateByteArrayToHoldInteger(n);
946 do_fromStr ( s, n, IntegerInsideByteArray(p));
947 SloppifyIntegerEnd(p);
954 StgWord w = xTaggedStackWord(BCO_INSTR_8);
960 xPushTaggedWord(bcoConstWord(bco,BCO_INSTR_8));
966 SSS; o = (StgClosure*)grabHpNonUpd(Wzh_sizeW); LLL;
967 SET_HDR(o,&Wzh_con_info,??);
968 payloadWord(o,0) = xPopTaggedWord();
970 fprintf(stderr,"\tBuilt ");
972 printObj(stgCast(StgClosure*,o));
975 xPushPtr(stgCast(StgPtr,o));
980 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
981 /* ASSERT(isWordLike(con)); */
982 xPushTaggedWord(payloadWord(con,0));
987 StgAddr a = xTaggedStackAddr(BCO_INSTR_8);
993 xPushTaggedAddr(bcoConstAddr(bco,BCO_INSTR_8));
999 SSS; o = (StgClosure*)grabHpNonUpd(Azh_sizeW); LLL;
1000 SET_HDR(o,&Azh_con_info,??);
1001 payloadPtr(o,0) = xPopTaggedAddr();
1003 fprintf(stderr,"\tBuilt ");
1005 printObj(stgCast(StgClosure*,o));
1008 xPushPtr(stgCast(StgPtr,o));
1011 Case(i_UNPACK_ADDR):
1013 StgClosure* con = (StgClosure*)xStackPtr(0);
1014 /* ASSERT(isAddrLike(con)); */
1015 xPushTaggedAddr(payloadPtr(con,0));
1020 StgChar c = xTaggedStackChar(BCO_INSTR_8);
1026 xPushTaggedChar(bcoConstChar(bco,BCO_INSTR_8));
1032 SSS; o = (StgClosure*)grabHpNonUpd(Czh_sizeW); LLL;
1033 SET_HDR(o,&Czh_con_info,??);
1034 payloadWord(o,0) = xPopTaggedChar();
1035 xPushPtr(stgCast(StgPtr,o));
1037 fprintf(stderr,"\tBuilt ");
1039 printObj(stgCast(StgClosure*,o));
1044 Case(i_UNPACK_CHAR):
1046 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1047 /* ASSERT(isCharLike(con)); */
1048 xPushTaggedChar(payloadWord(con,0));
1053 StgFloat f = xTaggedStackFloat(BCO_INSTR_8);
1054 xPushTaggedFloat(f);
1057 Case(i_CONST_FLOAT):
1059 xPushTaggedFloat(bcoConstFloat(bco,BCO_INSTR_8));
1065 SSS; o = (StgClosure*)grabHpNonUpd(Fzh_sizeW); LLL;
1066 SET_HDR(o,&Fzh_con_info,??);
1067 ASSIGN_FLT(&payloadWord(o,0),xPopTaggedFloat());
1069 fprintf(stderr,"\tBuilt ");
1071 printObj(stgCast(StgClosure*,o));
1074 xPushPtr(stgCast(StgPtr,o));
1077 Case(i_UNPACK_FLOAT):
1079 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1080 /* ASSERT(isFloatLike(con)); */
1081 xPushTaggedFloat(PK_FLT(&payloadWord(con,0)));
1086 StgDouble d = xTaggedStackDouble(BCO_INSTR_8);
1087 xPushTaggedDouble(d);
1090 Case(i_CONST_DOUBLE):
1092 xPushTaggedDouble(bcoConstDouble(bco,BCO_INSTR_8));
1095 Case(i_CONST_DOUBLE_big):
1097 int n = BCO_INSTR_16;
1098 xPushTaggedDouble(bcoConstDouble(bco,n));
1101 Case(i_PACK_DOUBLE):
1104 SSS; o = (StgClosure*)grabHpNonUpd(Dzh_sizeW); LLL;
1105 SET_HDR(o,&Dzh_con_info,??);
1106 ASSIGN_DBL(&payloadWord(o,0),xPopTaggedDouble());
1108 fprintf(stderr,"\tBuilt ");
1109 printObj(stgCast(StgClosure*,o));
1111 xPushPtr(stgCast(StgPtr,o));
1114 Case(i_UNPACK_DOUBLE):
1116 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1117 /* ASSERT(isDoubleLike(con)); */
1118 xPushTaggedDouble(PK_DBL(&payloadWord(con,0)));
1123 StgStablePtr s = xTaggedStackStable(BCO_INSTR_8);
1124 xPushTaggedStable(s);
1127 Case(i_PACK_STABLE):
1130 SSS; o = (StgClosure*)grabHpNonUpd(Stablezh_sizeW); LLL;
1131 SET_HDR(o,&StablePtr_con_info,??);
1132 payloadWord(o,0) = xPopTaggedStable();
1134 fprintf(stderr,"\tBuilt ");
1136 printObj(stgCast(StgClosure*,o));
1139 xPushPtr(stgCast(StgPtr,o));
1142 Case(i_UNPACK_STABLE):
1144 StgClosure* con = (StgClosure*)xStackPtr(0);
1145 /* ASSERT(isStableLike(con)); */
1146 xPushTaggedStable(payloadWord(con,0));
1154 SSS; p = enterBCO_primop1 ( i ); LLL;
1155 if (p) { obj = p; goto enterLoop; };
1160 /* Remember to save */
1161 int i, trc, pc_saved;
1164 trc = 12345678; /* Assume != any StgThreadReturnCode */
1169 p = enterBCO_primop2 ( i, &trc, &bco_tmp, cap );
1172 bciPtr = &(bcoInstr(bco,pc_saved));
1174 if (trc == 12345678) {
1175 /* we want to enter p */
1176 obj = p; goto enterLoop;
1178 /* p is the the StgThreadReturnCode for this thread */
1179 RETURN((StgThreadReturnCode)p);
1185 /* combined insns, created by peephole opt */
1188 int x = BCO_INSTR_8;
1189 int y = BCO_INSTR_8;
1190 ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
1191 /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
1198 xSetStackWord(x+y,xStackWord(x));
1208 p = xStackPtr(BCO_INSTR_8);
1210 p = xStackPtr(BCO_INSTR_8);
1217 xPushPtr(bcoConstPtr(bco,BCO_INSTR_8));
1218 xPushPtr(stgCast(StgPtr,&ret_bco_info));
1219 p = xStackPtr(BCO_INSTR_8);
1225 StgPtr retaddr = bcoConstPtr(bco,BCO_INSTR_8);
1226 StgPtr ptr = xStackPtr(BCO_INSTR_8);
1228 /* A shortcut. We're going to push the address of a
1229 return continuation, and then enter a variable, so
1230 that when the var is evaluated, we return to the
1231 continuation. The shortcut is: if the var is a
1232 constructor, don't bother to enter it. Instead,
1233 push the variable on the stack (since this is what
1234 the continuation expects) and jump directly to the
1237 if (get_itbl((StgClosure*)ptr)->type == CONSTR) {
1239 obj = (StgClosure*)retaddr;
1241 fprintf(stderr, "object to enter is a constructor -- "
1242 "jumping directly to return continuation\n" );
1247 /* This is the normal, non-short-cut route */
1249 xPushPtr(stgCast(StgPtr,&ret_bco_info));
1250 obj = (StgClosure*)ptr;
1255 Case(i_VAR_DOUBLE_big):
1256 Case(i_CONST_FLOAT_big):
1257 Case(i_VAR_FLOAT_big):
1258 Case(i_CONST_CHAR_big):
1259 Case(i_VAR_CHAR_big):
1260 Case(i_CONST_ADDR_big):
1261 Case(i_VAR_ADDR_big):
1262 Case(i_VAR_STABLE_big):
1263 Case(i_CONST_INTEGER_big):
1264 Case(i_CONST_INT_big):
1265 Case(i_VAR_INT_big):
1266 Case(i_VAR_WORD_big):
1267 Case(i_RETADDR_big):
1271 disInstr ( bco, PC );
1272 barf("\nUnrecognised instruction");
1276 barf("enterBCO: ran off end of loop");
1280 # undef LoopTopLabel
1286 /* ---------------------------------------------------- */
1287 /* End of the bytecode evaluator */
1288 /* ---------------------------------------------------- */
1292 StgBlockingQueue* bh;
1293 StgCAF* caf = (StgCAF*)obj;
1294 if (xSp - sizeofW(StgUpdateFrame) < xSpLim) {
1295 xPushCPtr(obj); /* code to restart with */
1296 RETURN(StackOverflow);
1298 /* ToDo: look for xSp==xSu && stackInt(0) == UPD_FRAME
1299 and insert an indirection immediately */
1300 SSS; bh = (StgBlockingQueue*)grabHpUpd(BLACKHOLE_sizeW()); LLL;
1301 SET_INFO(bh,&CAF_BLACKHOLE_info);
1302 bh->blocking_queue = EndTSOQueue;
1304 fprintf(stderr,"Created CAF_BLACKHOLE %p for CAF %p in evaluator\n",bh,caf));
1305 SET_INFO(caf,&CAF_ENTERED_info);
1306 caf->value = (StgClosure*)bh;
1307 if (caf->mut_link == NULL) {
1308 SSS; recordOldToNewPtrs((StgMutClosure*)caf); LLL;
1310 xPushUpdateFrame(bh,0);
1311 xSp -= sizeofW(StgUpdateFrame);
1312 caf->link = enteredCAFs;
1319 StgCAF* caf = (StgCAF*)obj;
1320 obj = caf->value; /* it's just a fancy indirection */
1326 case SE_CAF_BLACKHOLE:
1328 /*was StgBlackHole* */
1329 StgBlockingQueue* bh = (StgBlockingQueue*)obj;
1330 /* Put ourselves on the blocking queue for this black hole and block */
1331 cap->rCurrentTSO->link = bh->blocking_queue;
1332 bh->blocking_queue = cap->rCurrentTSO;
1333 xPushCPtr(obj); /* code to restart with */
1334 barf("enter: CAF_BLACKHOLE unexpected!");
1335 RETURN(ThreadBlocked);
1339 StgAP_UPD* ap = stgCast(StgAP_UPD*,obj);
1341 if (xSp - (i + sizeofW(StgUpdateFrame)) < xSpLim) {
1342 xPushCPtr(obj); /* code to restart with */
1343 RETURN(StackOverflow);
1345 /* ToDo: look for xSp==xSu && stackInt(0) == UPD_FRAME
1346 and insert an indirection immediately */
1347 xPushUpdateFrame(ap,0);
1348 xSp -= sizeofW(StgUpdateFrame);
1350 xPushWord(payloadWord(ap,i));
1353 #ifdef EAGER_BLACKHOLING
1354 #warn LAZY_BLACKHOLING is default for StgHugs
1355 #error Dont know if EAGER_BLACKHOLING works in StgHugs
1357 /* superfluous - but makes debugging easier */
1358 StgBlackHole* bh = stgCast(StgBlackHole*,ap);
1359 SET_INFO(bh,&BLACKHOLE_info);
1360 bh->blocking_queue = EndTSOQueue;
1362 fprintf(stderr,"Eagerly blackholed AP_UPD %p in evaluator\n",bh));
1365 #endif /* EAGER_BLACKHOLING */
1370 StgPAP* pap = stgCast(StgPAP*,obj);
1371 int i = pap->n_args; /* ToDo: stack check */
1372 /* ToDo: if PAP is in whnf, we can update any update frames
1376 xPushWord(payloadWord(pap,i));
1383 obj = stgCast(StgInd*,obj)->indirectee;
1388 obj = stgCast(StgIndOldGen*,obj)->indirectee;
1397 case CONSTR_INTLIKE:
1398 case CONSTR_CHARLIKE:
1400 case CONSTR_NOCAF_STATIC:
1403 switch (get_itbl(stgCast(StgClosure*,xSp))->type) {
1405 SSS; PopCatchFrame(); LLL;
1408 xPopUpdateFrame(obj);
1411 SSS; PopSeqFrame(); LLL;
1415 ASSERT(xSp==(P_)xSu);
1418 fprintf(stderr, "hit a STOP_FRAME\n");
1420 fprintf(stderr,"xSp = %p\txSu = %p\n", xSp, xSu);
1421 printStack(xSp,cap->rCurrentTSO->stack
1422 + cap->rCurrentTSO->stack_size,xSu);
1425 SSS; PopStopFrame(obj); LLL;
1426 RETURN(ThreadFinished);
1436 /* was: goto enterLoop;
1437 But we know that obj must be a bco now, so jump directly.
1440 case RET_SMALL: /* return to GHC */
1444 // barf("todo: RET_[VEC_]{BIG,SMALL}");
1446 belch("entered CONSTR with invalid continuation on stack");
1449 printObj(stgCast(StgClosure*,xSp));
1452 barf("bailing out");
1459 //fprintf(stderr, "enterCountI = %d\n", enterCountI);
1460 //fprintf(stderr, "entering unknown closure -- yielding to sched\n");
1463 cap->rCurrentTSO->whatNext = ThreadEnterGHC;
1464 xPushCPtr(obj); /* code to restart with */
1465 RETURN(ThreadYielding);
1468 barf("Ran off the end of enter - yoiks");
1485 #undef xSetStackWord
1488 #undef xPushTaggedInt
1489 #undef xPopTaggedInt
1490 #undef xTaggedStackInt
1491 #undef xPushTaggedWord
1492 #undef xPopTaggedWord
1493 #undef xTaggedStackWord
1494 #undef xPushTaggedAddr
1495 #undef xTaggedStackAddr
1496 #undef xPopTaggedAddr
1497 #undef xPushTaggedStable
1498 #undef xTaggedStackStable
1499 #undef xPopTaggedStable
1500 #undef xPushTaggedChar
1501 #undef xTaggedStackChar
1502 #undef xPopTaggedChar
1503 #undef xPushTaggedFloat
1504 #undef xTaggedStackFloat
1505 #undef xPopTaggedFloat
1506 #undef xPushTaggedDouble
1507 #undef xTaggedStackDouble
1508 #undef xPopTaggedDouble
1509 #undef xPopUpdateFrame
1510 #undef xPushUpdateFrame
1513 /* --------------------------------------------------------------------------
1514 * Supporting routines for primops
1515 * ------------------------------------------------------------------------*/
1517 static inline void PushTag ( StackTag t )
1519 inline void PushPtr ( StgPtr x )
1520 { *(--stgCast(StgPtr*,gSp)) = x; }
1521 static inline void PushCPtr ( StgClosure* x )
1522 { *(--stgCast(StgClosure**,gSp)) = x; }
1523 static inline void PushInt ( StgInt x )
1524 { *(--stgCast(StgInt*,gSp)) = x; }
1525 static inline void PushWord ( StgWord x )
1526 { *(--stgCast(StgWord*,gSp)) = x; }
1529 static inline void checkTag ( StackTag t1, StackTag t2 )
1530 { ASSERT(t1 == t2);}
1531 static inline void PopTag ( StackTag t )
1532 { checkTag(t,*(gSp++)); }
1533 inline StgPtr PopPtr ( void )
1534 { return *stgCast(StgPtr*,gSp)++; }
1535 static inline StgClosure* PopCPtr ( void )
1536 { return *stgCast(StgClosure**,gSp)++; }
1537 static inline StgInt PopInt ( void )
1538 { return *stgCast(StgInt*,gSp)++; }
1539 static inline StgWord PopWord ( void )
1540 { return *stgCast(StgWord*,gSp)++; }
1542 static inline StgPtr stackPtr ( StgStackOffset i )
1543 { return *stgCast(StgPtr*, gSp+i); }
1544 static inline StgInt stackInt ( StgStackOffset i )
1545 { return *stgCast(StgInt*, gSp+i); }
1546 static inline StgWord stackWord ( StgStackOffset i )
1547 { return *stgCast(StgWord*,gSp+i); }
1549 static inline void setStackWord ( StgStackOffset i, StgWord w )
1552 static inline void PushTaggedRealWorld( void )
1553 { PushTag(REALWORLD_TAG); }
1554 inline void PushTaggedInt ( StgInt x )
1555 { gSp -= sizeofW(StgInt); *gSp = x; PushTag(INT_TAG); }
1556 inline void PushTaggedWord ( StgWord x )
1557 { gSp -= sizeofW(StgWord); *gSp = x; PushTag(WORD_TAG); }
1558 inline void PushTaggedAddr ( StgAddr x )
1559 { gSp -= sizeofW(StgAddr); *gSp = (W_)x; PushTag(ADDR_TAG); }
1560 inline void PushTaggedChar ( StgChar x )
1561 { gSp -= sizeofW(StgChar); *gSp = stgCast(StgWord,x); PushTag(CHAR_TAG); }
1562 inline void PushTaggedFloat ( StgFloat x )
1563 { gSp -= sizeofW(StgFloat); ASSIGN_FLT(gSp,x); PushTag(FLOAT_TAG); }
1564 inline void PushTaggedDouble ( StgDouble x )
1565 { gSp -= sizeofW(StgDouble); ASSIGN_DBL(gSp,x); PushTag(DOUBLE_TAG); }
1566 inline void PushTaggedStablePtr ( StgStablePtr x )
1567 { gSp -= sizeofW(StgStablePtr); *gSp = x; PushTag(STABLE_TAG); }
1568 static inline void PushTaggedBool ( int x )
1569 { PushTaggedInt(x); }
1573 static inline void PopTaggedRealWorld ( void )
1574 { PopTag(REALWORLD_TAG); }
1575 inline StgInt PopTaggedInt ( void )
1576 { StgInt r; PopTag(INT_TAG); r = *stgCast(StgInt*, gSp);
1577 gSp += sizeofW(StgInt); return r;}
1578 inline StgWord PopTaggedWord ( void )
1579 { StgWord r; PopTag(WORD_TAG); r = *stgCast(StgWord*, gSp);
1580 gSp += sizeofW(StgWord); return r;}
1581 inline StgAddr PopTaggedAddr ( void )
1582 { StgAddr r; PopTag(ADDR_TAG); r = *stgCast(StgAddr*, gSp);
1583 gSp += sizeofW(StgAddr); return r;}
1584 inline StgChar PopTaggedChar ( void )
1585 { StgChar r; PopTag(CHAR_TAG); r = stgCast(StgChar, *gSp);
1586 gSp += sizeofW(StgChar); return r;}
1587 inline StgFloat PopTaggedFloat ( void )
1588 { StgFloat r; PopTag(FLOAT_TAG); r = PK_FLT(gSp);
1589 gSp += sizeofW(StgFloat); return r;}
1590 inline StgDouble PopTaggedDouble ( void )
1591 { StgDouble r; PopTag(DOUBLE_TAG); r = PK_DBL(gSp);
1592 gSp += sizeofW(StgDouble); return r;}
1593 inline StgStablePtr PopTaggedStablePtr ( void )
1594 { StgInt r; PopTag(STABLE_TAG); r = *stgCast(StgStablePtr*, gSp);
1595 gSp += sizeofW(StgStablePtr); return r;}
1599 static inline StgInt taggedStackInt ( StgStackOffset i )
1600 { checkTag(INT_TAG,gSp[i]); return *stgCast(StgInt*, gSp+1+i); }
1601 static inline StgWord taggedStackWord ( StgStackOffset i )
1602 { checkTag(WORD_TAG,gSp[i]); return *stgCast(StgWord*, gSp+1+i); }
1603 static inline StgAddr taggedStackAddr ( StgStackOffset i )
1604 { checkTag(ADDR_TAG,gSp[i]); return *stgCast(StgAddr*, gSp+1+i); }
1605 static inline StgChar taggedStackChar ( StgStackOffset i )
1606 { checkTag(CHAR_TAG,gSp[i]); return stgCast(StgChar, *(gSp+1+i)) ; }
1607 static inline StgFloat taggedStackFloat ( StgStackOffset i )
1608 { checkTag(FLOAT_TAG,gSp[i]); return PK_FLT(gSp+1+i); }
1609 static inline StgDouble taggedStackDouble ( StgStackOffset i )
1610 { checkTag(DOUBLE_TAG,gSp[i]); return PK_DBL(gSp+1+i); }
1611 static inline StgStablePtr taggedStackStable ( StgStackOffset i )
1612 { checkTag(STABLE_TAG,gSp[i]); return *stgCast(StgStablePtr*, gSp+1+i); }
1615 /* --------------------------------------------------------------------------
1618 * Should we allocate from a nursery or use the
1619 * doYouWantToGC/allocate interface? We'd already implemented a
1620 * nursery-style scheme when the doYouWantToGC/allocate interface
1622 * One reason to prefer the doYouWantToGC/allocate interface is to
1623 * support operations which allocate an unknown amount in the heap
1624 * (array ops, gmp ops, etc)
1625 * ------------------------------------------------------------------------*/
1627 static inline StgPtr grabHpUpd( nat size )
1629 ASSERT( size >= MIN_UPD_SIZE + sizeofW(StgHeader) );
1630 #ifdef CRUDE_PROFILING
1631 cp_bill_words ( size );
1633 return allocate(size);
1636 static inline StgPtr grabHpNonUpd( nat size )
1638 ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
1639 #ifdef CRUDE_PROFILING
1640 cp_bill_words ( size );
1642 return allocate(size);
1645 /* --------------------------------------------------------------------------
1646 * Manipulate "update frame" list:
1647 * o Update frames (based on stg_do_update and friends in Updates.hc)
1648 * o Error handling/catching (based on catchzh_fast and friends in Prims.hc)
1649 * o Seq frames (based on seq_frame_entry in Prims.hc)
1651 * ------------------------------------------------------------------------*/
1653 static inline void PopUpdateFrame ( StgClosure* obj )
1655 /* NB: doesn't assume that gSp == gSu */
1657 fprintf(stderr, "Updating ");
1658 printPtr(stgCast(StgPtr,gSu->updatee));
1659 fprintf(stderr, " with ");
1661 fprintf(stderr,"gSp = %p\tgSu = %p\n\n", gSp, gSu);
1663 #ifdef EAGER_BLACKHOLING
1664 #warn LAZY_BLACKHOLING is default for StgHugs
1665 #error Dont know if EAGER_BLACKHOLING works in StgHugs
1666 ASSERT(get_itbl(gSu->updatee)->type == BLACKHOLE
1667 || get_itbl(gSu->updatee)->type == SE_BLACKHOLE
1668 || get_itbl(gSu->updatee)->type == CAF_BLACKHOLE
1669 || get_itbl(gSu->updatee)->type == SE_CAF_BLACKHOLE
1671 #endif /* EAGER_BLACKHOLING */
1672 UPD_IND(gSu->updatee,obj);
1673 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgUpdateFrame);
1677 static inline void PopStopFrame ( StgClosure* obj )
1679 /* Move gSu just off the end of the stack, we're about to gSpam the
1680 * STOP_FRAME with the return value.
1682 gSu = stgCast(StgUpdateFrame*,gSp+1);
1683 *stgCast(StgClosure**,gSp) = obj;
1686 static inline void PushCatchFrame ( StgClosure* handler )
1689 /* ToDo: stack check! */
1690 gSp -= sizeofW(StgCatchFrame);
1691 fp = stgCast(StgCatchFrame*,gSp);
1692 SET_HDR(fp,(StgInfoTable*)&catch_frame_info,CCCS);
1693 fp->handler = handler;
1695 gSu = stgCast(StgUpdateFrame*,fp);
1698 static inline void PopCatchFrame ( void )
1700 /* NB: doesn't assume that gSp == gSu */
1701 /* fprintf(stderr,"Popping catch frame\n"); */
1702 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgCatchFrame);
1703 gSu = stgCast(StgCatchFrame*,gSu)->link;
1706 static inline void PushSeqFrame ( void )
1709 /* ToDo: stack check! */
1710 gSp -= sizeofW(StgSeqFrame);
1711 fp = stgCast(StgSeqFrame*,gSp);
1712 SET_HDR(fp,(StgInfoTable*)&seq_frame_info,CCCS);
1714 gSu = stgCast(StgUpdateFrame*,fp);
1717 static inline void PopSeqFrame ( void )
1719 /* NB: doesn't assume that gSp == gSu */
1720 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgSeqFrame);
1721 gSu = stgCast(StgSeqFrame*,gSu)->link;
1724 static inline StgClosure* raiseAnError ( StgClosure* errObj )
1726 StgClosure *raise_closure;
1728 /* This closure represents the expression 'raise# E' where E
1729 * is the exception raised. It is used to overwrite all the
1730 * thunks which are currently under evaluation.
1732 raise_closure = (StgClosure *)allocate(sizeofW(StgClosure)+1);
1733 raise_closure->header.info = &raise_info;
1734 raise_closure->payload[0] = 0xdeadbeef; /*R1.cl;*/
1737 switch (get_itbl(gSu)->type) {
1739 UPD_IND(gSu->updatee,raise_closure);
1740 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgUpdateFrame);
1746 case CATCH_FRAME: /* found it! */
1748 StgCatchFrame* fp = stgCast(StgCatchFrame*,gSu);
1749 StgClosure *handler = fp->handler;
1751 gSp += sizeofW(StgCatchFrame); /* Pop */
1756 barf("raiseError: uncaught exception: STOP_FRAME");
1758 barf("raiseError: weird activation record");
1764 static StgClosure* makeErrorCall ( const char* msg )
1766 /* Note! the msg string should be allocated in a
1767 place which will not get freed -- preferably
1768 read-only data of the program. That's because
1769 the thunk we build here may linger indefinitely.
1770 (thinks: probably not so, but anyway ...)
1773 = asmClosureOfObject(getHugs_AsmObject_for("error"));
1775 = asmClosureOfObject(getHugs_AsmObject_for("primUnpackString"));
1777 = rts_apply ( unpack, rts_mkAddr ( (void*)msg ) );
1779 = rts_apply ( error, thunk );
1781 (StgClosure*) thunk;
1784 #define raiseIndex(where) makeErrorCall("Array index out of range in " where)
1785 #define raiseDiv0(where) makeErrorCall("Division by zero in " where)
1787 /* --------------------------------------------------------------------------
1789 * ------------------------------------------------------------------------*/
1791 #define OP_CC_B(e) \
1793 unsigned char x = PopTaggedChar(); \
1794 unsigned char y = PopTaggedChar(); \
1795 PushTaggedBool(e); \
1800 unsigned char x = PopTaggedChar(); \
1809 #define OP_IW_I(e) \
1811 StgInt x = PopTaggedInt(); \
1812 StgWord y = PopTaggedWord(); \
1816 #define OP_II_I(e) \
1818 StgInt x = PopTaggedInt(); \
1819 StgInt y = PopTaggedInt(); \
1823 #define OP_II_B(e) \
1825 StgInt x = PopTaggedInt(); \
1826 StgInt y = PopTaggedInt(); \
1827 PushTaggedBool(e); \
1832 PushTaggedAddr(e); \
1837 StgInt x = PopTaggedInt(); \
1838 PushTaggedAddr(e); \
1843 StgInt x = PopTaggedInt(); \
1849 PushTaggedChar(e); \
1854 StgInt x = PopTaggedInt(); \
1855 PushTaggedChar(e); \
1860 PushTaggedWord(e); \
1865 StgInt x = PopTaggedInt(); \
1866 PushTaggedWord(e); \
1871 StgInt x = PopTaggedInt(); \
1872 PushTaggedStablePtr(e); \
1877 PushTaggedFloat(e); \
1882 StgInt x = PopTaggedInt(); \
1883 PushTaggedFloat(e); \
1888 PushTaggedDouble(e); \
1893 StgInt x = PopTaggedInt(); \
1894 PushTaggedDouble(e); \
1897 #define OP_WW_B(e) \
1899 StgWord x = PopTaggedWord(); \
1900 StgWord y = PopTaggedWord(); \
1901 PushTaggedBool(e); \
1904 #define OP_WW_W(e) \
1906 StgWord x = PopTaggedWord(); \
1907 StgWord y = PopTaggedWord(); \
1908 PushTaggedWord(e); \
1913 StgWord x = PopTaggedWord(); \
1919 StgStablePtr x = PopTaggedStablePtr(); \
1925 StgWord x = PopTaggedWord(); \
1926 PushTaggedWord(e); \
1929 #define OP_AA_B(e) \
1931 StgAddr x = PopTaggedAddr(); \
1932 StgAddr y = PopTaggedAddr(); \
1933 PushTaggedBool(e); \
1937 StgAddr x = PopTaggedAddr(); \
1940 #define OP_AI_C(s) \
1942 StgAddr x = PopTaggedAddr(); \
1943 int y = PopTaggedInt(); \
1946 PushTaggedChar(r); \
1948 #define OP_AI_I(s) \
1950 StgAddr x = PopTaggedAddr(); \
1951 int y = PopTaggedInt(); \
1956 #define OP_AI_A(s) \
1958 StgAddr x = PopTaggedAddr(); \
1959 int y = PopTaggedInt(); \
1962 PushTaggedAddr(s); \
1964 #define OP_AI_F(s) \
1966 StgAddr x = PopTaggedAddr(); \
1967 int y = PopTaggedInt(); \
1970 PushTaggedFloat(r); \
1972 #define OP_AI_D(s) \
1974 StgAddr x = PopTaggedAddr(); \
1975 int y = PopTaggedInt(); \
1978 PushTaggedDouble(r); \
1980 #define OP_AI_s(s) \
1982 StgAddr x = PopTaggedAddr(); \
1983 int y = PopTaggedInt(); \
1986 PushTaggedStablePtr(r); \
1988 #define OP_AIC_(s) \
1990 StgAddr x = PopTaggedAddr(); \
1991 int y = PopTaggedInt(); \
1992 StgChar z = PopTaggedChar(); \
1995 #define OP_AII_(s) \
1997 StgAddr x = PopTaggedAddr(); \
1998 int y = PopTaggedInt(); \
1999 StgInt z = PopTaggedInt(); \
2002 #define OP_AIA_(s) \
2004 StgAddr x = PopTaggedAddr(); \
2005 int y = PopTaggedInt(); \
2006 StgAddr z = PopTaggedAddr(); \
2009 #define OP_AIF_(s) \
2011 StgAddr x = PopTaggedAddr(); \
2012 int y = PopTaggedInt(); \
2013 StgFloat z = PopTaggedFloat(); \
2016 #define OP_AID_(s) \
2018 StgAddr x = PopTaggedAddr(); \
2019 int y = PopTaggedInt(); \
2020 StgDouble z = PopTaggedDouble(); \
2023 #define OP_AIs_(s) \
2025 StgAddr x = PopTaggedAddr(); \
2026 int y = PopTaggedInt(); \
2027 StgStablePtr z = PopTaggedStablePtr(); \
2032 #define OP_FF_B(e) \
2034 StgFloat x = PopTaggedFloat(); \
2035 StgFloat y = PopTaggedFloat(); \
2036 PushTaggedBool(e); \
2039 #define OP_FF_F(e) \
2041 StgFloat x = PopTaggedFloat(); \
2042 StgFloat y = PopTaggedFloat(); \
2043 PushTaggedFloat(e); \
2048 StgFloat x = PopTaggedFloat(); \
2049 PushTaggedFloat(e); \
2054 StgFloat x = PopTaggedFloat(); \
2055 PushTaggedBool(e); \
2060 StgFloat x = PopTaggedFloat(); \
2066 StgFloat x = PopTaggedFloat(); \
2067 PushTaggedDouble(e); \
2070 #define OP_DD_B(e) \
2072 StgDouble x = PopTaggedDouble(); \
2073 StgDouble y = PopTaggedDouble(); \
2074 PushTaggedBool(e); \
2077 #define OP_DD_D(e) \
2079 StgDouble x = PopTaggedDouble(); \
2080 StgDouble y = PopTaggedDouble(); \
2081 PushTaggedDouble(e); \
2086 StgDouble x = PopTaggedDouble(); \
2087 PushTaggedBool(e); \
2092 StgDouble x = PopTaggedDouble(); \
2093 PushTaggedDouble(e); \
2098 StgDouble x = PopTaggedDouble(); \
2104 StgDouble x = PopTaggedDouble(); \
2105 PushTaggedFloat(e); \
2109 #ifdef STANDALONE_INTEGER
2110 StgPtr CreateByteArrayToHoldInteger ( int nbytes )
2112 StgInt words = (nbytes+sizeof(W_)-1)/sizeof(W_);
2113 StgWord size = sizeofW(StgArrWords) + words;
2114 StgArrWords* arr = (StgArrWords*)allocate(size);
2115 SET_HDR(arr,&ARR_WORDS_info,CCCS);
2117 ASSERT(nbytes <= arr->words * sizeof(W_));
2120 for (i = 0; i < words; ++i) {
2121 arr->payload[i] = 0xdeadbeef;
2123 { B* b = (B*) &(arr->payload[0]);
2124 b->used = b->sign = 0;
2130 B* IntegerInsideByteArray ( StgPtr arr0 )
2133 StgArrWords* arr = (StgArrWords*)arr0;
2134 ASSERT(GET_INFO(arr) == &ARR_WORDS_info);
2135 b = (B*) &(arr->payload[0]);
2139 void SloppifyIntegerEnd ( StgPtr arr0 )
2141 StgArrWords* arr = (StgArrWords*)arr0;
2142 B* b = (B*) & (arr->payload[0]);
2143 I_ nwunused = arr->words - sizeofW(B) - (b->used+sizeof(W_)-1)/sizeof(W_);
2144 if (nwunused >= ((I_)sizeofW(StgArrWords))) {
2146 b->size -= nwunused * sizeof(W_);
2147 if (b->size < b->used) b->size = b->used;
2150 arr->words -= nwunused;
2151 slop = (StgArrWords*)&(arr->payload[arr->words]);
2152 SET_HDR(slop,&ARR_WORDS_info,CCCS);
2153 slop->words = nwunused - sizeofW(StgArrWords);
2154 ASSERT( &(slop->payload[slop->words]) ==
2155 &(arr->payload[arr->words + nwunused]) );
2159 #define OP_Z_Z(op) \
2161 B* x = IntegerInsideByteArray(PopPtr()); \
2162 int n = mycat2(size_,op)(x); \
2163 StgPtr p = CreateByteArrayToHoldInteger(n); \
2164 mycat2(do_,op)(x,n,IntegerInsideByteArray(p)); \
2165 SloppifyIntegerEnd(p); \
2168 #define OP_ZZ_Z(op) \
2170 B* x = IntegerInsideByteArray(PopPtr()); \
2171 B* y = IntegerInsideByteArray(PopPtr()); \
2172 int n = mycat2(size_,op)(x,y); \
2173 StgPtr p = CreateByteArrayToHoldInteger(n); \
2174 mycat2(do_,op)(x,y,n,IntegerInsideByteArray(p)); \
2175 SloppifyIntegerEnd(p); \
2183 #define HEADER_mI(ty,where) \
2184 StgArrWords* x = stgCast(StgArrWords*,PopPtr()); \
2185 nat i = PopTaggedInt(); \
2186 if (i * sizeof(ty) + (sizeof(ty)) > sizeof(StgWord) * x->words) { \
2187 return (raiseIndex(where)); \
2189 #define OP_mI_ty(ty,where,s) \
2191 HEADER_mI(mycat2(Stg,ty),where) \
2192 { mycat2(Stg,ty) r; \
2194 mycat2(PushTagged,ty)(r); \
2197 #define OP_mIty_(ty,where,s) \
2199 HEADER_mI(mycat2(Stg,ty),where) \
2201 mycat2(Stg,ty) z = mycat2(PopTagged,ty)(); \
2207 void myStackCheck ( Capability* cap )
2209 /* fprintf(stderr, "myStackCheck\n"); */
2210 if (!(gSpLim <= gSp && gSp <= stgCast(StgPtr,gSu))) {
2211 fprintf(stderr, "myStackCheck: invalid initial gSp/gSu \n" );
2215 if (!(gSu >= cap->rCurrentTSO->stack
2216 && gSu <= cap->rCurrentTSO->stack
2217 + cap->rCurrentTSO->stack_size)) {
2218 fprintf ( stderr, "myStackCheck: gSu out of stack\n" );
2221 switch (get_itbl(stgCast(StgClosure*,gSu))->type) {
2223 gSu = (StgPtr) ((StgCatchFrame*)(gSu))->link;
2226 gSu = (StgPtr) ((StgUpdateFrame*)(gSu))->link;
2229 gSu = (StgPtr) ((StgSeqFrame*)(gSu))->link;
2234 fprintf(stderr, "myStackCheck: invalid activation record\n"); assert(0);
2241 /* --------------------------------------------------------------------------
2242 * Primop stuff for bytecode interpreter
2243 * ------------------------------------------------------------------------*/
2245 /* Returns & of the next thing to enter (if throwing an exception),
2246 or NULL in the normal case.
2248 static void* enterBCO_primop1 ( int primop1code )
2250 switch (primop1code) {
2251 case i_pushseqframe:
2253 StgClosure* c = PopCPtr();
2258 case i_pushcatchframe:
2260 StgClosure* e = PopCPtr();
2261 StgClosure* h = PopCPtr();
2267 case i_gtChar: OP_CC_B(x>y); break;
2268 case i_geChar: OP_CC_B(x>=y); break;
2269 case i_eqChar: OP_CC_B(x==y); break;
2270 case i_neChar: OP_CC_B(x!=y); break;
2271 case i_ltChar: OP_CC_B(x<y); break;
2272 case i_leChar: OP_CC_B(x<=y); break;
2273 case i_charToInt: OP_C_I(x); break;
2274 case i_intToChar: OP_I_C(x); break;
2276 case i_gtInt: OP_II_B(x>y); break;
2277 case i_geInt: OP_II_B(x>=y); break;
2278 case i_eqInt: OP_II_B(x==y); break;
2279 case i_neInt: OP_II_B(x!=y); break;
2280 case i_ltInt: OP_II_B(x<y); break;
2281 case i_leInt: OP_II_B(x<=y); break;
2282 case i_minInt: OP__I(INT_MIN); break;
2283 case i_maxInt: OP__I(INT_MAX); break;
2284 case i_plusInt: OP_II_I(x+y); break;
2285 case i_minusInt: OP_II_I(x-y); break;
2286 case i_timesInt: OP_II_I(x*y); break;
2289 int x = PopTaggedInt();
2290 int y = PopTaggedInt();
2292 return (raiseDiv0("quotInt"));
2294 /* ToDo: protect against minInt / -1 errors
2295 * (repeat for all other division primops) */
2301 int x = PopTaggedInt();
2302 int y = PopTaggedInt();
2304 return (raiseDiv0("remInt"));
2311 StgInt x = PopTaggedInt();
2312 StgInt y = PopTaggedInt();
2314 return (raiseDiv0("quotRemInt"));
2316 PushTaggedInt(x%y); /* last result */
2317 PushTaggedInt(x/y); /* first result */
2320 case i_negateInt: OP_I_I(-x); break;
2322 case i_andInt: OP_II_I(x&y); break;
2323 case i_orInt: OP_II_I(x|y); break;
2324 case i_xorInt: OP_II_I(x^y); break;
2325 case i_notInt: OP_I_I(~x); break;
2326 case i_shiftLInt: OP_II_I(x<<y); break;
2327 case i_shiftRAInt: OP_II_I(x>>y); break; /* ToDo */
2328 case i_shiftRLInt: OP_II_I(x>>y); break; /* ToDo */
2330 case i_gtWord: OP_WW_B(x>y); break;
2331 case i_geWord: OP_WW_B(x>=y); break;
2332 case i_eqWord: OP_WW_B(x==y); break;
2333 case i_neWord: OP_WW_B(x!=y); break;
2334 case i_ltWord: OP_WW_B(x<y); break;
2335 case i_leWord: OP_WW_B(x<=y); break;
2336 case i_minWord: OP__W(0); break;
2337 case i_maxWord: OP__W(UINT_MAX); break;
2338 case i_plusWord: OP_WW_W(x+y); break;
2339 case i_minusWord: OP_WW_W(x-y); break;
2340 case i_timesWord: OP_WW_W(x*y); break;
2343 StgWord x = PopTaggedWord();
2344 StgWord y = PopTaggedWord();
2346 return (raiseDiv0("quotWord"));
2348 PushTaggedWord(x/y);
2353 StgWord x = PopTaggedWord();
2354 StgWord y = PopTaggedWord();
2356 return (raiseDiv0("remWord"));
2358 PushTaggedWord(x%y);
2363 StgWord x = PopTaggedWord();
2364 StgWord y = PopTaggedWord();
2366 return (raiseDiv0("quotRemWord"));
2368 PushTaggedWord(x%y); /* last result */
2369 PushTaggedWord(x/y); /* first result */
2372 case i_negateWord: OP_W_W(-x); break;
2373 case i_andWord: OP_WW_W(x&y); break;
2374 case i_orWord: OP_WW_W(x|y); break;
2375 case i_xorWord: OP_WW_W(x^y); break;
2376 case i_notWord: OP_W_W(~x); break;
2377 case i_shiftLWord: OP_WW_W(x<<y); break;
2378 case i_shiftRAWord: OP_WW_W(x>>y); break; /* ToDo */
2379 case i_shiftRLWord: OP_WW_W(x>>y); break; /* ToDo */
2380 case i_intToWord: OP_I_W(x); break;
2381 case i_wordToInt: OP_W_I(x); break;
2383 case i_gtAddr: OP_AA_B(x>y); break;
2384 case i_geAddr: OP_AA_B(x>=y); break;
2385 case i_eqAddr: OP_AA_B(x==y); break;
2386 case i_neAddr: OP_AA_B(x!=y); break;
2387 case i_ltAddr: OP_AA_B(x<y); break;
2388 case i_leAddr: OP_AA_B(x<=y); break;
2389 case i_intToAddr: OP_I_A((StgAddr)x); break; /* ToDo */
2390 case i_addrToInt: OP_A_I((StgInt)x); break; /* ToDo */
2392 case i_intToStable: OP_I_s(x); break;
2393 case i_stableToInt: OP_s_I(x); break;
2395 case i_indexCharOffAddr: OP_AI_C(indexCharOffAddrzh(r,x,y)); break;
2396 case i_readCharOffAddr: OP_AI_C(indexCharOffAddrzh(r,x,y)); break;
2397 case i_writeCharOffAddr: OP_AIC_(writeCharOffAddrzh(x,y,z)); break;
2399 case i_indexIntOffAddr: OP_AI_I(indexIntOffAddrzh(r,x,y)); break;
2400 case i_readIntOffAddr: OP_AI_I(indexIntOffAddrzh(r,x,y)); break;
2401 case i_writeIntOffAddr: OP_AII_(writeIntOffAddrzh(x,y,z)); break;
2403 case i_indexAddrOffAddr: OP_AI_A(indexAddrOffAddrzh(r,x,y)); break;
2404 case i_readAddrOffAddr: OP_AI_A(indexAddrOffAddrzh(r,x,y)); break;
2405 case i_writeAddrOffAddr: OP_AIA_(writeAddrOffAddrzh(x,y,z)); break;
2407 case i_indexFloatOffAddr: OP_AI_F(indexFloatOffAddrzh(r,x,y)); break;
2408 case i_readFloatOffAddr: OP_AI_F(indexFloatOffAddrzh(r,x,y)); break;
2409 case i_writeFloatOffAddr: OP_AIF_(writeFloatOffAddrzh(x,y,z)); break;
2411 case i_indexDoubleOffAddr: OP_AI_D(indexDoubleOffAddrzh(r,x,y)); break;
2412 case i_readDoubleOffAddr: OP_AI_D(indexDoubleOffAddrzh(r,x,y)); break;
2413 case i_writeDoubleOffAddr: OP_AID_(writeDoubleOffAddrzh(x,y,z)); break;
2415 case i_indexStableOffAddr: OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break;
2416 case i_readStableOffAddr: OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break;
2417 case i_writeStableOffAddr: OP_AIs_(writeStablePtrOffAddrzh(x,y,z)); break;
2419 #ifdef STANDALONE_INTEGER
2420 case i_compareInteger:
2422 B* x = IntegerInsideByteArray(PopPtr());
2423 B* y = IntegerInsideByteArray(PopPtr());
2424 StgInt r = do_cmp(x,y);
2425 PushTaggedInt(r<0 ? -1 : (r>0 ? 1 : 0));
2428 case i_negateInteger: OP_Z_Z(neg); break;
2429 case i_plusInteger: OP_ZZ_Z(add); break;
2430 case i_minusInteger: OP_ZZ_Z(sub); break;
2431 case i_timesInteger: OP_ZZ_Z(mul); break;
2432 case i_quotRemInteger:
2434 B* x = IntegerInsideByteArray(PopPtr());
2435 B* y = IntegerInsideByteArray(PopPtr());
2436 int n = size_qrm(x,y);
2437 StgPtr q = CreateByteArrayToHoldInteger(n);
2438 StgPtr r = CreateByteArrayToHoldInteger(n);
2439 if (do_getsign(y)==0)
2440 return (raiseDiv0("quotRemInteger"));
2441 do_qrm(x,y,n,IntegerInsideByteArray(q),
2442 IntegerInsideByteArray(r));
2443 SloppifyIntegerEnd(q);
2444 SloppifyIntegerEnd(r);
2449 case i_intToInteger:
2451 int n = size_fromInt();
2452 StgPtr p = CreateByteArrayToHoldInteger(n);
2453 do_fromInt( PopTaggedInt(), n, IntegerInsideByteArray(p));
2457 case i_wordToInteger:
2459 int n = size_fromWord();
2460 StgPtr p = CreateByteArrayToHoldInteger(n);
2461 do_fromWord( PopTaggedWord(), n, IntegerInsideByteArray(p));
2465 case i_integerToInt: PushTaggedInt(do_toInt(
2466 IntegerInsideByteArray(PopPtr())
2470 case i_integerToWord: PushTaggedWord(do_toWord(
2471 IntegerInsideByteArray(PopPtr())
2475 case i_integerToFloat: PushTaggedFloat(do_toFloat(
2476 IntegerInsideByteArray(PopPtr())
2480 case i_integerToDouble: PushTaggedDouble(do_toDouble(
2481 IntegerInsideByteArray(PopPtr())
2485 #error Non-standalone integer not yet implemented
2486 #endif /* STANDALONE_INTEGER */
2488 case i_gtFloat: OP_FF_B(x>y); break;
2489 case i_geFloat: OP_FF_B(x>=y); break;
2490 case i_eqFloat: OP_FF_B(x==y); break;
2491 case i_neFloat: OP_FF_B(x!=y); break;
2492 case i_ltFloat: OP_FF_B(x<y); break;
2493 case i_leFloat: OP_FF_B(x<=y); break;
2494 case i_minFloat: OP__F(FLT_MIN); break;
2495 case i_maxFloat: OP__F(FLT_MAX); break;
2496 case i_radixFloat: OP__I(FLT_RADIX); break;
2497 case i_digitsFloat: OP__I(FLT_MANT_DIG); break;
2498 case i_minExpFloat: OP__I(FLT_MIN_EXP); break;
2499 case i_maxExpFloat: OP__I(FLT_MAX_EXP); break;
2500 case i_plusFloat: OP_FF_F(x+y); break;
2501 case i_minusFloat: OP_FF_F(x-y); break;
2502 case i_timesFloat: OP_FF_F(x*y); break;
2505 StgFloat x = PopTaggedFloat();
2506 StgFloat y = PopTaggedFloat();
2507 PushTaggedFloat(x/y);
2510 case i_negateFloat: OP_F_F(-x); break;
2511 case i_floatToInt: OP_F_I(x); break;
2512 case i_intToFloat: OP_I_F(x); break;
2513 case i_expFloat: OP_F_F(exp(x)); break;
2514 case i_logFloat: OP_F_F(log(x)); break;
2515 case i_sqrtFloat: OP_F_F(sqrt(x)); break;
2516 case i_sinFloat: OP_F_F(sin(x)); break;
2517 case i_cosFloat: OP_F_F(cos(x)); break;
2518 case i_tanFloat: OP_F_F(tan(x)); break;
2519 case i_asinFloat: OP_F_F(asin(x)); break;
2520 case i_acosFloat: OP_F_F(acos(x)); break;
2521 case i_atanFloat: OP_F_F(atan(x)); break;
2522 case i_sinhFloat: OP_F_F(sinh(x)); break;
2523 case i_coshFloat: OP_F_F(cosh(x)); break;
2524 case i_tanhFloat: OP_F_F(tanh(x)); break;
2525 case i_powerFloat: OP_FF_F(pow(x,y)); break;
2527 #ifdef STANDALONE_INTEGER
2528 case i_encodeFloatZ:
2530 StgPtr sig = PopPtr();
2531 StgInt exp = PopTaggedInt();
2533 B__encodeFloat(IntegerInsideByteArray(sig), exp)
2537 case i_decodeFloatZ:
2539 StgFloat f = PopTaggedFloat();
2540 StgPtr sig = CreateByteArrayToHoldInteger(size_fltmantissa());
2542 B__decodeFloat(IntegerInsideByteArray(sig), &exp, f);
2548 #error encode/decodeFloatZ not yet implemented for GHC ints
2550 case i_isNaNFloat: OP_F_B(isFloatNaN(x)); break;
2551 case i_isInfiniteFloat: OP_F_B(isFloatInfinite(x)); break;
2552 case i_isNegativeZeroFloat: OP_F_B(isFloatNegativeZero(x)); break;
2553 case i_isDenormalizedFloat: OP_F_B(isFloatDenormalized(x)); break;
2554 case i_gtDouble: OP_DD_B(x>y); break;
2555 case i_geDouble: OP_DD_B(x>=y); break;
2556 case i_eqDouble: OP_DD_B(x==y); break;
2557 case i_neDouble: OP_DD_B(x!=y); break;
2558 case i_ltDouble: OP_DD_B(x<y); break;
2559 case i_leDouble: OP_DD_B(x<=y) break;
2560 case i_minDouble: OP__D(DBL_MIN); break;
2561 case i_maxDouble: OP__D(DBL_MAX); break;
2562 case i_radixDouble: OP__I(FLT_RADIX); break;
2563 case i_digitsDouble: OP__I(DBL_MANT_DIG); break;
2564 case i_minExpDouble: OP__I(DBL_MIN_EXP); break;
2565 case i_maxExpDouble: OP__I(DBL_MAX_EXP); break;
2566 case i_plusDouble: OP_DD_D(x+y); break;
2567 case i_minusDouble: OP_DD_D(x-y); break;
2568 case i_timesDouble: OP_DD_D(x*y); break;
2569 case i_divideDouble:
2571 StgDouble x = PopTaggedDouble();
2572 StgDouble y = PopTaggedDouble();
2573 PushTaggedDouble(x/y);
2576 case i_negateDouble: OP_D_D(-x); break;
2577 case i_doubleToInt: OP_D_I(x); break;
2578 case i_intToDouble: OP_I_D(x); break;
2579 case i_doubleToFloat: OP_D_F(x); break;
2580 case i_floatToDouble: OP_F_F(x); break;
2581 case i_expDouble: OP_D_D(exp(x)); break;
2582 case i_logDouble: OP_D_D(log(x)); break;
2583 case i_sqrtDouble: OP_D_D(sqrt(x)); break;
2584 case i_sinDouble: OP_D_D(sin(x)); break;
2585 case i_cosDouble: OP_D_D(cos(x)); break;
2586 case i_tanDouble: OP_D_D(tan(x)); break;
2587 case i_asinDouble: OP_D_D(asin(x)); break;
2588 case i_acosDouble: OP_D_D(acos(x)); break;
2589 case i_atanDouble: OP_D_D(atan(x)); break;
2590 case i_sinhDouble: OP_D_D(sinh(x)); break;
2591 case i_coshDouble: OP_D_D(cosh(x)); break;
2592 case i_tanhDouble: OP_D_D(tanh(x)); break;
2593 case i_powerDouble: OP_DD_D(pow(x,y)); break;
2595 #ifdef STANDALONE_INTEGER
2596 case i_encodeDoubleZ:
2598 StgPtr sig = PopPtr();
2599 StgInt exp = PopTaggedInt();
2601 B__encodeDouble(IntegerInsideByteArray(sig), exp)
2605 case i_decodeDoubleZ:
2607 StgDouble d = PopTaggedDouble();
2608 StgPtr sig = CreateByteArrayToHoldInteger(size_dblmantissa());
2610 B__decodeDouble(IntegerInsideByteArray(sig), &exp, d);
2616 #error encode/decodeDoubleZ not yet implemented for GHC ints
2618 case i_isNaNDouble: OP_D_B(isDoubleNaN(x)); break;
2619 case i_isInfiniteDouble: OP_D_B(isDoubleInfinite(x)); break;
2620 case i_isNegativeZeroDouble: OP_D_B(isDoubleNegativeZero(x)); break;
2621 case i_isDenormalizedDouble: OP_D_B(isDoubleDenormalized(x)); break;
2622 case i_isIEEEDouble:
2624 PushTaggedBool(rtsTrue);
2628 barf("Unrecognised primop1");
2635 /* For normal cases, return NULL and leave *return2 unchanged.
2636 To return the address of the next thing to enter,
2637 return the address of it and leave *return2 unchanged.
2638 To return a StgThreadReturnCode to the scheduler,
2639 set *return2 to it and return a non-NULL value.
2641 static void* enterBCO_primop2 ( int primop2code,
2642 int* /*StgThreadReturnCode* */ return2,
2646 switch (primop2code) {
2647 case i_raise: /* raise#{err} */
2649 StgClosure* err = PopCPtr();
2650 return (raiseAnError(err));
2655 StgClosure* init = PopCPtr();
2657 = stgCast(StgMutVar*,allocate(sizeofW(StgMutVar)));
2658 SET_HDR(mv,&MUT_VAR_info,CCCS);
2660 PushPtr(stgCast(StgPtr,mv));
2665 StgMutVar* mv = stgCast(StgMutVar*,PopPtr());
2671 StgMutVar* mv = stgCast(StgMutVar*,PopPtr());
2672 StgClosure* value = PopCPtr();
2678 nat n = PopTaggedInt(); /* or Word?? */
2679 StgClosure* init = PopCPtr();
2680 StgWord size = sizeofW(StgMutArrPtrs) + n;
2683 = stgCast(StgMutArrPtrs*,allocate(size));
2684 SET_HDR(arr,&MUT_ARR_PTRS_info,CCCS);
2686 for (i = 0; i < n; ++i) {
2687 arr->payload[i] = init;
2689 PushPtr(stgCast(StgPtr,arr));
2695 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2696 nat i = PopTaggedInt(); /* or Word?? */
2697 StgWord n = arr->ptrs;
2699 return (raiseIndex("{index,read}Array"));
2701 PushCPtr(arr->payload[i]);
2706 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2707 nat i = PopTaggedInt(); /* or Word? */
2708 StgClosure* v = PopCPtr();
2709 StgWord n = arr->ptrs;
2711 return (raiseIndex("{index,read}Array"));
2713 arr->payload[i] = v;
2717 case i_sizeMutableArray:
2719 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2720 PushTaggedInt(arr->ptrs);
2723 case i_unsafeFreezeArray:
2725 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2726 SET_INFO(arr,&MUT_ARR_PTRS_FROZEN_info);
2727 PushPtr(stgCast(StgPtr,arr));
2730 case i_unsafeFreezeByteArray:
2732 /* Delightfully simple :-) */
2736 case i_sameMutableArray:
2737 case i_sameMutableByteArray:
2739 StgPtr x = PopPtr();
2740 StgPtr y = PopPtr();
2741 PushTaggedBool(x==y);
2745 case i_newByteArray:
2747 nat n = PopTaggedInt(); /* or Word?? */
2748 StgInt words = (n+sizeof(W_)-1)/sizeof(W_);
2749 StgWord size = sizeofW(StgArrWords) + words;
2750 StgArrWords* arr = stgCast(StgArrWords*,allocate(size));
2751 SET_HDR(arr,&ARR_WORDS_info,CCCS);
2755 for (i = 0; i < n; ++i) {
2756 arr->payload[i] = 0xdeadbeef;
2759 PushPtr(stgCast(StgPtr,arr));
2763 /* Most of these generate alignment warnings on gSparcs and similar architectures.
2764 * These are harmless and are caused by the cast to C* in BYTE_ARR_CTS.
2766 case i_indexCharArray:
2767 OP_mI_ty(Char,"indexCharArray", indexCharArrayzh(r,x,i)); break;
2768 case i_readCharArray:
2769 OP_mI_ty(Char,"readCharArray", readCharArrayzh(r,x,i)); break;
2770 case i_writeCharArray:
2771 OP_mIty_(Char,"writeCharArray", writeCharArrayzh(x,i,z)); break;
2773 case i_indexIntArray:
2774 OP_mI_ty(Int,"indexIntArray", indexIntArrayzh(r,x,i)); break;
2775 case i_readIntArray:
2776 OP_mI_ty(Int,"readIntArray", readIntArrayzh(r,x,i)); break;
2777 case i_writeIntArray:
2778 OP_mIty_(Int,"writeIntArray", writeIntArrayzh(x,i,z)); break;
2780 case i_indexAddrArray:
2781 OP_mI_ty(Addr,"indexAddrArray", indexAddrArrayzh(r,x,i)); break;
2782 case i_readAddrArray:
2783 OP_mI_ty(Addr,"readAddrArray", readAddrArrayzh(r,x,i)); break;
2784 case i_writeAddrArray:
2785 OP_mIty_(Addr,"writeAddrArray", writeAddrArrayzh(x,i,z)); break;
2787 case i_indexFloatArray:
2788 OP_mI_ty(Float,"indexFloatArray", indexFloatArrayzh(r,x,i)); break;
2789 case i_readFloatArray:
2790 OP_mI_ty(Float,"readFloatArray", readFloatArrayzh(r,x,i)); break;
2791 case i_writeFloatArray:
2792 OP_mIty_(Float,"writeFloatArray", writeFloatArrayzh(x,i,z)); break;
2794 case i_indexDoubleArray:
2795 OP_mI_ty(Double,"indexDoubleArray", indexDoubleArrayzh(r,x,i)); break;
2796 case i_readDoubleArray:
2797 OP_mI_ty(Double,"readDoubleArray", readDoubleArrayzh(r,x,i)); break;
2798 case i_writeDoubleArray:
2799 OP_mIty_(Double,"writeDoubleArray", writeDoubleArrayzh(x,i,z)); break;
2802 #ifdef PROVIDE_STABLE
2803 case i_indexStableArray:
2804 OP_mI_ty(StablePtr,"indexStableArray", indexStablePtrArrayzh(r,x,i)); break;
2805 case i_readStableArray:
2806 OP_mI_ty(StablePtr,"readStableArray", readStablePtrArrayzh(r,x,i)); break;
2807 case i_writeStableArray:
2808 OP_mIty_(StablePtr,"writeStableArray", writeStablePtrArrayzh(x,i,z)); break;
2814 #ifdef PROVIDE_COERCE
2815 case i_unsafeCoerce:
2817 /* Another nullop */
2821 #ifdef PROVIDE_PTREQUALITY
2822 case i_reallyUnsafePtrEquality:
2823 { /* identical to i_sameRef */
2824 StgPtr x = PopPtr();
2825 StgPtr y = PopPtr();
2826 PushTaggedBool(x==y);
2830 #ifdef PROVIDE_FOREIGN
2831 /* ForeignObj# operations */
2832 case i_makeForeignObj:
2834 StgForeignObj *result
2835 = stgCast(StgForeignObj*,allocate(sizeofW(StgForeignObj)));
2836 SET_HDR(result,&FOREIGN_info,CCCS);
2837 result -> data = PopTaggedAddr();
2838 PushPtr(stgCast(StgPtr,result));
2841 #endif /* PROVIDE_FOREIGN */
2846 = stgCast(StgWeak*,allocate(sizeofW(StgWeak)));
2847 SET_HDR(w, &WEAK_info, CCCS);
2849 w->value = PopCPtr();
2850 w->finaliser = PopCPtr();
2851 w->link = weak_ptr_list;
2853 IF_DEBUG(weak, fprintf(stderr,"New weak pointer at %p\n",w));
2854 PushPtr(stgCast(StgPtr,w));
2859 StgWeak *w = stgCast(StgWeak*,PopPtr());
2860 if (w->header.info == &WEAK_info) {
2861 PushCPtr(w->value); /* last result */
2862 PushTaggedInt(1); /* first result */
2864 PushPtr(stgCast(StgPtr,w));
2865 /* ToDo: error thunk would be better */
2870 #endif /* PROVIDE_WEAK */
2872 case i_makeStablePtr:
2874 StgPtr p = PopPtr();
2875 StgStablePtr sp = getStablePtr ( p );
2876 PushTaggedStablePtr(sp);
2879 case i_deRefStablePtr:
2882 StgStablePtr sp = PopTaggedStablePtr();
2883 p = deRefStablePtr(sp);
2887 case i_freeStablePtr:
2889 StgStablePtr sp = PopTaggedStablePtr();
2894 case i_createAdjThunkARCH:
2896 StgStablePtr stableptr = PopTaggedStablePtr();
2897 StgAddr typestr = PopTaggedAddr();
2898 StgChar callconv = PopTaggedChar();
2899 StgAddr adj_thunk = createAdjThunk(stableptr,typestr,callconv);
2900 PushTaggedAddr(adj_thunk);
2906 StgInt n = prog_argc;
2912 StgInt n = PopTaggedInt();
2913 StgAddr a = (StgAddr)prog_argv[n];
2918 #ifdef PROVIDE_CONCURRENT
2921 StgClosure* c = PopCPtr();
2922 StgTSO* t = createGenThread(RtsFlags.GcFlags.initialStkSize,c);
2923 PushPtr(stgCast(StgPtr,t));
2925 /* switch at the earliest opportunity */
2927 /* but don't automatically switch to GHC - or you'll waste your
2928 * time slice switching back.
2930 * Actually, there's more to it than that: the default
2931 * (ThreadEnterGHC) causes the thread to crash - don't
2932 * understand why. - ADR
2934 t->whatNext = ThreadEnterHugs;
2939 StgTSO* tso = stgCast(StgTSO*,PopPtr());
2941 if (tso == cap->rCurrentTSO) { /* suicide */
2942 *return2 = ThreadFinished;
2943 return (void*)(1+(NULL));
2948 { /* identical to i_sameRef */
2949 StgPtr x = PopPtr();
2950 StgPtr y = PopPtr();
2951 PushTaggedBool(x==y);
2956 StgMVar *mvar = stgCast(StgMVar*,allocate(sizeofW(StgMVar)));
2957 SET_INFO(mvar,&EMPTY_MVAR_info);
2958 mvar->head = mvar->tail = EndTSOQueue;
2959 /* ToDo: this is a little strange */
2960 mvar->value = stgCast(StgClosure*,&END_TSO_QUEUE_closure);
2961 PushPtr(stgCast(StgPtr,mvar));
2966 ToDo: another way out of the problem might be to add an explicit
2967 continuation to primTakeMVar: takeMVar v = primTakeMVar v takeMVar.
2968 The problem with this plan is that now I dont know how much to chop
2973 StgMVar *mvar = stgCast(StgMVar*,PopPtr());
2974 /* If the MVar is empty, put ourselves
2975 * on its blocking queue, and wait
2976 * until we're woken up.
2978 if (GET_INFO(mvar) != &FULL_MVAR_info) {
2979 if (mvar->head == EndTSOQueue) {
2980 mvar->head = cap->rCurrentTSO;
2982 mvar->tail->link = cap->rCurrentTSO;
2984 cap->rCurrentTSO->link = EndTSOQueue;
2985 mvar->tail = cap->rCurrentTSO;
2987 /* Hack, hack, hack.
2988 * When we block, we push a restart closure
2989 * on the stack - but which closure?
2990 * We happen to know that the BCO we're
2991 * executing looks like this:
3000 * 14: ALLOC_CONSTR 0x8213a80
3010 * so we rearrange the stack to look the
3011 * way it did when we entered this BCO
3013 * What a disgusting hack!
3019 *return2 = ThreadBlocked;
3020 return (void*)(1+(NULL));
3023 PushCPtr(mvar->value);
3024 SET_INFO(mvar,&EMPTY_MVAR_info);
3025 /* ToDo: this is a little strange */
3026 mvar->value = (StgClosure*)&END_TSO_QUEUE_closure;
3033 StgMVar* mvar = stgCast(StgMVar*,PopPtr());
3034 StgClosure* value = PopCPtr();
3035 if (GET_INFO(mvar) == &FULL_MVAR_info) {
3036 return (raisePrim("putMVar {full MVar}"));
3038 /* wake up the first thread on the
3039 * queue, it will continue with the
3040 * takeMVar operation and mark the
3043 StgTSO* tso = mvar->head;
3044 SET_INFO(mvar,&FULL_MVAR_info);
3045 mvar->value = value;
3046 if (tso != EndTSOQueue) {
3047 PUSH_ON_RUN_QUEUE(tso);
3048 mvar->head = tso->link;
3049 tso->link = EndTSOQueue;
3050 if (mvar->head == EndTSOQueue) {
3051 mvar->tail = EndTSOQueue;
3055 /* yield for better communication performance */
3062 /* As PrimOps.h says: Hmm, I'll think about these later. */
3065 #endif /* PROVIDE_CONCURRENT */
3066 case i_ccall_ccall_Id:
3067 case i_ccall_ccall_IO:
3068 case i_ccall_stdcall_Id:
3069 case i_ccall_stdcall_IO:
3072 CFunDescriptor* descriptor = PopTaggedAddr();
3073 void (*funPtr)(void) = PopTaggedAddr();
3074 char cc = (primop2code == i_ccall_stdcall_Id ||
3075 primop2code == i_ccall_stdcall_IO)
3077 r = ccall(descriptor,funPtr,bco,cc,cap);
3080 return makeErrorCall(
3081 "unhandled type or too many args/results in ccall");
3083 barf("ccall not configured correctly for this platform");
3084 barf("unknown return code from ccall");
3087 barf("Unrecognised primop2");
3093 /* -----------------------------------------------------------------------------
3094 * ccall support code:
3095 * marshall moves args from C stack to Haskell stack
3096 * unmarshall moves args from Haskell stack to C stack
3097 * argSize calculates how much gSpace you need on the C stack
3098 * ---------------------------------------------------------------------------*/
3100 /* Pop arguments off the C stack and Push them onto the Hugs stack.
3101 * Used when preparing for C calling Haskell or in regSponse to
3102 * Haskell calling C.
3104 nat marshall(char arg_ty, void* arg)
3108 PushTaggedInt(*((int*)arg));
3109 return ARG_SIZE(INT_TAG);
3110 #ifdef TODO_STANDALONE_INTEGER
3112 PushTaggedInteger(*((mpz_ptr*)arg));
3113 return ARG_SIZE(INTEGER_TAG);
3116 PushTaggedWord(*((unsigned int*)arg));
3117 return ARG_SIZE(WORD_TAG);
3119 PushTaggedChar(*((char*)arg));
3120 return ARG_SIZE(CHAR_TAG);
3122 PushTaggedFloat(*((float*)arg));
3123 return ARG_SIZE(FLOAT_TAG);
3125 PushTaggedDouble(*((double*)arg));
3126 return ARG_SIZE(DOUBLE_TAG);
3128 PushTaggedAddr(*((void**)arg));
3129 return ARG_SIZE(ADDR_TAG);
3131 PushTaggedStablePtr(*((StgStablePtr*)arg));
3132 return ARG_SIZE(STABLE_TAG);
3133 #ifdef PROVIDE_FOREIGN
3135 /* Not allowed in this direction - you have to
3136 * call makeForeignPtr explicitly
3138 barf("marshall: ForeignPtr#\n");
3143 /* Not allowed in this direction */
3144 barf("marshall: [Mutable]ByteArray#\n");
3147 barf("marshall: unrecognised arg type %d\n",arg_ty);
3152 /* Pop arguments off the Hugs stack and Push them onto the C stack.
3153 * Used when preparing for Haskell calling C or in regSponse to
3154 * C calling Haskell.
3156 nat unmarshall(char res_ty, void* res)
3160 *((int*)res) = PopTaggedInt();
3161 return ARG_SIZE(INT_TAG);
3162 #ifdef TODO_STANDALONE_INTEGER
3164 *((mpz_ptr*)res) = PopTaggedInteger();
3165 return ARG_SIZE(INTEGER_TAG);
3168 *((unsigned int*)res) = PopTaggedWord();
3169 return ARG_SIZE(WORD_TAG);
3171 *((int*)res) = PopTaggedChar();
3172 return ARG_SIZE(CHAR_TAG);
3174 *((float*)res) = PopTaggedFloat();
3175 return ARG_SIZE(FLOAT_TAG);
3177 *((double*)res) = PopTaggedDouble();
3178 return ARG_SIZE(DOUBLE_TAG);
3180 *((void**)res) = PopTaggedAddr();
3181 return ARG_SIZE(ADDR_TAG);
3183 *((StgStablePtr*)res) = PopTaggedStablePtr();
3184 return ARG_SIZE(STABLE_TAG);
3185 #ifdef PROVIDE_FOREIGN
3188 StgForeignObj *result = stgCast(StgForeignObj*,PopPtr());
3189 *((void**)res) = result->data;
3190 return sizeofW(StgPtr);
3196 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
3197 *((void**)res) = stgCast(void*,&(arr->payload));
3198 return sizeofW(StgPtr);
3201 barf("unmarshall: unrecognised result type %d\n",res_ty);
3205 nat argSize( const char* ks )
3208 for( ; *ks != '\0'; ++ks) {
3211 sz += sizeof(StgWord) * ARG_SIZE(INT_TAG);
3213 #ifdef TODO_STANDALONE_INTEGER
3215 sz += sizeof(StgWord) * ARG_SIZE(INTEGER_TAG);
3219 sz += sizeof(StgWord) * ARG_SIZE(WORD_TAG);
3222 sz += sizeof(StgWord) * ARG_SIZE(CHAR_TAG);
3225 sz += sizeof(StgWord) * ARG_SIZE(FLOAT_TAG);
3228 sz += sizeof(StgWord) * ARG_SIZE(DOUBLE_TAG);
3231 sz += sizeof(StgWord) * ARG_SIZE(ADDR_TAG);
3234 sz += sizeof(StgWord) * ARG_SIZE(STABLE_TAG);
3236 #ifdef PROVIDE_FOREIGN
3241 sz += sizeof(StgPtr);
3244 barf("argSize: unrecognised result type %d\n",*ks);
3252 /* -----------------------------------------------------------------------------
3253 * encode/decode Float/Double code for standalone Hugs
3254 * Code based on the HBC code (lib/fltcode.c) and more recently GHC
3255 * (ghc/rts/StgPrimFloat.c)
3256 * ---------------------------------------------------------------------------*/
3258 #ifdef STANDALONE_INTEGER
3260 #if IEEE_FLOATING_POINT
3261 #define MY_DMINEXP ((DBL_MIN_EXP) - (DBL_MANT_DIG) - 1)
3262 /* DMINEXP is defined in values.h on Linux (for example) */
3263 #define DHIGHBIT 0x00100000
3264 #define DMSBIT 0x80000000
3266 #define MY_FMINEXP ((FLT_MIN_EXP) - (FLT_MANT_DIG) - 1)
3267 #define FHIGHBIT 0x00800000
3268 #define FMSBIT 0x80000000
3270 #error The following code doesnt work in a non-IEEE FP environment
3273 #ifdef WORDS_BIGENDIAN
3282 StgDouble B__encodeDouble (B* s, I_ e) /* result = s * 2^e */
3287 /* Convert a B to a double; knows a lot about internal rep! */
3288 for(r = 0.0, i = s->used-1; i >= 0; i--)
3289 r = (r * B_BASE_FLT) + s->stuff[i];
3291 /* Now raise to the exponent */
3292 if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
3295 /* handle the sign */
3296 if (s->sign < 0) r = -r;
3303 #if ! FLOATS_AS_DOUBLES
3304 StgFloat B__encodeFloat (B* s, I_ e) /* result = s * 2^e */
3309 /* Convert a B to a float; knows a lot about internal rep! */
3310 for(r = 0.0, i = s->used-1; i >= 0; i--)
3311 r = (r * B_BASE_FLT) + s->stuff[i];
3313 /* Now raise to the exponent */
3314 if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
3317 /* handle the sign */
3318 if (s->sign < 0) r = -r;
3322 #endif /* FLOATS_AS_DOUBLES */
3326 /* This only supports IEEE floating point */
3327 void B__decodeDouble (B* man, I_* exp, StgDouble dbl)
3329 /* Do some bit fiddling on IEEE */
3330 nat low, high; /* assuming 32 bit ints */
3332 union { double d; int i[2]; } u; /* assuming 32 bit ints, 64 bit double */
3334 u.d = dbl; /* grab chunks of the double */
3338 ASSERT(B_BASE == 256);
3340 /* Assume that the supplied B is the right size */
3343 if (low == 0 && (high & ~DMSBIT) == 0) {
3344 man->sign = man->used = 0;
3349 iexp = ((high >> 20) & 0x7ff) + MY_DMINEXP;
3353 if (iexp != MY_DMINEXP) /* don't add hidden bit to denorms */
3357 /* A denorm, normalize the mantissa */
3358 while (! (high & DHIGHBIT)) {
3368 man->stuff[7] = (((W_)high) >> 24) & 0xff;
3369 man->stuff[6] = (((W_)high) >> 16) & 0xff;
3370 man->stuff[5] = (((W_)high) >> 8) & 0xff;
3371 man->stuff[4] = (((W_)high) ) & 0xff;
3373 man->stuff[3] = (((W_)low) >> 24) & 0xff;
3374 man->stuff[2] = (((W_)low) >> 16) & 0xff;
3375 man->stuff[1] = (((W_)low) >> 8) & 0xff;
3376 man->stuff[0] = (((W_)low) ) & 0xff;
3378 if (sign < 0) man->sign = -1;
3380 do_renormalise(man);
3384 #if ! FLOATS_AS_DOUBLES
3385 void B__decodeFloat (B* man, I_* exp, StgFloat flt)
3387 /* Do some bit fiddling on IEEE */
3388 int high, sign; /* assuming 32 bit ints */
3389 union { float f; int i; } u; /* assuming 32 bit float and int */
3391 u.f = flt; /* grab the float */
3394 ASSERT(B_BASE == 256);
3396 /* Assume that the supplied B is the right size */
3399 if ((high & ~FMSBIT) == 0) {
3400 man->sign = man->used = 0;
3405 *exp = ((high >> 23) & 0xff) + MY_FMINEXP;
3409 if (*exp != MY_FMINEXP) /* don't add hidden bit to denorms */
3413 /* A denorm, normalize the mantissa */
3414 while (! (high & FHIGHBIT)) {
3419 man->stuff[3] = (((W_)high) >> 24) & 0xff;
3420 man->stuff[2] = (((W_)high) >> 16) & 0xff;
3421 man->stuff[1] = (((W_)high) >> 8) & 0xff;
3422 man->stuff[0] = (((W_)high) ) & 0xff;
3424 if (sign < 0) man->sign = -1;
3426 do_renormalise(man);
3429 #endif /* FLOATS_AS_DOUBLES */
3431 #endif /* STANDALONE_INTEGER */
3433 #endif /* INTERPRETER */