2 /* -----------------------------------------------------------------------------
5 * Copyright (c) 1994-1998.
7 * $RCSfile: Evaluator.c,v $
9 * $Date: 2000/05/10 09:00:20 $
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} */
28 #include "Evaluator.h"
29 #include "sainteger.h"
33 #include "Disassembler.h"
38 #include <math.h> /* These are for primops */
39 #include <limits.h> /* These are for primops */
40 #include <float.h> /* These are for primops */
42 #include <ieee754.h> /* These are for primops */
46 /* Allegedly useful macro, taken from ClosureMacros.h */
47 #define payloadWord( c, i ) (*stgCast(StgWord*, ((c)->payload+(i))))
48 #define payloadPtr( c, i ) (*stgCast(StgPtr*, ((c)->payload+(i))))
50 /* An incredibly useful abbreviation.
51 * Interestingly, there are some uses of END_TSO_QUEUE_closure that
52 * can't use it because they use the closure at type StgClosure* or
53 * even StgPtr*. I suspect they should be changed. -- ADR
55 #define EndTSOQueue stgCast(StgTSO*,(void*)&END_TSO_QUEUE_closure)
57 /* These macros are rather delicate - read a good ANSI C book carefully
61 #define mycat(x,y) x##y
62 #define mycat2(x,y) mycat(x,y)
63 #define mycat3(x,y,z) mycat2(x,mycat2(y,z))
65 #if defined(__GNUC__) && !defined(DEBUG)
66 #define USE_GCC_LABELS 1
68 #define USE_GCC_LABELS 0
71 /* Make it possible for the evaluator to get hold of bytecode
72 for a given function by name. Useful but a hack. Sigh.
74 extern void* /* StgClosure* */ getHugs_BCO_cptr_for ( char* s );
75 extern int /* Bool */ combined;
79 /* --------------------------------------------------------------------------
80 * Hugs Hooks - a bit of a hack
81 * ------------------------------------------------------------------------*/
83 void setRtsFlags( int x );
84 void setRtsFlags( int x )
86 unsigned int w = 0x12345678;
87 unsigned char* pw = (unsigned char *)&w;
90 *(int*)(&(RtsFlags.DebugFlags)) = x;
95 w2 |= (w1 && 0xFF); w2 <<= 8; w1 >>= 8;
96 w2 |= (w1 && 0xFF); w2 <<= 8; w1 >>= 8;
97 w2 |= (w1 && 0xFF); w2 <<= 8; w1 >>= 8;
98 w2 |= (w1 && 0xFF); w2 <<= 8; w1 >>= 8;
99 *(int*)(&(RtsFlags.DebugFlags)) = (int)w2;
105 StgTSOBlockReason reason;
110 /* --------------------------------------------------------------------------
111 * Entering-objects and bytecode interpreter part of evaluator
112 * ------------------------------------------------------------------------*/
114 /* The primop (and all other) parts of this evaluator operate upon the
115 machine state which lives in MainRegTable. enter is different:
116 to make its closure- and bytecode-interpreting loops go fast, some of that
117 state is pulled out into local vars (viz, registers, if we are lucky).
118 That means that we need to save(load) the local state at every exit(reentry)
119 into enter. That is, around every procedure call it makes. Blargh!
120 If you modify this code, __be warned__ it will fail in mysterious ways if
121 you fail to preserve this property.
123 Currently the pulled-out state is Sp in xSp, Su in xSu and SpLim in xSpLim.
124 The SSS macros saves the state back in MainRegTable, and LLL loads it from
125 MainRegTable. RETURN(v) does SSS and then returns v; all exits should
126 be via RETURN and not plain return.
128 Since xSp, xSu and xSpLim are local vars in enter, they are not visible
129 in procedures called from enter. To fix this, either (1) turn the
130 procedures into macros, so they get copied inline, or (2) bracket
131 the procedure call with SSS and LLL so that the local and global
132 machine states are synchronised for the duration of the call.
136 /* Forward decls ... */
137 static void* enterBCO_primop1 ( int );
138 static void* enterBCO_primop2 ( int , int* /*StgThreadReturnCode* */,
139 StgBCO**, Capability*, HugsBlock * );
140 static inline void PopUpdateFrame ( StgClosure* obj );
141 static inline void PopCatchFrame ( void );
142 static inline void PopSeqFrame ( void );
143 static inline void PopStopFrame( StgClosure* obj );
144 static inline void PushTaggedRealWorld( void );
145 /* static inline void PushTaggedInteger ( mpz_ptr ); */
146 static inline StgPtr grabHpUpd( nat size );
147 static inline StgPtr grabHpNonUpd( nat size );
148 static StgClosure* raiseAnError ( StgClosure* exception );
150 static int enterCountI = 0;
152 StgDouble B__encodeDouble (B* s, I_ e);
153 void B__decodeDouble (B* man, I_* exp, StgDouble dbl);
154 #if ! FLOATS_AS_DOUBLES
155 StgFloat B__encodeFloat (B* s, I_ e);
156 void B__decodeFloat (B* man, I_* exp, StgFloat flt);
157 StgPtr CreateByteArrayToHoldInteger ( int );
158 B* IntegerInsideByteArray ( StgPtr );
159 void SloppifyIntegerEnd ( StgPtr );
165 #define gSp MainRegTable.rSp
166 #define gSu MainRegTable.rSu
167 #define gSpLim MainRegTable.rSpLim
170 /* Macros to save/load local state. */
172 #define SSS { tSp=gSp = xSp; tSu=gSu = xSu; tSpLim=gSpLim = xSpLim; }
173 #define LLL { tSp=xSp = gSp; tSu=xSu = gSu; tSpLim=xSpLim = gSpLim; }
175 #define SSS { gSp = xSp; gSu = xSu; gSpLim = xSpLim; }
176 #define LLL { xSp = gSp; xSu = gSu; xSpLim = gSpLim; }
179 #define RETURN(vvv) { \
180 StgThreadReturnCode retVal=(vvv); \
182 cap->rCurrentTSO->sp = gSp; \
183 cap->rCurrentTSO->su = gSu; \
184 cap->rCurrentTSO->splim = gSpLim; \
189 /* Macros to operate directly on the pulled-out machine state.
190 These mirror some of the small procedures used in the primop code
191 below, except you have to be careful about side effects,
192 ie xPushPtr(xStackPtr(n)) won't work! It certainly isn't the
193 same as PushPtr(StackPtr(n)). Also note that (1) some of
194 the macros, in particular xPopTagged*, do not make the tag
195 sanity checks that their non-x cousins do, and (2) some of
196 the macros depend critically on the semantics of C comma
197 expressions to work properly.
199 #define xPushPtr(ppp) { xSp--; *xSp=(StgWord)(ppp); }
200 #define xPopPtr() ((StgPtr)(*xSp++))
202 #define xPushCPtr(ppp) { xSp--; *xSp=(StgWord)(ppp); }
203 #define xPopCPtr() ((StgClosure*)(*xSp++))
205 #define xPushWord(ppp) { xSp--; *xSp=(StgWord)(ppp); }
206 #define xPopWord() ((StgWord)(*xSp++))
208 #define xStackPtr(nnn) ((StgPtr)(*(xSp+(nnn))))
209 #define xStackWord(nnn) ((StgWord)(*(xSp+(nnn))))
210 #define xSetStackWord(iii,www) xSp[iii]=(StgWord)(www)
212 #define xPushTag(ttt) { xSp--; *xSp=(StgWord)(ttt); }
213 #define xPopTag(ttt) { StackTag t = (StackTag)(*xSp++); \
216 #define xPushTaggedInt(xxx) { xSp -= sizeofW(StgInt); \
217 *xSp = (xxx); xPushTag(INT_TAG); }
218 #define xTaggedStackInt(iii) ((StgInt)(*(xSp+1+(iii))))
219 #define xPopTaggedInt() ((xSp++,xSp+=sizeofW(StgInt), \
220 (StgInt)(*(xSp-sizeofW(StgInt)))))
222 #define xPushTaggedWord(xxx) { xSp -= sizeofW(StgWord); \
223 *xSp = (xxx); xPushTag(WORD_TAG); }
224 #define xTaggedStackWord(iii) ((StgWord)(*(xSp+1+(iii))))
225 #define xPopTaggedWord() ((xSp++,xSp+=sizeofW(StgWord), \
226 (StgWord)(*(xSp-sizeofW(StgWord)))))
228 #define xPushTaggedAddr(xxx) { xSp -= sizeofW(StgAddr); \
229 *xSp = (StgWord)(xxx); xPushTag(ADDR_TAG); }
230 #define xTaggedStackAddr(iii) ((StgAddr)(*(xSp+1+(iii))))
231 #define xPopTaggedAddr() ((xSp++,xSp+=sizeofW(StgAddr), \
232 (StgAddr)(*(xSp-sizeofW(StgAddr)))))
234 #define xPushTaggedStable(xxx) { xSp -= sizeofW(StgStablePtr); \
235 *xSp = (StgWord)(xxx); xPushTag(STABLE_TAG); }
236 #define xTaggedStackStable(iii) ((StgStablePtr)(*(xSp+1+(iii))))
237 #define xPopTaggedStable() ((xSp++,xSp+=sizeofW(StgStablePtr), \
238 (StgStablePtr)(*(xSp-sizeofW(StgStablePtr)))))
240 #define xPushTaggedChar(xxx) { xSp -= sizeofW(StgChar); \
241 *xSp = (StgWord)(xxx); xPushTag(CHAR_TAG); }
242 #define xTaggedStackChar(iii) ((StgChar)(*(xSp+1+(iii))))
243 #define xPopTaggedChar() ((xSp++,xSp+=sizeofW(StgChar), \
244 (StgChar)(*(xSp-sizeofW(StgChar)))))
246 #define xPushTaggedFloat(xxx) { xSp -= sizeofW(StgFloat); \
247 ASSIGN_FLT(xSp,xxx); xPushTag(FLOAT_TAG); }
248 #define xTaggedStackFloat(iii) PK_FLT(xSp+1+(iii))
249 #define xPopTaggedFloat() ((xSp++,xSp+=sizeofW(StgFloat), \
250 PK_FLT(xSp-sizeofW(StgFloat))))
252 #define xPushTaggedDouble(xxx) { xSp -= sizeofW(StgDouble); \
253 ASSIGN_DBL(xSp,xxx); xPushTag(DOUBLE_TAG); }
254 #define xTaggedStackDouble(iii) PK_DBL(xSp+1+(iii))
255 #define xPopTaggedDouble() ((xSp++,xSp+=sizeofW(StgDouble), \
256 PK_DBL(xSp-sizeofW(StgDouble))))
259 #define xPushUpdateFrame(target, xSp_offset) \
261 StgUpdateFrame *__frame; \
262 __frame = (StgUpdateFrame *)(xSp + (xSp_offset)) - 1; \
263 SET_INFO(__frame, (StgInfoTable *)&Upd_frame_info); \
264 __frame->link = xSu; \
265 __frame->updatee = (StgClosure *)(target); \
269 #define xPopUpdateFrame(ooo) \
271 /* NB: doesn't assume that Sp == Su */ \
272 IF_DEBUG(evaluator, \
273 fprintf(stderr, "Updating "); \
274 printPtr(stgCast(StgPtr,xSu->updatee)); \
275 fprintf(stderr, " with "); \
277 fprintf(stderr,"xSp = %p\txSu = %p\n\n", xSp, xSu); \
279 UPD_IND(xSu->updatee,ooo); \
280 xSp = stgCast(StgStackPtr,xSu) + sizeofW(StgUpdateFrame); \
286 /* Instruction stream macros */
287 #define BCO_INSTR_8 *bciPtr++
288 #define BCO_INSTR_16 ((bciPtr += 2, (*(bciPtr-2) << 8) + *(bciPtr-1)))
289 #define PC (bciPtr - &(bcoInstr(bco,0)))
292 /* State on entry to enter():
293 * - current thread is in cap->rCurrentTSO;
294 * - allocation area is in cap->rCurrentNursery & cap->rNursery
297 StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 )
299 /* use of register here is primarily to make it clear to compilers
300 that these entities are non-aliasable.
302 register StgPtr xSp; /* local state -- stack pointer */
303 register StgUpdateFrame* xSu; /* local state -- frame pointer */
304 register StgPtr xSpLim; /* local state -- stack lim pointer */
305 register StgClosure* obj; /* object currently under evaluation */
306 char eCount; /* enter counter, for context switching */
309 HugsBlock hugsBlock = { NotBlocked, 0 };
313 StgPtr tSp; StgUpdateFrame* tSu; StgPtr tSpLim;
316 gSp = cap->rCurrentTSO->sp;
317 gSu = cap->rCurrentTSO->su;
318 gSpLim = cap->rCurrentTSO->splim;
321 /* use the t values to check that Su/Sp/SpLim do not change unexpectedly */
322 tSp = gSp; tSu = gSu; tSpLim = gSpLim;
328 /* Load the local state from global state, and Party On, Dudes! */
329 /* From here onwards, we operate with the local state and
330 save/reload it as necessary.
341 assert(gSpLim == tSpLim);
345 ASSERT(xSpLim <= xSp && xSp <= stgCast(StgPtr,xSu));
347 "\n---------------------------------------------------------------\n");
348 fprintf(stderr,"(%d) Entering: ",enterCountI); printObj(obj);
349 fprintf(stderr,"xSp = %p\txSu = %p\n", xSp, xSu);
350 fprintf(stderr, "\n" );
351 printStack(xSp,cap->rCurrentTSO->stack+cap->rCurrentTSO->stack_size,xSu);
352 fprintf(stderr, "\n\n");
359 ((++eCount) & 0x0F) == 0
364 if (context_switch) {
365 switch(hugsBlock.reason) {
367 xPushCPtr(obj); /* code to restart with */
368 RETURN(ThreadYielding);
370 case BlockedOnDelay: /* fall through */
371 case BlockedOnRead: /* fall through */
372 case BlockedOnWrite: {
373 ASSERT(cap->rCurrentTSO->why_blocked == NotBlocked);
374 cap->rCurrentTSO->why_blocked = BlockedOnDelay;
375 ACQUIRE_LOCK(&sched_mutex);
377 #if defined(HAVE_SETITIMER) || defined(mingw32_TARGET_OS)
378 cap->rCurrentTSO->block_info.delay
379 = hugsBlock.delay + ticks_since_select;
381 cap->rCurrentTSO->block_info.target
382 = hugsBlock.delay + getourtimeofday();
384 APPEND_TO_BLOCKED_QUEUE(cap->rCurrentTSO);
386 RELEASE_LOCK(&sched_mutex);
388 xPushCPtr(obj); /* code to restart with */
389 RETURN(ThreadBlocked);
392 barf("Unknown context switch reasoning");
397 switch ( get_itbl(obj)->type ) {
399 barf("Invalid object %p",obj);
403 /* ---------------------------------------------------- */
404 /* Start of the bytecode evaluator */
405 /* ---------------------------------------------------- */
408 # define Ins(x) &&l##x
409 static void *labs[] = { INSTRLIST };
411 # define LoopTopLabel
412 # define Case(x) l##x
413 # define Continue goto *labs[BCO_INSTR_8]
414 # define Dispatch Continue;
417 # define LoopTopLabel insnloop:
418 # define Case(x) case x
419 # define Continue goto insnloop
420 # define Dispatch switch (BCO_INSTR_8) {
421 # define EndDispatch }
424 register StgWord8* bciPtr; /* instruction pointer */
425 register StgBCO* bco = (StgBCO*)obj;
428 /* Don't need to SSS ... LLL around doYouWantToGC */
429 wantToGC = doYouWantToGC();
431 xPushCPtr((StgClosure*)bco); /* code to restart with */
432 RETURN(HeapOverflow);
435 bciPtr = &(bcoInstr(bco,0));
439 ASSERT((StgWord)(PC) < bco->n_instrs);
441 fprintf(stderr,"Sp = %p\tSu = %p\tpc = %d\t", xSp, xSu, PC);
445 fprintf(stderr,"\n");
446 for (i = 8; i >= 0; i--)
447 fprintf(stderr, "%d %p\n", i, (StgPtr)(*(gSp+i)));
449 fprintf(stderr,"\n");
455 Case(i_INTERNAL_ERROR):
456 barf("INTERNAL_ERROR at %p:%d",bco,PC-1);
458 barf("PANIC at %p:%d",bco,PC-1);
462 if (xSp - n < xSpLim) {
463 xPushCPtr((StgClosure*)bco); /* code to restart with */
464 RETURN(StackOverflow);
468 Case(i_STK_CHECK_big):
470 int n = BCO_INSTR_16;
471 if (xSp - n < xSpLim) {
472 xPushCPtr((StgClosure*)bco); /* code to restart with */
473 RETURN(StackOverflow);
480 if ((StgPtr*)(xSp + n) > (StgPtr*)xSu) {
481 StgWord words = (P_)xSu - xSp;
483 /* first build a PAP */
484 ASSERT((P_)xSu >= xSp); /* was (words >= 0) but that's always true */
485 if (words == 0) { /* optimisation */
486 /* Skip building the PAP and update with an indirection. */
489 /* In the evaluator, we avoid the need to do
490 * a heap check here by including the size of
491 * the PAP in the heap check we performed
492 * when we entered the BCO.
496 SSS; pap = (StgPAP*)grabHpNonUpd(PAP_sizeW(words)); LLL;
497 SET_HDR(pap,&PAP_info,CC_pap);
500 for (i = 0; i < (I_)words; ++i) {
501 payloadWord(pap,i) = xSp[i];
504 obj = stgCast(StgClosure*,pap);
507 /* now deal with "update frame" */
508 /* as an optimisation, we process all on top of stack */
509 /* instead of just the top one */
510 ASSERT(xSp==(P_)xSu);
512 switch (get_itbl(xSu)->type) {
514 /* Hit a catch frame during an arg satisfaction check,
515 * so the thing returning (1) has not thrown an
516 * exception, and (2) is of functional type. Just
517 * zap the catch frame and carry on down the stack
518 * (looking for more arguments, basically).
520 SSS; PopCatchFrame(); LLL;
523 xPopUpdateFrame(obj);
526 barf("STOP frame during pap update");
528 cap->rCurrentTSO->what_next = ThreadComplete;
529 SSS; PopStopFrame(obj); LLL;
530 RETURN(ThreadFinished);
533 SSS; PopSeqFrame(); LLL;
534 ASSERT(xSp != (P_)xSu);
535 /* Hit a SEQ frame during an arg satisfaction check.
536 * So now return to bco_info which is under the
537 * SEQ frame. The following code is copied from a
538 * case RET_BCO further down. (The reason why we're
539 * here is that something of functional type has
540 * been seq-d on, and we're now returning to the
541 * algebraic-case-continuation which forced the
542 * evaluation in the first place.)
554 barf("Invalid update frame during argcheck");
556 } while (xSp==(P_)xSu);
564 int words = BCO_INSTR_8;
565 SSS; p = grabHpUpd(AP_sizeW(words)); LLL;
569 Case(i_ALLOC_CONSTR):
572 StgInfoTable* info = bcoConstAddr(bco,BCO_INSTR_8);
573 SSS; p = grabHpNonUpd(sizeW_fromITBL(info)); LLL;
574 SET_HDR((StgClosure*)p,info,??);
578 Case(i_ALLOC_CONSTR_big):
581 int x = BCO_INSTR_16;
582 StgInfoTable* info = bcoConstAddr(bco,x);
583 SSS; p = grabHpNonUpd(sizeW_fromITBL(info)); LLL;
584 SET_HDR((StgClosure*)p,info,??);
590 int x = BCO_INSTR_8; /* ToDo: Word not Int! */
592 StgAP_UPD* o = stgCast(StgAP_UPD*,xStackPtr(x));
593 SET_HDR(o,&AP_UPD_info,??);
595 o->fun = stgCast(StgClosure*,xPopPtr());
596 for(x=0; x < y; ++x) {
597 payloadWord(o,x) = xPopWord();
600 fprintf(stderr,"\tBuilt ");
602 printObj(stgCast(StgClosure*,o));
613 o = stgCast(StgAP_UPD*,xStackPtr(x));
614 SET_HDR(o,&AP_UPD_info,??);
616 o->fun = stgCast(StgClosure*,xPopPtr());
617 for(x=0; x < y; ++x) {
618 payloadWord(o,x) = xPopWord();
621 fprintf(stderr,"\tBuilt ");
623 printObj(stgCast(StgClosure*,o));
632 StgPAP* o = stgCast(StgPAP*,xStackPtr(x));
633 SET_HDR(o,&PAP_info,??);
635 o->fun = stgCast(StgClosure*,xPopPtr());
636 for(x=0; x < y; ++x) {
637 payloadWord(o,x) = xPopWord();
640 fprintf(stderr,"\tBuilt ");
642 printObj(stgCast(StgClosure*,o));
649 int offset = BCO_INSTR_8;
650 StgClosure* o = stgCast(StgClosure*,xStackPtr(offset));
651 const StgInfoTable* info = get_itbl(o);
652 nat p = info->layout.payload.ptrs;
653 nat np = info->layout.payload.nptrs;
655 for(i=0; i < p; ++i) {
656 o->payload[i] = xPopCPtr();
658 for(i=0; i < np; ++i) {
659 payloadWord(o,p+i) = 0xdeadbeef;
662 fprintf(stderr,"\tBuilt ");
664 printObj(stgCast(StgClosure*,o));
671 int offset = BCO_INSTR_16;
672 StgClosure* o = stgCast(StgClosure*,xStackPtr(offset));
673 const StgInfoTable* info = get_itbl(o);
674 nat p = info->layout.payload.ptrs;
675 nat np = info->layout.payload.nptrs;
677 for(i=0; i < p; ++i) {
678 o->payload[i] = xPopCPtr();
680 for(i=0; i < np; ++i) {
681 payloadWord(o,p+i) = 0xdeadbeef;
684 fprintf(stderr,"\tBuilt ");
686 printObj(stgCast(StgClosure*,o));
695 ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
696 /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
698 xSetStackWord(x+y,xStackWord(x));
708 ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
709 /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
711 xSetStackWord(x+y,xStackWord(x));
723 xPushPtr(bcoConstPtr(bco,BCO_INSTR_8));
724 xPushPtr(stgCast(StgPtr,&ret_bco_info));
729 int tag = BCO_INSTR_8;
730 StgWord offset = BCO_INSTR_16;
731 if (constrTag( (StgClosure*)xStackPtr(0) ) != tag) {
738 StgClosure* o = stgCast(StgClosure*,xStackPtr(0));
739 const StgInfoTable* itbl = get_itbl(o);
740 int i = itbl->layout.payload.ptrs;
741 ASSERT( itbl->type == CONSTR
742 || itbl->type == CONSTR_STATIC
743 || itbl->type == CONSTR_NOCAF_STATIC
744 || itbl->type == CONSTR_1_0
745 || itbl->type == CONSTR_0_1
746 || itbl->type == CONSTR_2_0
747 || itbl->type == CONSTR_1_1
748 || itbl->type == CONSTR_0_2
751 xPushCPtr(o->payload[i]);
757 int n = BCO_INSTR_16;
758 StgPtr p = xStackPtr(n);
764 StgPtr p = xStackPtr(BCO_INSTR_8);
770 xPushPtr(stgCast(StgPtr,bcoConstPtr(bco,BCO_INSTR_8)));
775 int n = BCO_INSTR_16;
776 xPushPtr(stgCast(StgPtr,bcoConstPtr(bco,n)));
781 SSS; PushTaggedRealWorld(); LLL;
786 StgInt i = xTaggedStackInt(BCO_INSTR_8);
792 xPushTaggedInt(bcoConstInt(bco,BCO_INSTR_8));
795 Case(i_CONST_INT_big):
797 int n = BCO_INSTR_16;
798 xPushTaggedInt(bcoConstInt(bco,n));
804 SSS; o = (StgClosure*)grabHpNonUpd(Izh_sizeW); LLL;
805 SET_HDR(o,Izh_con_info,??);
806 payloadWord(o,0) = xPopTaggedInt();
808 fprintf(stderr,"\tBuilt ");
810 printObj(stgCast(StgClosure*,o));
813 xPushPtr(stgCast(StgPtr,o));
818 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
819 /* ASSERT(isIntLike(con)); */
820 xPushTaggedInt(payloadWord(con,0));
825 StgWord offset = BCO_INSTR_16;
826 StgInt x = xPopTaggedInt();
827 StgInt y = xPopTaggedInt();
833 Case(i_CONST_INTEGER):
837 char* s = bcoConstAddr(bco,BCO_INSTR_8);
840 p = CreateByteArrayToHoldInteger(n);
841 do_fromStr ( s, n, IntegerInsideByteArray(p));
842 SloppifyIntegerEnd(p);
849 StgWord w = xTaggedStackWord(BCO_INSTR_8);
855 xPushTaggedWord(bcoConstWord(bco,BCO_INSTR_8));
861 SSS; o = (StgClosure*)grabHpNonUpd(Wzh_sizeW); LLL;
862 SET_HDR(o,Wzh_con_info,??);
863 payloadWord(o,0) = xPopTaggedWord();
865 fprintf(stderr,"\tBuilt ");
867 printObj(stgCast(StgClosure*,o));
870 xPushPtr(stgCast(StgPtr,o));
875 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
876 /* ASSERT(isWordLike(con)); */
877 xPushTaggedWord(payloadWord(con,0));
882 StgAddr a = xTaggedStackAddr(BCO_INSTR_8);
888 xPushTaggedAddr(bcoConstAddr(bco,BCO_INSTR_8));
891 Case(i_CONST_ADDR_big):
893 int n = BCO_INSTR_16;
894 xPushTaggedAddr(bcoConstAddr(bco,n));
900 SSS; o = (StgClosure*)grabHpNonUpd(Azh_sizeW); LLL;
901 SET_HDR(o,Azh_con_info,??);
902 payloadPtr(o,0) = xPopTaggedAddr();
904 fprintf(stderr,"\tBuilt ");
906 printObj(stgCast(StgClosure*,o));
909 xPushPtr(stgCast(StgPtr,o));
914 StgClosure* con = (StgClosure*)xStackPtr(0);
915 /* ASSERT(isAddrLike(con)); */
916 xPushTaggedAddr(payloadPtr(con,0));
921 StgChar c = xTaggedStackChar(BCO_INSTR_8);
927 xPushTaggedChar(bcoConstChar(bco,BCO_INSTR_8));
933 SSS; o = (StgClosure*)grabHpNonUpd(Czh_sizeW); LLL;
934 SET_HDR(o,Czh_con_info,??);
935 payloadWord(o,0) = xPopTaggedChar();
936 xPushPtr(stgCast(StgPtr,o));
938 fprintf(stderr,"\tBuilt ");
940 printObj(stgCast(StgClosure*,o));
947 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
948 /* ASSERT(isCharLike(con)); */
949 xPushTaggedChar(payloadWord(con,0));
954 StgFloat f = xTaggedStackFloat(BCO_INSTR_8);
960 xPushTaggedFloat(bcoConstFloat(bco,BCO_INSTR_8));
966 SSS; o = (StgClosure*)grabHpNonUpd(Fzh_sizeW); LLL;
967 SET_HDR(o,Fzh_con_info,??);
968 ASSIGN_FLT(&payloadWord(o,0),xPopTaggedFloat());
970 fprintf(stderr,"\tBuilt ");
972 printObj(stgCast(StgClosure*,o));
975 xPushPtr(stgCast(StgPtr,o));
978 Case(i_UNPACK_FLOAT):
980 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
981 /* ASSERT(isFloatLike(con)); */
982 xPushTaggedFloat(PK_FLT(&payloadWord(con,0)));
987 StgDouble d = xTaggedStackDouble(BCO_INSTR_8);
988 xPushTaggedDouble(d);
991 Case(i_CONST_DOUBLE):
993 xPushTaggedDouble(bcoConstDouble(bco,BCO_INSTR_8));
996 Case(i_CONST_DOUBLE_big):
998 int n = BCO_INSTR_16;
999 xPushTaggedDouble(bcoConstDouble(bco,n));
1002 Case(i_PACK_DOUBLE):
1005 SSS; o = (StgClosure*)grabHpNonUpd(Dzh_sizeW); LLL;
1006 SET_HDR(o,Dzh_con_info,??);
1007 ASSIGN_DBL(&payloadWord(o,0),xPopTaggedDouble());
1009 fprintf(stderr,"\tBuilt ");
1010 printObj(stgCast(StgClosure*,o));
1012 xPushPtr(stgCast(StgPtr,o));
1015 Case(i_UNPACK_DOUBLE):
1017 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1018 /* ASSERT(isDoubleLike(con)); */
1019 xPushTaggedDouble(PK_DBL(&payloadWord(con,0)));
1024 StgStablePtr s = xTaggedStackStable(BCO_INSTR_8);
1025 xPushTaggedStable(s);
1028 Case(i_PACK_STABLE):
1031 SSS; o = (StgClosure*)grabHpNonUpd(Stablezh_sizeW); LLL;
1032 SET_HDR(o,StablePtr_con_info,??);
1033 payloadWord(o,0) = (W_)xPopTaggedStable();
1035 fprintf(stderr,"\tBuilt ");
1037 printObj(stgCast(StgClosure*,o));
1040 xPushPtr(stgCast(StgPtr,o));
1043 Case(i_UNPACK_STABLE):
1045 StgClosure* con = (StgClosure*)xStackPtr(0);
1046 /* ASSERT(isStableLike(con)); */
1047 xPushTaggedStable(payloadWord(con,0));
1055 SSS; p = enterBCO_primop1 ( i ); LLL;
1056 if (p) { obj = p; goto enterLoop; };
1061 int i, trc, pc_saved;
1064 trc = 12345678; /* Assume != any StgThreadReturnCode */
1069 p = enterBCO_primop2 ( i, &trc, &bco_tmp, cap,
1073 bciPtr = &(bcoInstr(bco,pc_saved));
1075 if (trc == 12345678) {
1076 /* we want to enter p */
1077 obj = p; goto enterLoop;
1079 /* trc is the the StgThreadReturnCode for
1081 RETURN((StgThreadReturnCode)trc);
1087 /* combined insns, created by peephole opt */
1090 int x = BCO_INSTR_8;
1091 int y = BCO_INSTR_8;
1092 ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
1093 /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
1100 xSetStackWord(x+y,xStackWord(x));
1110 p = xStackPtr(BCO_INSTR_8);
1112 p = xStackPtr(BCO_INSTR_8);
1119 xPushPtr(bcoConstPtr(bco,BCO_INSTR_8));
1120 xPushPtr(stgCast(StgPtr,&ret_bco_info));
1121 p = xStackPtr(BCO_INSTR_8);
1127 StgPtr retaddr = bcoConstPtr(bco,BCO_INSTR_8);
1128 StgPtr ptr = xStackPtr(BCO_INSTR_8);
1130 /* A shortcut. We're going to push the address of a
1131 return continuation, and then enter a variable, so
1132 that when the var is evaluated, we return to the
1133 continuation. The shortcut is: if the var is a
1134 constructor, don't bother to enter it. Instead,
1135 push the variable on the stack (since this is what
1136 the continuation expects) and jump directly to the
1139 if (get_itbl((StgClosure*)ptr)->type == CONSTR) {
1141 obj = (StgClosure*)retaddr;
1143 fprintf(stderr, "object to enter is a constructor -- "
1144 "jumping directly to return continuation\n" );
1149 /* This is the normal, non-short-cut route */
1151 xPushPtr(stgCast(StgPtr,&ret_bco_info));
1152 obj = (StgClosure*)ptr;
1157 Case(i_VAR_DOUBLE_big):
1158 Case(i_CONST_FLOAT_big):
1159 Case(i_VAR_FLOAT_big):
1160 Case(i_CONST_CHAR_big):
1161 Case(i_VAR_CHAR_big):
1162 Case(i_VAR_ADDR_big):
1163 Case(i_VAR_STABLE_big):
1164 Case(i_CONST_INTEGER_big):
1165 Case(i_VAR_INT_big):
1166 Case(i_VAR_WORD_big):
1167 Case(i_RETADDR_big):
1171 disInstr ( bco, PC );
1172 barf("\nUnrecognised instruction");
1176 barf("enterBCO: ran off end of loop");
1180 # undef LoopTopLabel
1186 /* ---------------------------------------------------- */
1187 /* End of the bytecode evaluator */
1188 /* ---------------------------------------------------- */
1192 StgBlockingQueue* bh;
1193 StgCAF* caf = (StgCAF*)obj;
1194 if (xSp - sizeofW(StgUpdateFrame) < xSpLim) {
1195 xPushCPtr(obj); /* code to restart with */
1196 RETURN(StackOverflow);
1198 SSS; bh = (StgBlockingQueue*)grabHpUpd(BLACKHOLE_sizeW()); LLL;
1199 SET_INFO(bh,&CAF_BLACKHOLE_info);
1200 bh->blocking_queue = EndTSOQueue;
1202 fprintf(stderr,"Created CAF_BLACKHOLE %p for CAF %p"
1203 " in evaluator\n",bh,caf));
1204 SET_INFO(caf,&CAF_ENTERED_info);
1205 caf->value = (StgClosure*)bh;
1207 SSS; newCAF_made_by_Hugs(caf); LLL;
1209 xPushUpdateFrame(bh,0);
1210 xSp -= sizeofW(StgUpdateFrame);
1216 StgCAF* caf = (StgCAF*)obj;
1217 obj = caf->value; /* it's just a fancy indirection */
1223 case SE_CAF_BLACKHOLE:
1225 /* Let the scheduler figure out what to do :-) */
1226 cap->rCurrentTSO->what_next = ThreadEnterGHC;
1228 RETURN(ThreadYielding);
1232 StgAP_UPD* ap = stgCast(StgAP_UPD*,obj);
1234 if (xSp - (i + sizeofW(StgUpdateFrame)) < xSpLim) {
1235 xPushCPtr(obj); /* code to restart with */
1236 RETURN(StackOverflow);
1238 /* ToDo: look for xSp==xSu && stackInt(0) == UPD_FRAME
1239 and insert an indirection immediately */
1240 xPushUpdateFrame(ap,0);
1241 xSp -= sizeofW(StgUpdateFrame);
1243 xPushWord(payloadWord(ap,i));
1246 #ifdef EAGER_BLACKHOLING
1247 #warn LAZY_BLACKHOLING is default for StgHugs
1248 #error Dont know if EAGER_BLACKHOLING works in StgHugs
1250 /* superfluous - but makes debugging easier */
1251 StgBlackHole* bh = stgCast(StgBlackHole*,ap);
1252 SET_INFO(bh,&BLACKHOLE_info);
1253 bh->blocking_queue = EndTSOQueue;
1255 fprintf(stderr,"Eagerly blackholed AP_UPD %p in evaluator\n",bh));
1258 #endif /* EAGER_BLACKHOLING */
1263 StgPAP* pap = stgCast(StgPAP*,obj);
1264 int i = pap->n_args; /* ToDo: stack check */
1265 /* ToDo: if PAP is in whnf, we can update any update frames
1269 xPushWord(payloadWord(pap,i));
1276 obj = stgCast(StgInd*,obj)->indirectee;
1281 obj = stgCast(StgIndOldGen*,obj)->indirectee;
1290 case CONSTR_INTLIKE:
1291 case CONSTR_CHARLIKE:
1293 case CONSTR_NOCAF_STATIC:
1296 switch (get_itbl(stgCast(StgClosure*,xSp))->type) {
1298 SSS; PopCatchFrame(); LLL;
1301 xPopUpdateFrame(obj);
1304 SSS; PopSeqFrame(); LLL;
1308 ASSERT(xSp==(P_)xSu);
1311 fprintf(stderr, "hit a STOP_FRAME\n");
1313 fprintf(stderr,"xSp = %p\txSu = %p\n", xSp, xSu);
1314 printStack(xSp,cap->rCurrentTSO->stack
1315 + cap->rCurrentTSO->stack_size,xSu);
1318 cap->rCurrentTSO->what_next = ThreadComplete;
1319 SSS; PopStopFrame(obj); LLL;
1321 RETURN(ThreadFinished);
1331 /* was: goto enterLoop;
1332 But we know that obj must be a bco now, so jump directly.
1335 case RET_SMALL: /* return to GHC */
1339 cap->rCurrentTSO->what_next = ThreadEnterGHC;
1341 RETURN(ThreadYielding);
1343 belch("entered CONSTR with invalid continuation on stack");
1346 printObj(stgCast(StgClosure*,xSp));
1349 barf("bailing out");
1356 //fprintf(stderr, "enterCountI = %d\n", enterCountI);
1357 //fprintf(stderr, "entering unknown closure -- yielding to sched\n");
1360 cap->rCurrentTSO->what_next = ThreadEnterGHC;
1361 xPushCPtr(obj); /* code to restart with */
1362 RETURN(ThreadYielding);
1365 barf("Ran off the end of enter - yoiks");
1382 #undef xSetStackWord
1385 #undef xPushTaggedInt
1386 #undef xPopTaggedInt
1387 #undef xTaggedStackInt
1388 #undef xPushTaggedWord
1389 #undef xPopTaggedWord
1390 #undef xTaggedStackWord
1391 #undef xPushTaggedAddr
1392 #undef xTaggedStackAddr
1393 #undef xPopTaggedAddr
1394 #undef xPushTaggedStable
1395 #undef xTaggedStackStable
1396 #undef xPopTaggedStable
1397 #undef xPushTaggedChar
1398 #undef xTaggedStackChar
1399 #undef xPopTaggedChar
1400 #undef xPushTaggedFloat
1401 #undef xTaggedStackFloat
1402 #undef xPopTaggedFloat
1403 #undef xPushTaggedDouble
1404 #undef xTaggedStackDouble
1405 #undef xPopTaggedDouble
1406 #undef xPopUpdateFrame
1407 #undef xPushUpdateFrame
1410 /* --------------------------------------------------------------------------
1411 * Supporting routines for primops
1412 * ------------------------------------------------------------------------*/
1414 static inline void PushTag ( StackTag t )
1416 inline void PushPtr ( StgPtr x )
1417 { *(--stgCast(StgPtr*,gSp)) = x; }
1418 static inline void PushCPtr ( StgClosure* x )
1419 { *(--stgCast(StgClosure**,gSp)) = x; }
1420 static inline void PushInt ( StgInt x )
1421 { *(--stgCast(StgInt*,gSp)) = x; }
1422 static inline void PushWord ( StgWord x )
1423 { *(--stgCast(StgWord*,gSp)) = x; }
1426 static inline void checkTag ( StackTag t1, StackTag t2 )
1427 { ASSERT(t1 == t2);}
1428 static inline void PopTag ( StackTag t )
1429 { checkTag(t,*(gSp++)); }
1430 inline StgPtr PopPtr ( void )
1431 { return *stgCast(StgPtr*,gSp)++; }
1432 static inline StgClosure* PopCPtr ( void )
1433 { return *stgCast(StgClosure**,gSp)++; }
1434 static inline StgInt PopInt ( void )
1435 { return *stgCast(StgInt*,gSp)++; }
1436 static inline StgWord PopWord ( void )
1437 { return *stgCast(StgWord*,gSp)++; }
1439 static inline StgPtr stackPtr ( StgStackOffset i )
1440 { return *stgCast(StgPtr*, gSp+i); }
1441 static inline StgInt stackInt ( StgStackOffset i )
1442 { return *stgCast(StgInt*, gSp+i); }
1443 static inline StgWord stackWord ( StgStackOffset i )
1444 { return *stgCast(StgWord*,gSp+i); }
1446 static inline void setStackWord ( StgStackOffset i, StgWord w )
1449 static inline void PushTaggedRealWorld( void )
1450 { PushTag(REALWORLD_TAG); }
1451 inline void PushTaggedInt ( StgInt x )
1452 { gSp -= sizeofW(StgInt); *gSp = x; PushTag(INT_TAG); }
1453 inline void PushTaggedWord ( StgWord x )
1454 { gSp -= sizeofW(StgWord); *gSp = x; PushTag(WORD_TAG); }
1455 inline void PushTaggedAddr ( StgAddr x )
1456 { gSp -= sizeofW(StgAddr); *gSp = (W_)x; PushTag(ADDR_TAG); }
1457 inline void PushTaggedChar ( StgChar x )
1458 { gSp -= sizeofW(StgChar); *gSp = stgCast(StgWord,x); PushTag(CHAR_TAG); }
1459 inline void PushTaggedFloat ( StgFloat x )
1460 { gSp -= sizeofW(StgFloat); ASSIGN_FLT(gSp,x); PushTag(FLOAT_TAG); }
1461 inline void PushTaggedDouble ( StgDouble x )
1462 { gSp -= sizeofW(StgDouble); ASSIGN_DBL(gSp,x); PushTag(DOUBLE_TAG); }
1463 inline void PushTaggedStablePtr ( StgStablePtr x )
1464 { gSp -= sizeofW(StgStablePtr); *gSp = (W_)x; PushTag(STABLE_TAG); }
1465 static inline void PushTaggedBool ( int x )
1466 { PushTaggedInt(x); }
1470 static inline void PopTaggedRealWorld ( void )
1471 { PopTag(REALWORLD_TAG); }
1472 inline StgInt PopTaggedInt ( void )
1473 { StgInt r; PopTag(INT_TAG); r = *stgCast(StgInt*, gSp);
1474 gSp += sizeofW(StgInt); return r;}
1475 inline StgWord PopTaggedWord ( void )
1476 { StgWord r; PopTag(WORD_TAG); r = *stgCast(StgWord*, gSp);
1477 gSp += sizeofW(StgWord); return r;}
1478 inline StgAddr PopTaggedAddr ( void )
1479 { StgAddr r; PopTag(ADDR_TAG); r = *stgCast(StgAddr*, gSp);
1480 gSp += sizeofW(StgAddr); return r;}
1481 inline StgChar PopTaggedChar ( void )
1482 { StgChar r; PopTag(CHAR_TAG); r = stgCast(StgChar, *gSp);
1483 gSp += sizeofW(StgChar); return r;}
1484 inline StgFloat PopTaggedFloat ( void )
1485 { StgFloat r; PopTag(FLOAT_TAG); r = PK_FLT(gSp);
1486 gSp += sizeofW(StgFloat); return r;}
1487 inline StgDouble PopTaggedDouble ( void )
1488 { StgDouble r; PopTag(DOUBLE_TAG); r = PK_DBL(gSp);
1489 gSp += sizeofW(StgDouble); return r;}
1490 inline StgStablePtr PopTaggedStablePtr ( void )
1491 { StgStablePtr r; PopTag(STABLE_TAG); r = *stgCast(StgStablePtr*, gSp);
1492 gSp += sizeofW(StgStablePtr); return r;}
1496 static inline StgInt taggedStackInt ( StgStackOffset i )
1497 { checkTag(INT_TAG,gSp[i]); return *stgCast(StgInt*, gSp+1+i); }
1498 static inline StgWord taggedStackWord ( StgStackOffset i )
1499 { checkTag(WORD_TAG,gSp[i]); return *stgCast(StgWord*, gSp+1+i); }
1500 static inline StgAddr taggedStackAddr ( StgStackOffset i )
1501 { checkTag(ADDR_TAG,gSp[i]); return *stgCast(StgAddr*, gSp+1+i); }
1502 static inline StgChar taggedStackChar ( StgStackOffset i )
1503 { checkTag(CHAR_TAG,gSp[i]); return stgCast(StgChar, *(gSp+1+i)) ; }
1504 static inline StgFloat taggedStackFloat ( StgStackOffset i )
1505 { checkTag(FLOAT_TAG,gSp[i]); return PK_FLT(gSp+1+i); }
1506 static inline StgDouble taggedStackDouble ( StgStackOffset i )
1507 { checkTag(DOUBLE_TAG,gSp[i]); return PK_DBL(gSp+1+i); }
1508 static inline StgStablePtr taggedStackStable ( StgStackOffset i )
1509 { checkTag(STABLE_TAG,gSp[i]); return *stgCast(StgStablePtr*, gSp+1+i); }
1512 /* --------------------------------------------------------------------------
1515 * Should we allocate from a nursery or use the
1516 * doYouWantToGC/allocate interface? We'd already implemented a
1517 * nursery-style scheme when the doYouWantToGC/allocate interface
1519 * One reason to prefer the doYouWantToGC/allocate interface is to
1520 * support operations which allocate an unknown amount in the heap
1521 * (array ops, gmp ops, etc)
1522 * ------------------------------------------------------------------------*/
1524 static inline StgPtr grabHpUpd( nat size )
1526 ASSERT( size >= MIN_UPD_SIZE + sizeofW(StgHeader) );
1527 return allocate(size);
1530 static inline StgPtr grabHpNonUpd( nat size )
1532 ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
1533 return allocate(size);
1536 /* --------------------------------------------------------------------------
1537 * Manipulate "update frame" list:
1538 * o Update frames (based on stg_do_update and friends in Updates.hc)
1539 * o Error handling/catching (based on catchzh_fast and friends in Prims.hc)
1540 * o Seq frames (based on seq_frame_entry in Prims.hc)
1542 * ------------------------------------------------------------------------*/
1544 static inline void PopUpdateFrame ( StgClosure* obj )
1546 /* NB: doesn't assume that gSp == gSu */
1548 fprintf(stderr, "Updating ");
1549 printPtr(stgCast(StgPtr,gSu->updatee));
1550 fprintf(stderr, " with ");
1552 fprintf(stderr,"gSp = %p\tgSu = %p\n\n", gSp, gSu);
1554 #ifdef EAGER_BLACKHOLING
1555 #warn LAZY_BLACKHOLING is default for StgHugs
1556 #error Dont know if EAGER_BLACKHOLING works in StgHugs
1557 ASSERT(get_itbl(gSu->updatee)->type == BLACKHOLE
1558 || get_itbl(gSu->updatee)->type == SE_BLACKHOLE
1559 || get_itbl(gSu->updatee)->type == CAF_BLACKHOLE
1560 || get_itbl(gSu->updatee)->type == SE_CAF_BLACKHOLE
1562 #endif /* EAGER_BLACKHOLING */
1563 UPD_IND(gSu->updatee,obj);
1564 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgUpdateFrame);
1568 static inline void PopStopFrame ( StgClosure* obj )
1570 /* Move gSu just off the end of the stack, we're about to gSpam the
1571 * STOP_FRAME with the return value.
1573 gSu = stgCast(StgUpdateFrame*,gSp+1);
1574 *stgCast(StgClosure**,gSp) = obj;
1577 static inline void PushCatchFrame ( StgClosure* handler )
1580 /* ToDo: stack check! */
1581 gSp -= sizeofW(StgCatchFrame);
1582 fp = stgCast(StgCatchFrame*,gSp);
1583 SET_HDR(fp,(StgInfoTable*)&catch_frame_info,CCCS);
1584 fp->handler = handler;
1586 gSu = stgCast(StgUpdateFrame*,fp);
1589 static inline void PopCatchFrame ( void )
1591 /* NB: doesn't assume that gSp == gSu */
1592 /* fprintf(stderr,"Popping catch frame\n"); */
1593 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgCatchFrame);
1594 gSu = stgCast(StgCatchFrame*,gSu)->link;
1597 static inline void PushSeqFrame ( void )
1600 /* ToDo: stack check! */
1601 gSp -= sizeofW(StgSeqFrame);
1602 fp = stgCast(StgSeqFrame*,gSp);
1603 SET_HDR(fp,(StgInfoTable*)&seq_frame_info,CCCS);
1605 gSu = stgCast(StgUpdateFrame*,fp);
1608 static inline void PopSeqFrame ( void )
1610 /* NB: doesn't assume that gSp == gSu */
1611 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgSeqFrame);
1612 gSu = stgCast(StgSeqFrame*,gSu)->link;
1615 static inline StgClosure* raiseAnError ( StgClosure* exception )
1617 /* This closure represents the expression 'primRaise E' where E
1618 * is the exception raised (:: Exception).
1619 * It is used to overwrite all the
1620 * thunks which are currently under evaluation.
1622 HaskellObj primRaiseClosure
1623 = getHugs_BCO_cptr_for("primRaise");
1624 HaskellObj reraiseClosure
1625 = rts_apply ( primRaiseClosure, exception );
1628 switch (get_itbl(gSu)->type) {
1630 UPD_IND(gSu->updatee,reraiseClosure);
1631 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgUpdateFrame);
1637 case CATCH_FRAME: /* found it! */
1639 StgCatchFrame* fp = stgCast(StgCatchFrame*,gSu);
1640 StgClosure *handler = fp->handler;
1642 gSp += sizeofW(StgCatchFrame); /* Pop */
1643 PushCPtr(exception);
1647 barf("raiseError: uncaught exception: STOP_FRAME");
1649 barf("raiseError: weird activation record");
1655 static StgClosure* makeErrorCall ( const char* msg )
1657 /* Note! the msg string should be allocated in a
1658 place which will not get freed -- preferably
1659 read-only data of the program. That's because
1660 the thunk we build here may linger indefinitely.
1661 (thinks: probably not so, but anyway ...)
1664 = getHugs_BCO_cptr_for("error");
1666 = getHugs_BCO_cptr_for("hugsprimUnpackString");
1668 = rts_apply ( unpack, rts_mkAddr ( (void*)msg ) );
1670 = rts_apply ( error, thunk );
1672 (StgClosure*) thunk;
1675 #define raiseIndex(where) makeErrorCall("Array index out of range in " where)
1676 #define raiseDiv0(where) makeErrorCall("Division by zero in " where)
1678 /* --------------------------------------------------------------------------
1680 * ------------------------------------------------------------------------*/
1682 #define OP_CC_B(e) \
1684 unsigned char x = PopTaggedChar(); \
1685 unsigned char y = PopTaggedChar(); \
1686 PushTaggedBool(e); \
1691 unsigned char x = PopTaggedChar(); \
1700 #define OP_IW_I(e) \
1702 StgInt x = PopTaggedInt(); \
1703 StgWord y = PopTaggedWord(); \
1707 #define OP_II_I(e) \
1709 StgInt x = PopTaggedInt(); \
1710 StgInt y = PopTaggedInt(); \
1714 #define OP_II_B(e) \
1716 StgInt x = PopTaggedInt(); \
1717 StgInt y = PopTaggedInt(); \
1718 PushTaggedBool(e); \
1723 PushTaggedAddr(e); \
1728 StgInt x = PopTaggedInt(); \
1729 PushTaggedAddr(e); \
1734 StgInt x = PopTaggedInt(); \
1740 PushTaggedChar(e); \
1745 StgInt x = PopTaggedInt(); \
1746 PushTaggedChar(e); \
1751 PushTaggedWord(e); \
1756 StgInt x = PopTaggedInt(); \
1757 PushTaggedWord(e); \
1762 StgInt x = PopTaggedInt(); \
1763 PushTaggedStablePtr(e); \
1768 PushTaggedFloat(e); \
1773 StgInt x = PopTaggedInt(); \
1774 PushTaggedFloat(e); \
1779 PushTaggedDouble(e); \
1784 StgInt x = PopTaggedInt(); \
1785 PushTaggedDouble(e); \
1788 #define OP_WW_B(e) \
1790 StgWord x = PopTaggedWord(); \
1791 StgWord y = PopTaggedWord(); \
1792 PushTaggedBool(e); \
1795 #define OP_WW_W(e) \
1797 StgWord x = PopTaggedWord(); \
1798 StgWord y = PopTaggedWord(); \
1799 PushTaggedWord(e); \
1804 StgWord x = PopTaggedWord(); \
1810 StgStablePtr x = PopTaggedStablePtr(); \
1816 StgWord x = PopTaggedWord(); \
1817 PushTaggedWord(e); \
1820 #define OP_AA_B(e) \
1822 StgAddr x = PopTaggedAddr(); \
1823 StgAddr y = PopTaggedAddr(); \
1824 PushTaggedBool(e); \
1828 StgAddr x = PopTaggedAddr(); \
1831 #define OP_AI_C(s) \
1833 StgAddr x = PopTaggedAddr(); \
1834 int y = PopTaggedInt(); \
1837 PushTaggedChar(r); \
1839 #define OP_AI_I(s) \
1841 StgAddr x = PopTaggedAddr(); \
1842 int y = PopTaggedInt(); \
1847 #define OP_AI_A(s) \
1849 StgAddr x = PopTaggedAddr(); \
1850 int y = PopTaggedInt(); \
1853 PushTaggedAddr(s); \
1855 #define OP_AI_F(s) \
1857 StgAddr x = PopTaggedAddr(); \
1858 int y = PopTaggedInt(); \
1861 PushTaggedFloat(r); \
1863 #define OP_AI_D(s) \
1865 StgAddr x = PopTaggedAddr(); \
1866 int y = PopTaggedInt(); \
1869 PushTaggedDouble(r); \
1871 #define OP_AI_s(s) \
1873 StgAddr x = PopTaggedAddr(); \
1874 int y = PopTaggedInt(); \
1877 PushTaggedStablePtr(r); \
1879 #define OP_AIC_(s) \
1881 StgAddr x = PopTaggedAddr(); \
1882 int y = PopTaggedInt(); \
1883 StgChar z = PopTaggedChar(); \
1886 #define OP_AII_(s) \
1888 StgAddr x = PopTaggedAddr(); \
1889 int y = PopTaggedInt(); \
1890 StgInt z = PopTaggedInt(); \
1893 #define OP_AIA_(s) \
1895 StgAddr x = PopTaggedAddr(); \
1896 int y = PopTaggedInt(); \
1897 StgAddr z = PopTaggedAddr(); \
1900 #define OP_AIF_(s) \
1902 StgAddr x = PopTaggedAddr(); \
1903 int y = PopTaggedInt(); \
1904 StgFloat z = PopTaggedFloat(); \
1907 #define OP_AID_(s) \
1909 StgAddr x = PopTaggedAddr(); \
1910 int y = PopTaggedInt(); \
1911 StgDouble z = PopTaggedDouble(); \
1914 #define OP_AIs_(s) \
1916 StgAddr x = PopTaggedAddr(); \
1917 int y = PopTaggedInt(); \
1918 StgStablePtr z = PopTaggedStablePtr(); \
1923 #define OP_FF_B(e) \
1925 StgFloat x = PopTaggedFloat(); \
1926 StgFloat y = PopTaggedFloat(); \
1927 PushTaggedBool(e); \
1930 #define OP_FF_F(e) \
1932 StgFloat x = PopTaggedFloat(); \
1933 StgFloat y = PopTaggedFloat(); \
1934 PushTaggedFloat(e); \
1939 StgFloat x = PopTaggedFloat(); \
1940 PushTaggedFloat(e); \
1945 StgFloat x = PopTaggedFloat(); \
1946 PushTaggedBool(e); \
1951 StgFloat x = PopTaggedFloat(); \
1957 StgFloat x = PopTaggedFloat(); \
1958 PushTaggedDouble(e); \
1961 #define OP_DD_B(e) \
1963 StgDouble x = PopTaggedDouble(); \
1964 StgDouble y = PopTaggedDouble(); \
1965 PushTaggedBool(e); \
1968 #define OP_DD_D(e) \
1970 StgDouble x = PopTaggedDouble(); \
1971 StgDouble y = PopTaggedDouble(); \
1972 PushTaggedDouble(e); \
1977 StgDouble x = PopTaggedDouble(); \
1978 PushTaggedBool(e); \
1983 StgDouble x = PopTaggedDouble(); \
1984 PushTaggedDouble(e); \
1989 StgDouble x = PopTaggedDouble(); \
1995 StgDouble x = PopTaggedDouble(); \
1996 PushTaggedFloat(e); \
2000 StgPtr CreateByteArrayToHoldInteger ( int nbytes )
2002 StgWord words = (nbytes+sizeof(W_)-1)/sizeof(W_);
2003 StgWord size = sizeofW(StgArrWords) + words;
2004 StgArrWords* arr = (StgArrWords*)allocate(size);
2005 SET_HDR(arr,&ARR_WORDS_info,CCCS);
2007 ASSERT((W_)nbytes <= arr->words * sizeof(W_));
2010 for (i = 0; i < words; ++i) {
2011 arr->payload[i] = 0xdeadbeef;
2013 { B* b = (B*) &(arr->payload[0]);
2014 b->used = b->sign = 0;
2020 B* IntegerInsideByteArray ( StgPtr arr0 )
2023 StgArrWords* arr = (StgArrWords*)arr0;
2024 ASSERT(GET_INFO(arr) == &ARR_WORDS_info);
2025 b = (B*) &(arr->payload[0]);
2029 void SloppifyIntegerEnd ( StgPtr arr0 )
2031 StgArrWords* arr = (StgArrWords*)arr0;
2032 B* b = (B*) & (arr->payload[0]);
2033 I_ nwunused = arr->words - sizeofW(B) - (b->used+sizeof(W_)-1)/sizeof(W_);
2034 if (nwunused >= ((I_)sizeofW(StgArrWords))) {
2036 b->size -= nwunused * sizeof(W_);
2037 if (b->size < b->used) b->size = b->used;
2040 arr->words -= nwunused;
2041 slop = (StgArrWords*)&(arr->payload[arr->words]);
2042 SET_HDR(slop,&ARR_WORDS_info,CCCS);
2043 slop->words = nwunused - sizeofW(StgArrWords);
2044 ASSERT( &(slop->payload[slop->words]) ==
2045 &(arr->payload[arr->words + nwunused]) );
2049 #define OP_Z_Z(op) \
2051 B* x = IntegerInsideByteArray(PopPtr()); \
2052 int n = mycat2(size_,op)(x); \
2053 StgPtr p = CreateByteArrayToHoldInteger(n); \
2054 mycat2(do_,op)(x,n,IntegerInsideByteArray(p)); \
2055 SloppifyIntegerEnd(p); \
2058 #define OP_ZZ_Z(op) \
2060 B* x = IntegerInsideByteArray(PopPtr()); \
2061 B* y = IntegerInsideByteArray(PopPtr()); \
2062 int n = mycat2(size_,op)(x,y); \
2063 StgPtr p = CreateByteArrayToHoldInteger(n); \
2064 mycat2(do_,op)(x,y,n,IntegerInsideByteArray(p)); \
2065 SloppifyIntegerEnd(p); \
2072 #define HEADER_mI(ty,where) \
2073 StgArrWords* x = stgCast(StgArrWords*,PopPtr()); \
2074 nat i = PopTaggedInt(); \
2075 if (i * sizeof(ty) + (sizeof(ty)) > sizeof(StgWord) * x->words) { \
2076 return (raiseIndex(where)); \
2078 #define OP_mI_ty(ty,where,s) \
2080 HEADER_mI(mycat2(Stg,ty),where) \
2081 { mycat2(Stg,ty) r; \
2083 mycat2(PushTagged,ty)(r); \
2086 #define OP_mIty_(ty,where,s) \
2088 HEADER_mI(mycat2(Stg,ty),where) \
2090 mycat2(Stg,ty) z = mycat2(PopTagged,ty)(); \
2096 __attribute__ ((unused))
2097 static void myStackCheck ( Capability* cap )
2099 /* fprintf(stderr, "myStackCheck\n"); */
2100 if (!(gSpLim <= gSp && gSp <= stgCast(StgPtr,gSu))) {
2101 fprintf(stderr, "myStackCheck: invalid initial gSp/gSu \n" );
2105 if (!( (P_)gSu >= (P_)cap->rCurrentTSO->stack
2107 (P_)gSu <= (P_)(cap->rCurrentTSO->stack
2108 + cap->rCurrentTSO->stack_size))) {
2109 fprintf ( stderr, "myStackCheck: gSu out of stack\n" );
2112 switch (get_itbl(stgCast(StgClosure*,gSu))->type) {
2114 gSu = (StgUpdateFrame*) ((StgCatchFrame*)(gSu))->link;
2117 gSu = (StgUpdateFrame*) ((StgUpdateFrame*)(gSu))->link;
2120 gSu = (StgUpdateFrame*) ((StgSeqFrame*)(gSu))->link;
2125 fprintf(stderr, "myStackCheck: invalid activation record\n"); assert(0);
2132 /* --------------------------------------------------------------------------
2133 * Primop stuff for bytecode interpreter
2134 * ------------------------------------------------------------------------*/
2136 /* Returns & of the next thing to enter (if throwing an exception),
2137 or NULL in the normal case.
2139 static void* enterBCO_primop1 ( int primop1code )
2142 barf("enterBCO_primop1 in combined mode");
2144 switch (primop1code) {
2145 case i_pushseqframe:
2147 StgClosure* c = PopCPtr();
2152 case i_pushcatchframe:
2154 StgClosure* e = PopCPtr();
2155 StgClosure* h = PopCPtr();
2161 case i_gtChar: OP_CC_B(x>y); break;
2162 case i_geChar: OP_CC_B(x>=y); break;
2163 case i_eqChar: OP_CC_B(x==y); break;
2164 case i_neChar: OP_CC_B(x!=y); break;
2165 case i_ltChar: OP_CC_B(x<y); break;
2166 case i_leChar: OP_CC_B(x<=y); break;
2167 case i_charToInt: OP_C_I(x); break;
2168 case i_intToChar: OP_I_C(x); break;
2170 case i_gtInt: OP_II_B(x>y); break;
2171 case i_geInt: OP_II_B(x>=y); break;
2172 case i_eqInt: OP_II_B(x==y); break;
2173 case i_neInt: OP_II_B(x!=y); break;
2174 case i_ltInt: OP_II_B(x<y); break;
2175 case i_leInt: OP_II_B(x<=y); break;
2176 case i_minInt: OP__I(INT_MIN); break;
2177 case i_maxInt: OP__I(INT_MAX); break;
2178 case i_plusInt: OP_II_I(x+y); break;
2179 case i_minusInt: OP_II_I(x-y); break;
2180 case i_timesInt: OP_II_I(x*y); break;
2183 int x = PopTaggedInt();
2184 int y = PopTaggedInt();
2186 return (raiseDiv0("quotInt"));
2188 /* ToDo: protect against minInt / -1 errors
2189 * (repeat for all other division primops) */
2195 int x = PopTaggedInt();
2196 int y = PopTaggedInt();
2198 return (raiseDiv0("remInt"));
2205 StgInt x = PopTaggedInt();
2206 StgInt y = PopTaggedInt();
2208 return (raiseDiv0("quotRemInt"));
2210 PushTaggedInt(x%y); /* last result */
2211 PushTaggedInt(x/y); /* first result */
2214 case i_negateInt: OP_I_I(-x); break;
2216 case i_andInt: OP_II_I(x&y); break;
2217 case i_orInt: OP_II_I(x|y); break;
2218 case i_xorInt: OP_II_I(x^y); break;
2219 case i_notInt: OP_I_I(~x); break;
2220 case i_shiftLInt: OP_II_I(x<<y); break;
2221 case i_shiftRAInt: OP_II_I(x>>y); break; /* ToDo */
2222 case i_shiftRLInt: OP_II_I(x>>y); break; /* ToDo */
2224 case i_gtWord: OP_WW_B(x>y); break;
2225 case i_geWord: OP_WW_B(x>=y); break;
2226 case i_eqWord: OP_WW_B(x==y); break;
2227 case i_neWord: OP_WW_B(x!=y); break;
2228 case i_ltWord: OP_WW_B(x<y); break;
2229 case i_leWord: OP_WW_B(x<=y); break;
2230 case i_minWord: OP__W(0); break;
2231 case i_maxWord: OP__W(UINT_MAX); break;
2232 case i_plusWord: OP_WW_W(x+y); break;
2233 case i_minusWord: OP_WW_W(x-y); break;
2234 case i_timesWord: OP_WW_W(x*y); break;
2237 StgWord x = PopTaggedWord();
2238 StgWord y = PopTaggedWord();
2240 return (raiseDiv0("quotWord"));
2242 PushTaggedWord(x/y);
2247 StgWord x = PopTaggedWord();
2248 StgWord y = PopTaggedWord();
2250 return (raiseDiv0("remWord"));
2252 PushTaggedWord(x%y);
2257 StgWord x = PopTaggedWord();
2258 StgWord y = PopTaggedWord();
2260 return (raiseDiv0("quotRemWord"));
2262 PushTaggedWord(x%y); /* last result */
2263 PushTaggedWord(x/y); /* first result */
2266 case i_negateWord: OP_W_W(-x); break;
2267 case i_andWord: OP_WW_W(x&y); break;
2268 case i_orWord: OP_WW_W(x|y); break;
2269 case i_xorWord: OP_WW_W(x^y); break;
2270 case i_notWord: OP_W_W(~x); break;
2271 case i_shiftLWord: OP_WW_W(x<<y); break;
2272 case i_shiftRAWord: OP_WW_W(x>>y); break; /* ToDo */
2273 case i_shiftRLWord: OP_WW_W(x>>y); break; /* ToDo */
2274 case i_intToWord: OP_I_W(x); break;
2275 case i_wordToInt: OP_W_I(x); break;
2277 case i_gtAddr: OP_AA_B(x>y); break;
2278 case i_geAddr: OP_AA_B(x>=y); break;
2279 case i_eqAddr: OP_AA_B(x==y); break;
2280 case i_neAddr: OP_AA_B(x!=y); break;
2281 case i_ltAddr: OP_AA_B(x<y); break;
2282 case i_leAddr: OP_AA_B(x<=y); break;
2283 case i_intToAddr: OP_I_A((StgAddr)x); break; /* ToDo */
2284 case i_addrToInt: OP_A_I((StgInt)x); break; /* ToDo */
2286 case i_intToStable: OP_I_s((StgStablePtr)x); break;
2287 case i_stableToInt: OP_s_I((W_)x); break;
2289 case i_indexCharOffAddr: OP_AI_C(indexCharOffAddrzh(r,x,y)); break;
2290 case i_readCharOffAddr: OP_AI_C(indexCharOffAddrzh(r,x,y)); break;
2291 case i_writeCharOffAddr: OP_AIC_(writeCharOffAddrzh(x,y,z)); break;
2293 case i_indexIntOffAddr: OP_AI_I(indexIntOffAddrzh(r,x,y)); break;
2294 case i_readIntOffAddr: OP_AI_I(indexIntOffAddrzh(r,x,y)); break;
2295 case i_writeIntOffAddr: OP_AII_(writeIntOffAddrzh(x,y,z)); break;
2297 case i_indexAddrOffAddr: OP_AI_A(indexAddrOffAddrzh(r,x,y)); break;
2298 case i_readAddrOffAddr: OP_AI_A(indexAddrOffAddrzh(r,x,y)); break;
2299 case i_writeAddrOffAddr: OP_AIA_(writeAddrOffAddrzh(x,y,z)); break;
2301 case i_indexFloatOffAddr: OP_AI_F(indexFloatOffAddrzh(r,x,y)); break;
2302 case i_readFloatOffAddr: OP_AI_F(indexFloatOffAddrzh(r,x,y)); break;
2303 case i_writeFloatOffAddr: OP_AIF_(writeFloatOffAddrzh(x,y,z)); break;
2305 case i_indexDoubleOffAddr: OP_AI_D(indexDoubleOffAddrzh(r,x,y)); break;
2306 case i_readDoubleOffAddr: OP_AI_D(indexDoubleOffAddrzh(r,x,y)); break;
2307 case i_writeDoubleOffAddr: OP_AID_(writeDoubleOffAddrzh(x,y,z)); break;
2309 case i_indexStableOffAddr: OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break;
2310 case i_readStableOffAddr: OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break;
2311 case i_writeStableOffAddr: OP_AIs_(writeStablePtrOffAddrzh(x,y,z)); break;
2313 case i_compareInteger:
2315 B* x = IntegerInsideByteArray(PopPtr());
2316 B* y = IntegerInsideByteArray(PopPtr());
2317 StgInt r = do_cmp(x,y);
2318 PushTaggedInt(r<0 ? -1 : (r>0 ? 1 : 0));
2321 case i_negateInteger: OP_Z_Z(neg); break;
2322 case i_plusInteger: OP_ZZ_Z(add); break;
2323 case i_minusInteger: OP_ZZ_Z(sub); break;
2324 case i_timesInteger: OP_ZZ_Z(mul); break;
2325 case i_quotRemInteger:
2327 B* x = IntegerInsideByteArray(PopPtr());
2328 B* y = IntegerInsideByteArray(PopPtr());
2329 int n = size_qrm(x,y);
2330 StgPtr q = CreateByteArrayToHoldInteger(n);
2331 StgPtr r = CreateByteArrayToHoldInteger(n);
2332 if (do_getsign(y)==0)
2333 return (raiseDiv0("quotRemInteger"));
2334 do_qrm(x,y,n,IntegerInsideByteArray(q),
2335 IntegerInsideByteArray(r));
2336 SloppifyIntegerEnd(q);
2337 SloppifyIntegerEnd(r);
2342 case i_intToInteger:
2344 int n = size_fromInt();
2345 StgPtr p = CreateByteArrayToHoldInteger(n);
2346 do_fromInt( PopTaggedInt(), n, IntegerInsideByteArray(p));
2350 case i_wordToInteger:
2352 int n = size_fromWord();
2353 StgPtr p = CreateByteArrayToHoldInteger(n);
2354 do_fromWord( PopTaggedWord(), n, IntegerInsideByteArray(p));
2358 case i_integerToInt: PushTaggedInt(do_toInt(
2359 IntegerInsideByteArray(PopPtr())
2363 case i_integerToWord: PushTaggedWord(do_toWord(
2364 IntegerInsideByteArray(PopPtr())
2368 case i_integerToFloat: PushTaggedFloat(do_toFloat(
2369 IntegerInsideByteArray(PopPtr())
2373 case i_integerToDouble: PushTaggedDouble(do_toDouble(
2374 IntegerInsideByteArray(PopPtr())
2378 case i_gtFloat: OP_FF_B(x>y); break;
2379 case i_geFloat: OP_FF_B(x>=y); break;
2380 case i_eqFloat: OP_FF_B(x==y); break;
2381 case i_neFloat: OP_FF_B(x!=y); break;
2382 case i_ltFloat: OP_FF_B(x<y); break;
2383 case i_leFloat: OP_FF_B(x<=y); break;
2384 case i_minFloat: OP__F(FLT_MIN); break;
2385 case i_maxFloat: OP__F(FLT_MAX); break;
2386 case i_radixFloat: OP__I(FLT_RADIX); break;
2387 case i_digitsFloat: OP__I(FLT_MANT_DIG); break;
2388 case i_minExpFloat: OP__I(FLT_MIN_EXP); break;
2389 case i_maxExpFloat: OP__I(FLT_MAX_EXP); break;
2390 case i_plusFloat: OP_FF_F(x+y); break;
2391 case i_minusFloat: OP_FF_F(x-y); break;
2392 case i_timesFloat: OP_FF_F(x*y); break;
2395 StgFloat x = PopTaggedFloat();
2396 StgFloat y = PopTaggedFloat();
2397 PushTaggedFloat(x/y);
2400 case i_negateFloat: OP_F_F(-x); break;
2401 case i_floatToInt: OP_F_I(x); break;
2402 case i_intToFloat: OP_I_F(x); break;
2403 case i_expFloat: OP_F_F(exp(x)); break;
2404 case i_logFloat: OP_F_F(log(x)); break;
2405 case i_sqrtFloat: OP_F_F(sqrt(x)); break;
2406 case i_sinFloat: OP_F_F(sin(x)); break;
2407 case i_cosFloat: OP_F_F(cos(x)); break;
2408 case i_tanFloat: OP_F_F(tan(x)); break;
2409 case i_asinFloat: OP_F_F(asin(x)); break;
2410 case i_acosFloat: OP_F_F(acos(x)); break;
2411 case i_atanFloat: OP_F_F(atan(x)); break;
2412 case i_sinhFloat: OP_F_F(sinh(x)); break;
2413 case i_coshFloat: OP_F_F(cosh(x)); break;
2414 case i_tanhFloat: OP_F_F(tanh(x)); break;
2415 case i_powerFloat: OP_FF_F(pow(x,y)); break;
2417 case i_encodeFloatZ:
2419 StgPtr sig = PopPtr();
2420 StgInt exp = PopTaggedInt();
2422 B__encodeFloat(IntegerInsideByteArray(sig), exp)
2426 case i_decodeFloatZ:
2428 StgFloat f = PopTaggedFloat();
2429 StgPtr sig = CreateByteArrayToHoldInteger(size_fltmantissa());
2431 B__decodeFloat(IntegerInsideByteArray(sig), &exp, f);
2437 case i_isNaNFloat: OP_F_B(isFloatNaN(x)); break;
2438 case i_isInfiniteFloat: OP_F_B(isFloatInfinite(x)); break;
2439 case i_isNegativeZeroFloat: OP_F_B(isFloatNegativeZero(x)); break;
2440 case i_isDenormalizedFloat: OP_F_B(isFloatDenormalized(x)); break;
2441 case i_gtDouble: OP_DD_B(x>y); break;
2442 case i_geDouble: OP_DD_B(x>=y); break;
2443 case i_eqDouble: OP_DD_B(x==y); break;
2444 case i_neDouble: OP_DD_B(x!=y); break;
2445 case i_ltDouble: OP_DD_B(x<y); break;
2446 case i_leDouble: OP_DD_B(x<=y) break;
2447 case i_minDouble: OP__D(DBL_MIN); break;
2448 case i_maxDouble: OP__D(DBL_MAX); break;
2449 case i_radixDouble: OP__I(FLT_RADIX); break;
2450 case i_digitsDouble: OP__I(DBL_MANT_DIG); break;
2451 case i_minExpDouble: OP__I(DBL_MIN_EXP); break;
2452 case i_maxExpDouble: OP__I(DBL_MAX_EXP); break;
2453 case i_plusDouble: OP_DD_D(x+y); break;
2454 case i_minusDouble: OP_DD_D(x-y); break;
2455 case i_timesDouble: OP_DD_D(x*y); break;
2456 case i_divideDouble:
2458 StgDouble x = PopTaggedDouble();
2459 StgDouble y = PopTaggedDouble();
2460 PushTaggedDouble(x/y);
2463 case i_negateDouble: OP_D_D(-x); break;
2464 case i_doubleToInt: OP_D_I(x); break;
2465 case i_intToDouble: OP_I_D(x); break;
2466 case i_doubleToFloat: OP_D_F(x); break;
2467 case i_floatToDouble: OP_F_F(x); break;
2468 case i_expDouble: OP_D_D(exp(x)); break;
2469 case i_logDouble: OP_D_D(log(x)); break;
2470 case i_sqrtDouble: OP_D_D(sqrt(x)); break;
2471 case i_sinDouble: OP_D_D(sin(x)); break;
2472 case i_cosDouble: OP_D_D(cos(x)); break;
2473 case i_tanDouble: OP_D_D(tan(x)); break;
2474 case i_asinDouble: OP_D_D(asin(x)); break;
2475 case i_acosDouble: OP_D_D(acos(x)); break;
2476 case i_atanDouble: OP_D_D(atan(x)); break;
2477 case i_sinhDouble: OP_D_D(sinh(x)); break;
2478 case i_coshDouble: OP_D_D(cosh(x)); break;
2479 case i_tanhDouble: OP_D_D(tanh(x)); break;
2480 case i_powerDouble: OP_DD_D(pow(x,y)); break;
2482 case i_encodeDoubleZ:
2484 StgPtr sig = PopPtr();
2485 StgInt exp = PopTaggedInt();
2487 B__encodeDouble(IntegerInsideByteArray(sig), exp)
2491 case i_decodeDoubleZ:
2493 StgDouble d = PopTaggedDouble();
2494 StgPtr sig = CreateByteArrayToHoldInteger(size_dblmantissa());
2496 B__decodeDouble(IntegerInsideByteArray(sig), &exp, d);
2502 case i_isNaNDouble: OP_D_B(isDoubleNaN(x)); break;
2503 case i_isInfiniteDouble: OP_D_B(isDoubleInfinite(x)); break;
2504 case i_isNegativeZeroDouble: OP_D_B(isDoubleNegativeZero(x)); break;
2505 case i_isDenormalizedDouble: OP_D_B(isDoubleDenormalized(x)); break;
2506 case i_isIEEEDouble:
2508 PushTaggedBool(rtsTrue);
2512 barf("Unrecognised primop1");
2519 /* For normal cases, return NULL and leave *return2 unchanged.
2520 To return the address of the next thing to enter,
2521 return the address of it and leave *return2 unchanged.
2522 To return a StgThreadReturnCode to the scheduler,
2523 set *return2 to it and return a non-NULL value.
2524 To cause a context switch, set context_switch (its a global),
2525 and optionally set hugsBlock to your rational.
2527 static void* enterBCO_primop2 ( int primop2code,
2528 int* /*StgThreadReturnCode* */ return2,
2531 HugsBlock *hugsBlock )
2534 /* A small concession: we need to allow ccalls,
2535 even in combined mode.
2537 if (primop2code != i_ccall_ccall_IO &&
2538 primop2code != i_ccall_stdcall_IO)
2539 barf("enterBCO_primop2 in combined mode");
2542 switch (primop2code) {
2543 case i_raise: /* raise#{err} */
2545 StgClosure* err = PopCPtr();
2546 return (raiseAnError(err));
2551 StgClosure* init = PopCPtr();
2553 = stgCast(StgMutVar*,allocate(sizeofW(StgMutVar)));
2554 SET_HDR(mv,&MUT_VAR_info,CCCS);
2556 PushPtr(stgCast(StgPtr,mv));
2561 StgMutVar* mv = stgCast(StgMutVar*,PopPtr());
2567 StgMutVar* mv = stgCast(StgMutVar*,PopPtr());
2568 StgClosure* value = PopCPtr();
2574 nat n = PopTaggedInt(); /* or Word?? */
2575 StgClosure* init = PopCPtr();
2576 StgWord size = sizeofW(StgMutArrPtrs) + n;
2579 = stgCast(StgMutArrPtrs*,allocate(size));
2580 SET_HDR(arr,&MUT_ARR_PTRS_info,CCCS);
2582 for (i = 0; i < n; ++i) {
2583 arr->payload[i] = init;
2585 PushPtr(stgCast(StgPtr,arr));
2591 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2592 nat i = PopTaggedInt(); /* or Word?? */
2593 StgWord n = arr->ptrs;
2595 return (raiseIndex("{index,read}Array"));
2597 PushCPtr(arr->payload[i]);
2602 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2603 nat i = PopTaggedInt(); /* or Word? */
2604 StgClosure* v = PopCPtr();
2605 StgWord n = arr->ptrs;
2607 return (raiseIndex("{index,read}Array"));
2609 arr->payload[i] = v;
2613 case i_sizeMutableArray:
2615 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2616 PushTaggedInt(arr->ptrs);
2619 case i_unsafeFreezeArray:
2621 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2622 SET_INFO(arr,&MUT_ARR_PTRS_FROZEN_info);
2623 PushPtr(stgCast(StgPtr,arr));
2626 case i_unsafeFreezeByteArray:
2628 /* Delightfully simple :-) */
2632 case i_sameMutableArray:
2633 case i_sameMutableByteArray:
2635 StgPtr x = PopPtr();
2636 StgPtr y = PopPtr();
2637 PushTaggedBool(x==y);
2641 case i_newByteArray:
2643 nat n = PopTaggedInt(); /* or Word?? */
2644 StgInt words = (n+sizeof(W_)-1)/sizeof(W_);
2645 StgWord size = sizeofW(StgArrWords) + words;
2646 StgArrWords* arr = stgCast(StgArrWords*,allocate(size));
2647 SET_HDR(arr,&ARR_WORDS_info,CCCS);
2651 for (i = 0; i < n; ++i) {
2652 arr->payload[i] = 0xdeadbeef;
2655 PushPtr(stgCast(StgPtr,arr));
2659 /* Most of these generate alignment warnings on Sparcs and similar architectures.
2660 * These are harmless and are caused by the cast to C* in BYTE_ARR_CTS.
2662 case i_indexCharArray:
2663 OP_mI_ty(Char,"indexCharArray", indexCharArrayzh(r,x,i)); break;
2664 case i_readCharArray:
2665 OP_mI_ty(Char,"readCharArray", readCharArrayzh(r,x,i)); break;
2666 case i_writeCharArray:
2667 OP_mIty_(Char,"writeCharArray", writeCharArrayzh(x,i,z)); break;
2669 case i_indexIntArray:
2670 OP_mI_ty(Int,"indexIntArray", indexIntArrayzh(r,x,i)); break;
2671 case i_readIntArray:
2672 OP_mI_ty(Int,"readIntArray", readIntArrayzh(r,x,i)); break;
2673 case i_writeIntArray:
2674 OP_mIty_(Int,"writeIntArray", writeIntArrayzh(x,i,z)); break;
2676 case i_indexAddrArray:
2677 OP_mI_ty(Addr,"indexAddrArray", indexAddrArrayzh(r,x,i)); break;
2678 case i_readAddrArray:
2679 OP_mI_ty(Addr,"readAddrArray", readAddrArrayzh(r,x,i)); break;
2680 case i_writeAddrArray:
2681 OP_mIty_(Addr,"writeAddrArray", writeAddrArrayzh(x,i,z)); break;
2683 case i_indexFloatArray:
2684 OP_mI_ty(Float,"indexFloatArray", indexFloatArrayzh(r,x,i)); break;
2685 case i_readFloatArray:
2686 OP_mI_ty(Float,"readFloatArray", readFloatArrayzh(r,x,i)); break;
2687 case i_writeFloatArray:
2688 OP_mIty_(Float,"writeFloatArray", writeFloatArrayzh(x,i,z)); break;
2690 case i_indexDoubleArray:
2691 OP_mI_ty(Double,"indexDoubleArray", indexDoubleArrayzh(r,x,i)); break;
2692 case i_readDoubleArray:
2693 OP_mI_ty(Double,"readDoubleArray", readDoubleArrayzh(r,x,i)); break;
2694 case i_writeDoubleArray:
2695 OP_mIty_(Double,"writeDoubleArray", writeDoubleArrayzh(x,i,z)); break;
2698 #ifdef PROVIDE_STABLE
2699 case i_indexStableArray:
2700 OP_mI_ty(StablePtr,"indexStableArray", indexStablePtrArrayzh(r,x,i)); break;
2701 case i_readStableArray:
2702 OP_mI_ty(StablePtr,"readStableArray", readStablePtrArrayzh(r,x,i)); break;
2703 case i_writeStableArray:
2704 OP_mIty_(StablePtr,"writeStableArray", writeStablePtrArrayzh(x,i,z)); break;
2710 #ifdef PROVIDE_COERCE
2711 case i_unsafeCoerce:
2713 /* Another nullop */
2717 #ifdef PROVIDE_PTREQUALITY
2718 case i_reallyUnsafePtrEquality:
2719 { /* identical to i_sameRef */
2720 StgPtr x = PopPtr();
2721 StgPtr y = PopPtr();
2722 PushTaggedBool(x==y);
2726 #ifdef PROVIDE_FOREIGN
2727 /* ForeignObj# operations */
2728 case i_mkForeignObj:
2730 StgForeignObj *result
2731 = stgCast(StgForeignObj*,allocate(sizeofW(StgForeignObj)));
2732 SET_HDR(result,&FOREIGN_info,CCCS);
2733 result -> data = PopTaggedAddr();
2734 PushPtr(stgCast(StgPtr,result));
2737 #endif /* PROVIDE_FOREIGN */
2742 = stgCast(StgWeak*,allocate(sizeofW(StgWeak)));
2743 SET_HDR(w, &WEAK_info, CCCS);
2745 w->value = PopCPtr();
2746 w->finaliser = PopCPtr();
2747 w->link = weak_ptr_list;
2749 IF_DEBUG(weak, fprintf(stderr,"New weak pointer at %p\n",w));
2750 PushPtr(stgCast(StgPtr,w));
2755 StgWeak *w = stgCast(StgWeak*,PopPtr());
2756 if (w->header.info == &WEAK_info) {
2757 PushCPtr(w->value); /* last result */
2758 PushTaggedInt(1); /* first result */
2760 PushPtr(stgCast(StgPtr,w));
2761 /* ToDo: error thunk would be better */
2766 #endif /* PROVIDE_WEAK */
2768 case i_makeStablePtr:
2770 StgPtr p = PopPtr();
2771 StgStablePtr sp = getStablePtr ( p );
2772 PushTaggedStablePtr(sp);
2775 case i_deRefStablePtr:
2778 StgStablePtr sp = PopTaggedStablePtr();
2779 p = deRefStablePtr(sp);
2783 case i_freeStablePtr:
2785 StgStablePtr sp = PopTaggedStablePtr();
2790 case i_createAdjThunkARCH:
2792 StgStablePtr stableptr = PopTaggedStablePtr();
2793 StgAddr typestr = PopTaggedAddr();
2794 StgChar callconv = PopTaggedChar();
2795 StgAddr adj_thunk = createAdjThunk(stableptr,typestr,callconv);
2796 PushTaggedAddr(adj_thunk);
2802 StgInt n = prog_argc;
2808 StgInt n = PopTaggedInt();
2809 StgAddr a = (StgAddr)prog_argv[n];
2816 StgMVar *mvar = stgCast(StgMVar*,allocate(sizeofW(StgMVar)));
2817 SET_INFO(mvar,&EMPTY_MVAR_info);
2818 mvar->head = mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
2819 mvar->value = stgCast(StgClosure*,&END_TSO_QUEUE_closure);
2820 PushPtr(stgCast(StgPtr,mvar));
2825 StgMVar *mvar = (StgMVar*)PopCPtr();
2826 if (GET_INFO(mvar) == &EMPTY_MVAR_info) {
2828 /* The MVar is empty. Attach ourselves to the TSO's
2831 if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
2832 mvar->head = cap->rCurrentTSO;
2834 mvar->tail->link = cap->rCurrentTSO;
2836 cap->rCurrentTSO->link = (StgTSO *)&END_TSO_QUEUE_closure;
2837 cap->rCurrentTSO->why_blocked = BlockedOnMVar;
2838 cap->rCurrentTSO->block_info.closure = (StgClosure *)mvar;
2839 mvar->tail = cap->rCurrentTSO;
2841 /* At this point, the top-of-stack holds the MVar,
2842 and underneath is the world token (). So the
2843 stack is in the same state as when primTakeMVar
2844 was entered (primTakeMVar is handwritten bytecode).
2845 Push obj, which is this BCO, and return to the
2846 scheduler. When the MVar is filled, the scheduler
2847 will re-enter primTakeMVar, with the args still on
2848 the top of the stack.
2850 PushCPtr((StgClosure*)(*bco));
2851 *return2 = ThreadBlocked;
2852 return (void*)(1+(char*)(NULL));
2855 PushCPtr(mvar->value);
2856 mvar->value = (StgClosure *)&END_TSO_QUEUE_closure;
2857 SET_INFO(mvar,&EMPTY_MVAR_info);
2863 StgMVar* mvar = stgCast(StgMVar*,PopPtr());
2864 StgClosure* value = PopCPtr();
2865 if (GET_INFO(mvar) == &FULL_MVAR_info) {
2866 return (makeErrorCall("putMVar {full MVar}"));
2868 /* wake up the first thread on the
2869 * queue, it will continue with the
2870 * takeMVar operation and mark the
2873 mvar->value = value;
2875 if (mvar->head != (StgTSO *)&END_TSO_QUEUE_closure) {
2876 ASSERT(mvar->head->why_blocked == BlockedOnMVar);
2877 mvar->head = unblockOne(mvar->head);
2878 if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
2879 mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
2883 /* unlocks the MVar in the SMP case */
2884 SET_INFO(mvar,&FULL_MVAR_info);
2886 /* yield for better communication performance */
2892 { /* identical to i_sameRef */
2893 StgMVar* x = (StgMVar*)PopPtr();
2894 StgMVar* y = (StgMVar*)PopPtr();
2895 PushTaggedBool(x==y);
2898 #ifdef PROVIDE_CONCURRENT
2901 StgClosure* closure;
2904 closure = PopCPtr();
2905 tso = createGenThread (RtsFlags.GcFlags.initialStkSize,closure);
2907 scheduleThread(tso);
2909 /* Later: Change to use tso as the ThreadId */
2910 PushTaggedWord(tid);
2916 StgWord n = PopTaggedWord();
2920 // Map from ThreadId to Thread Structure */
2921 for (t = all_threads; t != END_TSO_QUEUE; t = t->global_link) {
2930 while (tso->what_next == ThreadRelocated) {
2935 if (tso == cap->rCurrentTSO) { /* suicide */
2936 *return2 = ThreadFinished;
2937 return (void*)(1+(char*)(NULL));
2941 case i_raiseInThread:
2942 ASSERT(0); /* not (yet) supported */
2945 StgInt n = PopTaggedInt();
2947 hugsBlock->reason = BlockedOnDelay;
2948 hugsBlock->delay = n;
2953 StgInt n = PopTaggedInt();
2955 hugsBlock->reason = BlockedOnRead;
2956 hugsBlock->delay = n;
2961 StgInt n = PopTaggedInt();
2963 hugsBlock->reason = BlockedOnWrite;
2964 hugsBlock->delay = n;
2969 /* The definition of yield include an enter right after
2970 * the primYield, at which time context_switch is tested.
2977 StgWord tid = cap->rCurrentTSO->id;
2978 PushTaggedWord(tid);
2981 case i_cmpThreadIds:
2983 StgWord tid1 = PopTaggedWord();
2984 StgWord tid2 = PopTaggedWord();
2985 if (tid1 < tid2) PushTaggedInt(-1);
2986 else if (tid1 > tid2) PushTaggedInt(1);
2987 else PushTaggedInt(0);
2990 #endif /* PROVIDE_CONCURRENT */
2992 case i_ccall_ccall_Id:
2993 case i_ccall_ccall_IO:
2994 case i_ccall_stdcall_Id:
2995 case i_ccall_stdcall_IO:
2998 CFunDescriptor* descriptor;
2999 void (*funPtr)(void);
3001 descriptor = PopTaggedAddr();
3002 funPtr = PopTaggedAddr();
3003 cc = (primop2code == i_ccall_stdcall_Id ||
3004 primop2code == i_ccall_stdcall_IO)
3006 r = ccall(descriptor,funPtr,bco,cc,cap);
3009 return makeErrorCall(
3010 "unhandled type or too many args/results in ccall");
3012 barf("ccall not configured correctly for this platform");
3013 barf("unknown return code from ccall");
3016 barf("Unrecognised primop2");
3022 /* -----------------------------------------------------------------------------
3023 * ccall support code:
3024 * marshall moves args from C stack to Haskell stack
3025 * unmarshall moves args from Haskell stack to C stack
3026 * argSize calculates how much gSpace you need on the C stack
3027 * ---------------------------------------------------------------------------*/
3029 /* Pop arguments off the C stack and Push them onto the Hugs stack.
3030 * Used when preparing for C calling Haskell or in regSponse to
3031 * Haskell calling C.
3033 nat marshall(char arg_ty, void* arg)
3037 PushTaggedInt(*((int*)arg));
3038 return ARG_SIZE(INT_TAG);
3041 PushTaggedInteger(*((mpz_ptr*)arg));
3042 return ARG_SIZE(INTEGER_TAG);
3045 PushTaggedWord(*((unsigned int*)arg));
3046 return ARG_SIZE(WORD_TAG);
3048 PushTaggedChar(*((char*)arg));
3049 return ARG_SIZE(CHAR_TAG);
3051 PushTaggedFloat(*((float*)arg));
3052 return ARG_SIZE(FLOAT_TAG);
3054 PushTaggedDouble(*((double*)arg));
3055 return ARG_SIZE(DOUBLE_TAG);
3057 PushTaggedAddr(*((void**)arg));
3058 return ARG_SIZE(ADDR_TAG);
3060 PushTaggedStablePtr(*((StgStablePtr*)arg));
3061 return ARG_SIZE(STABLE_TAG);
3062 #ifdef PROVIDE_FOREIGN
3064 /* Not allowed in this direction - you have to
3065 * call makeForeignPtr explicitly
3067 barf("marshall: ForeignPtr#\n");
3072 /* Not allowed in this direction */
3073 barf("marshall: [Mutable]ByteArray#\n");
3076 barf("marshall: unrecognised arg type %d\n",arg_ty);
3081 /* Pop arguments off the Hugs stack and Push them onto the C stack.
3082 * Used when preparing for Haskell calling C or in regSponse to
3083 * C calling Haskell.
3085 nat unmarshall(char res_ty, void* res)
3089 *((int*)res) = PopTaggedInt();
3090 return ARG_SIZE(INT_TAG);
3093 *((mpz_ptr*)res) = PopTaggedInteger();
3094 return ARG_SIZE(INTEGER_TAG);
3097 *((unsigned int*)res) = PopTaggedWord();
3098 return ARG_SIZE(WORD_TAG);
3100 *((int*)res) = PopTaggedChar();
3101 return ARG_SIZE(CHAR_TAG);
3103 *((float*)res) = PopTaggedFloat();
3104 return ARG_SIZE(FLOAT_TAG);
3106 *((double*)res) = PopTaggedDouble();
3107 return ARG_SIZE(DOUBLE_TAG);
3109 *((void**)res) = PopTaggedAddr();
3110 return ARG_SIZE(ADDR_TAG);
3112 *((StgStablePtr*)res) = PopTaggedStablePtr();
3113 return ARG_SIZE(STABLE_TAG);
3114 #ifdef PROVIDE_FOREIGN
3117 StgForeignObj *result = stgCast(StgForeignObj*,PopPtr());
3118 *((void**)res) = result->data;
3119 return sizeofW(StgPtr);
3125 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
3126 *((void**)res) = stgCast(void*,&(arr->payload));
3127 return sizeofW(StgPtr);
3130 barf("unmarshall: unrecognised result type %d\n",res_ty);
3134 nat argSize( const char* ks )
3137 for( ; *ks != '\0'; ++ks) {
3140 sz += sizeof(StgWord) * ARG_SIZE(INT_TAG);
3144 sz += sizeof(StgWord) * ARG_SIZE(INTEGER_TAG);
3148 sz += sizeof(StgWord) * ARG_SIZE(WORD_TAG);
3151 sz += sizeof(StgWord) * ARG_SIZE(CHAR_TAG);
3154 sz += sizeof(StgWord) * ARG_SIZE(FLOAT_TAG);
3157 sz += sizeof(StgWord) * ARG_SIZE(DOUBLE_TAG);
3160 sz += sizeof(StgWord) * ARG_SIZE(ADDR_TAG);
3163 sz += sizeof(StgWord) * ARG_SIZE(STABLE_TAG);
3165 #ifdef PROVIDE_FOREIGN
3170 sz += sizeof(StgPtr);
3173 barf("argSize: unrecognised result type %d\n",*ks);
3181 /* -----------------------------------------------------------------------------
3182 * encode/decode Float/Double code for standalone Hugs
3183 * Code based on the HBC code (lib/fltcode.c) and more recently GHC
3184 * (ghc/rts/StgPrimFloat.c)
3185 * ---------------------------------------------------------------------------*/
3187 #if IEEE_FLOATING_POINT
3188 #define MY_DMINEXP ((DBL_MIN_EXP) - (DBL_MANT_DIG) - 1)
3189 /* DMINEXP is defined in values.h on Linux (for example) */
3190 #define DHIGHBIT 0x00100000
3191 #define DMSBIT 0x80000000
3193 #define MY_FMINEXP ((FLT_MIN_EXP) - (FLT_MANT_DIG) - 1)
3194 #define FHIGHBIT 0x00800000
3195 #define FMSBIT 0x80000000
3197 #error The following code doesnt work in a non-IEEE FP environment
3200 #ifdef WORDS_BIGENDIAN
3209 StgDouble B__encodeDouble (B* s, I_ e) /* result = s * 2^e */
3214 /* Convert a B to a double; knows a lot about internal rep! */
3215 for(r = 0.0, i = s->used-1; i >= 0; i--)
3216 r = (r * B_BASE_FLT) + s->stuff[i];
3218 /* Now raise to the exponent */
3219 if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
3222 /* handle the sign */
3223 if (s->sign < 0) r = -r;
3230 #if ! FLOATS_AS_DOUBLES
3231 StgFloat B__encodeFloat (B* s, I_ e) /* result = s * 2^e */
3236 /* Convert a B to a float; knows a lot about internal rep! */
3237 for(r = 0.0, i = s->used-1; i >= 0; i--)
3238 r = (r * B_BASE_FLT) + s->stuff[i];
3240 /* Now raise to the exponent */
3241 if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
3244 /* handle the sign */
3245 if (s->sign < 0) r = -r;
3249 #endif /* FLOATS_AS_DOUBLES */
3253 /* This only supports IEEE floating point */
3254 void B__decodeDouble (B* man, I_* exp, StgDouble dbl)
3256 /* Do some bit fiddling on IEEE */
3257 nat low, high; /* assuming 32 bit ints */
3259 union { double d; int i[2]; } u; /* assuming 32 bit ints, 64 bit double */
3261 u.d = dbl; /* grab chunks of the double */
3265 ASSERT(B_BASE == 256);
3267 /* Assume that the supplied B is the right size */
3270 if (low == 0 && (high & ~DMSBIT) == 0) {
3271 man->sign = man->used = 0;
3276 iexp = ((high >> 20) & 0x7ff) + MY_DMINEXP;
3280 if (iexp != MY_DMINEXP) /* don't add hidden bit to denorms */
3284 /* A denorm, normalize the mantissa */
3285 while (! (high & DHIGHBIT)) {
3295 man->stuff[7] = (((W_)high) >> 24) & 0xff;
3296 man->stuff[6] = (((W_)high) >> 16) & 0xff;
3297 man->stuff[5] = (((W_)high) >> 8) & 0xff;
3298 man->stuff[4] = (((W_)high) ) & 0xff;
3300 man->stuff[3] = (((W_)low) >> 24) & 0xff;
3301 man->stuff[2] = (((W_)low) >> 16) & 0xff;
3302 man->stuff[1] = (((W_)low) >> 8) & 0xff;
3303 man->stuff[0] = (((W_)low) ) & 0xff;
3305 if (sign < 0) man->sign = -1;
3307 do_renormalise(man);
3311 #if ! FLOATS_AS_DOUBLES
3312 void B__decodeFloat (B* man, I_* exp, StgFloat flt)
3314 /* Do some bit fiddling on IEEE */
3315 int high, sign; /* assuming 32 bit ints */
3316 union { float f; int i; } u; /* assuming 32 bit float and int */
3318 u.f = flt; /* grab the float */
3321 ASSERT(B_BASE == 256);
3323 /* Assume that the supplied B is the right size */
3326 if ((high & ~FMSBIT) == 0) {
3327 man->sign = man->used = 0;
3332 *exp = ((high >> 23) & 0xff) + MY_FMINEXP;
3336 if (*exp != MY_FMINEXP) /* don't add hidden bit to denorms */
3340 /* A denorm, normalize the mantissa */
3341 while (! (high & FHIGHBIT)) {
3346 man->stuff[3] = (((W_)high) >> 24) & 0xff;
3347 man->stuff[2] = (((W_)high) >> 16) & 0xff;
3348 man->stuff[1] = (((W_)high) >> 8) & 0xff;
3349 man->stuff[0] = (((W_)high) ) & 0xff;
3351 if (sign < 0) man->sign = -1;
3353 do_renormalise(man);
3356 #endif /* FLOATS_AS_DOUBLES */
3357 #endif /* INTERPRETER */