2 /* -----------------------------------------------------------------------------
5 * Copyright (c) 1994-2000.
7 * $RCSfile: Evaluator.c,v $
9 * $Date: 2000/11/07 13:30:41 $
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 StgFloat B__encodeFloat (B* s, I_ e);
155 void B__decodeFloat (B* man, I_* exp, StgFloat flt);
156 StgPtr CreateByteArrayToHoldInteger ( int );
157 B* IntegerInsideByteArray ( StgPtr );
158 void SloppifyIntegerEnd ( StgPtr );
163 #define gSp MainRegTable.rSp
164 #define gSu MainRegTable.rSu
165 #define gSpLim MainRegTable.rSpLim
168 /* Macros to save/load local state. */
170 #define SSS { tSp=gSp = xSp; tSu=gSu = xSu; tSpLim=gSpLim = xSpLim; }
171 #define LLL { tSp=xSp = gSp; tSu=xSu = gSu; tSpLim=xSpLim = gSpLim; }
173 #define SSS { gSp = xSp; gSu = xSu; gSpLim = xSpLim; }
174 #define LLL { xSp = gSp; xSu = gSu; xSpLim = gSpLim; }
177 #define RETURN(vvv) { \
178 StgThreadReturnCode retVal=(vvv); \
180 cap->rCurrentTSO->sp = gSp; \
181 cap->rCurrentTSO->su = gSu; \
186 /* Macros to operate directly on the pulled-out machine state.
187 These mirror some of the small procedures used in the primop code
188 below, except you have to be careful about side effects,
189 ie xPushPtr(xStackPtr(n)) won't work! It certainly isn't the
190 same as PushPtr(StackPtr(n)). Also note that (1) some of
191 the macros, in particular xPopTagged*, do not make the tag
192 sanity checks that their non-x cousins do, and (2) some of
193 the macros depend critically on the semantics of C comma
194 expressions to work properly.
196 #define xPushPtr(ppp) { xSp--; *xSp=(StgWord)(ppp); }
197 #define xPopPtr() ((StgPtr)(*xSp++))
199 #define xPushCPtr(ppp) { xSp--; *xSp=(StgWord)(ppp); }
200 #define xPopCPtr() ((StgClosure*)(*xSp++))
202 #define xPushWord(ppp) { xSp--; *xSp=(StgWord)(ppp); }
203 #define xPopWord() ((StgWord)(*xSp++))
205 #define xStackPtr(nnn) ((StgPtr)(*(xSp+(nnn))))
206 #define xStackWord(nnn) ((StgWord)(*(xSp+(nnn))))
207 #define xSetStackWord(iii,www) xSp[iii]=(StgWord)(www)
209 #define xPushTag(ttt) { xSp--; *xSp=(StgWord)(ttt); }
210 #define xPopTag(ttt) { StackTag t = (StackTag)(*xSp++); \
213 #define xPushTaggedInt(xxx) { xSp -= sizeofW(StgInt); \
214 *xSp = (xxx); xPushTag(INT_TAG); }
215 #define xTaggedStackInt(iii) ((StgInt)(*(xSp+1+(iii))))
216 #define xPopTaggedInt() ((xSp++,xSp+=sizeofW(StgInt), \
217 (StgInt)(*(xSp-sizeofW(StgInt)))))
219 #define xPushTaggedWord(xxx) { xSp -= sizeofW(StgWord); \
220 *xSp = (xxx); xPushTag(WORD_TAG); }
221 #define xTaggedStackWord(iii) ((StgWord)(*(xSp+1+(iii))))
222 #define xPopTaggedWord() ((xSp++,xSp+=sizeofW(StgWord), \
223 (StgWord)(*(xSp-sizeofW(StgWord)))))
225 #define xPushTaggedAddr(xxx) { xSp -= sizeofW(StgAddr); \
226 *xSp = (StgWord)(xxx); xPushTag(ADDR_TAG); }
227 #define xTaggedStackAddr(iii) ((StgAddr)(*(xSp+1+(iii))))
228 #define xPopTaggedAddr() ((xSp++,xSp+=sizeofW(StgAddr), \
229 (StgAddr)(*(xSp-sizeofW(StgAddr)))))
231 #define xPushTaggedStable(xxx) { xSp -= sizeofW(StgStablePtr); \
232 *xSp = (StgWord)(xxx); xPushTag(STABLE_TAG); }
233 #define xTaggedStackStable(iii) ((StgStablePtr)(*(xSp+1+(iii))))
234 #define xPopTaggedStable() ((xSp++,xSp+=sizeofW(StgStablePtr), \
235 (StgStablePtr)(*(xSp-sizeofW(StgStablePtr)))))
237 #define xPushTaggedChar(xxx) { xSp -= sizeofW(StgChar); \
238 *xSp = (StgWord)(xxx); xPushTag(CHAR_TAG); }
239 #define xTaggedStackChar(iii) ((StgChar)(*(xSp+1+(iii))))
240 #define xPopTaggedChar() ((xSp++,xSp+=sizeofW(StgChar), \
241 (StgChar)(*(xSp-sizeofW(StgChar)))))
243 #define xPushTaggedFloat(xxx) { xSp -= sizeofW(StgFloat); \
244 ASSIGN_FLT(xSp,xxx); xPushTag(FLOAT_TAG); }
245 #define xTaggedStackFloat(iii) PK_FLT(xSp+1+(iii))
246 #define xPopTaggedFloat() ((xSp++,xSp+=sizeofW(StgFloat), \
247 PK_FLT(xSp-sizeofW(StgFloat))))
249 #define xPushTaggedDouble(xxx) { xSp -= sizeofW(StgDouble); \
250 ASSIGN_DBL(xSp,xxx); xPushTag(DOUBLE_TAG); }
251 #define xTaggedStackDouble(iii) PK_DBL(xSp+1+(iii))
252 #define xPopTaggedDouble() ((xSp++,xSp+=sizeofW(StgDouble), \
253 PK_DBL(xSp-sizeofW(StgDouble))))
256 #define xPushUpdateFrame(target, xSp_offset) \
258 StgUpdateFrame *__frame; \
259 __frame = (StgUpdateFrame *)(xSp + (xSp_offset)) - 1; \
260 SET_INFO(__frame, (StgInfoTable *)&upd_frame_info); \
261 __frame->link = xSu; \
262 __frame->updatee = (StgClosure *)(target); \
266 #define xPopUpdateFrame(ooo) \
268 /* NB: doesn't assume that Sp == Su */ \
269 IF_DEBUG(evaluator, \
270 fprintf(stderr, "Updating "); \
271 printPtr(stgCast(StgPtr,xSu->updatee)); \
272 fprintf(stderr, " with "); \
274 fprintf(stderr,"xSp = %p\txSu = %p\n\n", xSp, xSu); \
276 UPD_IND(xSu->updatee,ooo); \
277 xSp = stgCast(StgStackPtr,xSu) + sizeofW(StgUpdateFrame); \
283 /* Instruction stream macros */
284 #define BCO_INSTR_8 *bciPtr++
285 #define BCO_INSTR_16 ((bciPtr += 2, (*(bciPtr-2) << 8) + *(bciPtr-1)))
286 #define PC (bciPtr - &(bcoInstr(bco,0)))
289 /* State on entry to enter():
290 * - current thread is in cap->rCurrentTSO;
291 * - allocation area is in cap->rCurrentNursery & cap->rNursery
294 StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 )
296 /* use of register here is primarily to make it clear to compilers
297 that these entities are non-aliasable.
299 register StgPtr xSp; /* local state -- stack pointer */
300 register StgUpdateFrame* xSu; /* local state -- frame pointer */
301 register StgPtr xSpLim; /* local state -- stack lim pointer */
302 register StgClosure* obj; /* object currently under evaluation */
303 char eCount; /* enter counter, for context switching */
306 HugsBlock hugsBlock = { NotBlocked, 0 };
310 StgPtr tSp; StgUpdateFrame* tSu; StgPtr tSpLim;
313 gSp = cap->rCurrentTSO->sp;
314 gSu = cap->rCurrentTSO->su;
315 gSpLim = cap->rCurrentTSO->stack + RESERVED_STACK_WORDS;
318 /* use the t values to check that Su/Sp/SpLim do not change unexpectedly */
319 tSp = gSp; tSu = gSu; tSpLim = gSpLim;
325 /* Load the local state from global state, and Party On, Dudes! */
326 /* From here onwards, we operate with the local state and
327 save/reload it as necessary.
338 ASSERT(gSpLim == tSpLim);
342 ASSERT(xSpLim <= xSp && xSp <= stgCast(StgPtr,xSu));
344 "\n---------------------------------------------------------------\n");
345 fprintf(stderr,"(%d) Entering: ",enterCountI); printObj(obj);
346 fprintf(stderr,"xSp = %p\txSu = %p\n", xSp, xSu);
347 fprintf(stderr, "\n" );
348 printStack(xSp,cap->rCurrentTSO->stack+cap->rCurrentTSO->stack_size,xSu);
349 fprintf(stderr, "\n\n");
356 ((++eCount) & 0x0F) == 0
361 if (context_switch) {
362 switch(hugsBlock.reason) {
364 xPushCPtr(obj); /* code to restart with */
365 RETURN(ThreadYielding);
367 case BlockedOnDelay: /* fall through */
368 case BlockedOnRead: /* fall through */
369 case BlockedOnWrite: {
370 ASSERT(cap->rCurrentTSO->why_blocked == NotBlocked);
371 cap->rCurrentTSO->why_blocked = BlockedOnDelay;
372 ACQUIRE_LOCK(&sched_mutex);
374 #if defined(HAVE_SETITIMER) /* || defined(mingw32_TARGET_OS) */
375 cap->rCurrentTSO->block_info.delay
376 = hugsBlock.delay + ticks_since_select;
378 cap->rCurrentTSO->block_info.target
379 = hugsBlock.delay + getourtimeofday();
381 APPEND_TO_BLOCKED_QUEUE(cap->rCurrentTSO);
383 RELEASE_LOCK(&sched_mutex);
385 xPushCPtr(obj); /* code to restart with */
386 RETURN(ThreadBlocked);
389 barf("Unknown context switch reasoning");
394 switch ( get_itbl(obj)->type ) {
396 barf("Invalid object %p",obj);
400 /* ---------------------------------------------------- */
401 /* Start of the bytecode evaluator */
402 /* ---------------------------------------------------- */
405 # define Ins(x) &&l##x
406 static void *labs[] = { INSTRLIST };
408 # define LoopTopLabel
409 # define Case(x) l##x
410 # define Continue goto *labs[BCO_INSTR_8]
411 # define Dispatch Continue;
414 # define LoopTopLabel insnloop:
415 # define Case(x) case x
416 # define Continue goto insnloop
417 # define Dispatch switch (BCO_INSTR_8) {
418 # define EndDispatch }
421 register StgWord8* bciPtr; /* instruction pointer */
422 register StgBCO* bco = (StgBCO*)obj;
425 /* Don't need to SSS ... LLL around doYouWantToGC */
426 wantToGC = doYouWantToGC();
428 xPushCPtr((StgClosure*)bco); /* code to restart with */
429 RETURN(HeapOverflow);
432 bciPtr = &(bcoInstr(bco,0));
436 ASSERT((StgWord)(PC) < bco->n_instrs);
438 fprintf(stderr,"Sp = %p\tSu = %p\tpc = %d\t", xSp, xSu, PC);
442 fprintf(stderr,"\n");
443 for (i = 8; i >= 0; i--)
444 fprintf(stderr, "%d %p\n", i, (StgPtr)(*(gSp+i)));
446 fprintf(stderr,"\n");
452 Case(i_INTERNAL_ERROR):
453 barf("INTERNAL_ERROR at %p:%d",bco,PC-1);
455 barf("PANIC at %p:%d",bco,PC-1);
459 if (xSp - n < xSpLim) {
460 xPushCPtr((StgClosure*)bco); /* code to restart with */
461 RETURN(StackOverflow);
465 Case(i_STK_CHECK_big):
467 int n = BCO_INSTR_16;
468 if (xSp - n < xSpLim) {
469 xPushCPtr((StgClosure*)bco); /* code to restart with */
470 RETURN(StackOverflow);
477 if ((StgPtr*)(xSp + n) > (StgPtr*)xSu) {
478 StgWord words = (P_)xSu - xSp;
480 /* first build a PAP */
481 ASSERT((P_)xSu >= xSp); /* was (words >= 0) but that's always true */
482 if (words == 0) { /* optimisation */
483 /* Skip building the PAP and update with an indirection. */
486 /* In the evaluator, we avoid the need to do
487 * a heap check here by including the size of
488 * the PAP in the heap check we performed
489 * when we entered the BCO.
493 SSS; pap = (StgPAP*)grabHpNonUpd(PAP_sizeW(words)); LLL;
494 SET_HDR(pap,&PAP_info,CC_pap);
497 for (i = 0; i < (I_)words; ++i) {
498 payloadWord(pap,i) = xSp[i];
501 obj = stgCast(StgClosure*,pap);
504 /* now deal with "update frame" */
505 /* as an optimisation, we process all on top of stack */
506 /* instead of just the top one */
507 ASSERT(xSp==(P_)xSu);
509 switch (get_itbl(xSu)->type) {
511 /* Hit a catch frame during an arg satisfaction check,
512 * so the thing returning (1) has not thrown an
513 * exception, and (2) is of functional type. Just
514 * zap the catch frame and carry on down the stack
515 * (looking for more arguments, basically).
517 SSS; PopCatchFrame(); LLL;
520 xPopUpdateFrame(obj);
523 barf("STOP frame during pap update");
525 cap->rCurrentTSO->what_next = ThreadComplete;
526 SSS; PopStopFrame(obj); LLL;
527 RETURN(ThreadFinished);
530 SSS; PopSeqFrame(); LLL;
531 ASSERT(xSp != (P_)xSu);
532 /* Hit a SEQ frame during an arg satisfaction check.
533 * So now return to bco_info which is under the
534 * SEQ frame. The following code is copied from a
535 * case RET_BCO further down. (The reason why we're
536 * here is that something of functional type has
537 * been seq-d on, and we're now returning to the
538 * algebraic-case-continuation which forced the
539 * evaluation in the first place.)
551 barf("Invalid update frame during argcheck");
553 } while (xSp==(P_)xSu);
561 int words = BCO_INSTR_8;
562 SSS; p = grabHpUpd(AP_sizeW(words)); LLL;
566 Case(i_ALLOC_CONSTR):
569 StgInfoTable* info = bcoConstAddr(bco,BCO_INSTR_8);
570 SSS; p = grabHpNonUpd(sizeW_fromITBL(info)); LLL;
571 SET_HDR((StgClosure*)p,info,??);
575 Case(i_ALLOC_CONSTR_big):
578 int x = BCO_INSTR_16;
579 StgInfoTable* info = bcoConstAddr(bco,x);
580 SSS; p = grabHpNonUpd(sizeW_fromITBL(info)); LLL;
581 SET_HDR((StgClosure*)p,info,??);
587 int x = BCO_INSTR_8; /* ToDo: Word not Int! */
589 StgAP_UPD* o = stgCast(StgAP_UPD*,xStackPtr(x));
590 SET_HDR(o,&AP_UPD_info,??);
592 o->fun = stgCast(StgClosure*,xPopPtr());
593 for(x=0; x < y; ++x) {
594 payloadWord(o,x) = xPopWord();
597 fprintf(stderr,"\tBuilt ");
599 printObj(stgCast(StgClosure*,o));
610 o = stgCast(StgAP_UPD*,xStackPtr(x));
611 SET_HDR(o,&AP_UPD_info,??);
613 o->fun = stgCast(StgClosure*,xPopPtr());
614 for(x=0; x < y; ++x) {
615 payloadWord(o,x) = xPopWord();
618 fprintf(stderr,"\tBuilt ");
620 printObj(stgCast(StgClosure*,o));
629 StgPAP* o = stgCast(StgPAP*,xStackPtr(x));
630 SET_HDR(o,&PAP_info,??);
632 o->fun = stgCast(StgClosure*,xPopPtr());
633 for(x=0; x < y; ++x) {
634 payloadWord(o,x) = xPopWord();
637 fprintf(stderr,"\tBuilt ");
639 printObj(stgCast(StgClosure*,o));
646 int offset = BCO_INSTR_8;
647 StgClosure* o = stgCast(StgClosure*,xStackPtr(offset));
648 const StgInfoTable* info = get_itbl(o);
649 nat p = info->layout.payload.ptrs;
650 nat np = info->layout.payload.nptrs;
652 for(i=0; i < p; ++i) {
653 o->payload[i] = xPopCPtr();
655 for(i=0; i < np; ++i) {
656 payloadWord(o,p+i) = 0xdeadbeef;
659 fprintf(stderr,"\tBuilt ");
661 printObj(stgCast(StgClosure*,o));
668 int offset = BCO_INSTR_16;
669 StgClosure* o = stgCast(StgClosure*,xStackPtr(offset));
670 const StgInfoTable* info = get_itbl(o);
671 nat p = info->layout.payload.ptrs;
672 nat np = info->layout.payload.nptrs;
674 for(i=0; i < p; ++i) {
675 o->payload[i] = xPopCPtr();
677 for(i=0; i < np; ++i) {
678 payloadWord(o,p+i) = 0xdeadbeef;
681 fprintf(stderr,"\tBuilt ");
683 printObj(stgCast(StgClosure*,o));
692 ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
693 /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
695 xSetStackWord(x+y,xStackWord(x));
705 ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
706 /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
708 xSetStackWord(x+y,xStackWord(x));
720 xPushPtr(bcoConstPtr(bco,BCO_INSTR_8));
721 xPushPtr(stgCast(StgPtr,&ret_bco_info));
726 int tag = BCO_INSTR_8;
727 StgWord offset = BCO_INSTR_16;
728 if (constrTag( (StgClosure*)xStackPtr(0) ) != tag) {
735 StgClosure* o = stgCast(StgClosure*,xStackPtr(0));
736 const StgInfoTable* itbl = get_itbl(o);
737 int i = itbl->layout.payload.ptrs;
738 ASSERT( itbl->type == CONSTR
739 || itbl->type == CONSTR_STATIC
740 || itbl->type == CONSTR_NOCAF_STATIC
741 || itbl->type == CONSTR_1_0
742 || itbl->type == CONSTR_0_1
743 || itbl->type == CONSTR_2_0
744 || itbl->type == CONSTR_1_1
745 || itbl->type == CONSTR_0_2
748 xPushCPtr(o->payload[i]);
754 int n = BCO_INSTR_16;
755 StgPtr p = xStackPtr(n);
761 StgPtr p = xStackPtr(BCO_INSTR_8);
767 xPushPtr(stgCast(StgPtr,bcoConstPtr(bco,BCO_INSTR_8)));
772 int n = BCO_INSTR_16;
773 xPushPtr(stgCast(StgPtr,bcoConstPtr(bco,n)));
777 /* allocate rows, implemented on top of (frozen) Arrays */
781 StgWord n = BCO_INSTR_8;
782 SSS; p = stgCast(StgMutArrPtrs*,grabHpNonUpd(sizeofW(StgMutArrPtrs) + n)); LLL;
783 SET_HDR(p,&MUT_ARR_PTRS_FROZEN_info,CCCS);
788 Case(i_ALLOC_ROW_big):
791 StgWord n = BCO_INSTR_16;
792 SSS; p = stgCast(StgMutArrPtrs*,grabHpNonUpd(sizeofW(StgMutArrPtrs) + n)); LLL;
793 SET_HDR(p,&MUT_ARR_PTRS_FROZEN_info,CCCS);
799 /* pack values into a row. */
802 StgWord offset = BCO_INSTR_8;
803 StgMutArrPtrs* p = stgCast(StgMutArrPtrs*,xStackPtr(offset));
809 p->payload[i] = xPopCPtr();
812 fprintf(stderr,"\tBuilt ");
814 printObj(stgCast(StgClosure*,p));
819 Case(i_PACK_ROW_big):
821 StgWord offset = BCO_INSTR_16;
822 StgMutArrPtrs* p = stgCast(StgMutArrPtrs*,xStackPtr(offset));
828 p->payload[i] = xPopCPtr();
831 fprintf(stderr,"\tBuilt ");
833 printObj(stgCast(StgClosure*,p));
839 /* extract all fields of a row */
842 StgMutArrPtrs* p = stgCast(StgMutArrPtrs*,xStackPtr(0));
847 xPushCPtr(p->payload[i]);
852 /* Trivial row (unit) */
853 Case(i_CONST_ROW_TRIV):
856 SSS; p = stgCast(StgMutArrPtrs*,grabHpNonUpd(sizeofW(StgMutArrPtrs) + 0)); LLL;
857 SET_HDR(p,&MUT_ARR_PTRS_FROZEN_info,CCCS);
863 /* pack values into an Inj */
864 Case(i_PACK_INJ_VAR):
866 const int size = CONSTR_sizeW(sizeofW(StgPtr),sizeofW(StgWord));
867 StgWord offset = BCO_INSTR_8;
870 SSS; o = (StgClosure*)grabHpNonUpd(size); LLL;
871 SET_HDR(o,Inj_con_info,??);
873 payloadWord(o,sizeofW(StgPtr)) = xTaggedStackWord(offset);
874 payloadPtr(o,0) = xPopPtr();
877 fprintf(stderr,"\tBuilt ");
879 printObj(stgCast(StgClosure*,o));
882 xPushPtr(stgCast(StgPtr,o));
885 Case(i_PACK_INJ_VAR_big):
887 const int size = CONSTR_sizeW(sizeofW(StgPtr),sizeofW(StgWord));
888 StgWord offset = BCO_INSTR_16;
891 SSS; o = (StgClosure*)grabHpNonUpd(size); LLL;
892 SET_HDR(o,Inj_con_info,??);
894 payloadWord(o,sizeofW(StgPtr)) = xTaggedStackWord(offset);
895 payloadPtr(o,0) = xPopPtr();
898 fprintf(stderr,"\tBuilt ");
900 printObj(stgCast(StgClosure*,o));
903 xPushPtr(stgCast(StgPtr,o));
906 Case(i_PACK_INJ_CONST_8):
908 const int size = CONSTR_sizeW(sizeofW(StgPtr),sizeofW(StgWord));
909 StgWord witness = BCO_INSTR_8;
912 SSS; o = (StgClosure*)grabHpNonUpd(size); LLL;
913 SET_HDR(o,Inj_con_info,??);
915 payloadWord(o,sizeofW(StgPtr)) = witness;
916 payloadPtr(o,0) = xPopPtr();
919 fprintf(stderr,"\tBuilt ");
921 printObj(stgCast(StgClosure*,o));
924 xPushPtr(stgCast(StgPtr,o));
927 Case(i_PACK_INJ_REL_8):
929 const int size = CONSTR_sizeW(sizeofW(StgPtr),sizeofW(StgWord));
930 StgWord offset = BCO_INSTR_8;
931 StgWord cwitness = BCO_INSTR_8;
934 SSS; o = (StgClosure*)grabHpNonUpd(size); LLL;
935 SET_HDR(o,Inj_con_info,??);
937 payloadWord(o,sizeofW(StgPtr)) = xTaggedStackWord(offset) + cwitness;
938 payloadPtr(o,0) = xPopPtr();
941 fprintf(stderr,"\tBuilt ");
943 printObj(stgCast(StgClosure*,o));
946 xPushPtr(stgCast(StgPtr,o));
951 const int size = CONSTR_sizeW(sizeofW(StgPtr),sizeofW(StgWord));
954 SSS; o = (StgClosure*)grabHpNonUpd(size); LLL;
955 SET_HDR(o,Inj_con_info,??);
957 payloadWord(o,sizeofW(StgPtr)) = xPopTaggedWord();
958 payloadPtr(o,0) = xPopPtr();
961 fprintf(stderr,"\tBuilt ");
963 printObj(stgCast(StgClosure*,o));
966 xPushPtr(stgCast(StgPtr,o));
970 /* Test Inj witnesses. */
971 Case(i_TEST_INJ_VAR):
973 StgWord offset = BCO_INSTR_8;
974 StgWord jump = BCO_INSTR_16;
976 StgWord index = payloadWord( (StgClosure*)xStackPtr(0), sizeofW(StgPtr) );
977 if (index != xTaggedStackWord(offset) )
983 Case(i_TEST_INJ_VAR_big):
985 StgWord offset = BCO_INSTR_16;
986 StgWord jump = BCO_INSTR_16;
988 StgWord index = payloadWord( (StgClosure*)xStackPtr(0), sizeofW(StgPtr) );
989 if (index != xTaggedStackWord(offset) )
995 Case(i_TEST_INJ_CONST_8):
997 StgWord cwitness = BCO_INSTR_8;
998 StgWord jump = BCO_INSTR_16;
1000 StgWord witness = payloadWord( (StgClosure*)xStackPtr(0), sizeofW(StgPtr) );
1001 if (witness != cwitness )
1007 Case(i_TEST_INJ_REL_8):
1009 StgWord offset = BCO_INSTR_8;
1010 StgWord cwitness = BCO_INSTR_8;
1011 StgWord jump = BCO_INSTR_16;
1013 StgWord witness = payloadWord( (StgClosure*)xStackPtr(0), sizeofW(StgPtr) );
1014 if (witness != xTaggedStackWord(offset) + cwitness )
1022 StgWord jump = BCO_INSTR_16;
1023 StgWord cwitness = xPopTaggedWord();
1025 StgWord witness = payloadWord( (StgClosure*)xStackPtr(0), sizeofW(StgPtr) );
1026 if (witness != cwitness )
1033 /* extract the value of an INJ */
1036 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1038 ASSERT(get_itbl(con) == Inj_con_info);
1040 xPushPtr(payloadPtr(con,0));
1044 /* optimized witness (word) operations */
1045 Case(i_CONST_WORD_8):
1047 xPushTaggedWord(BCO_INSTR_8);
1050 Case(i_ADD_WORD_VAR):
1052 StgWord offset = BCO_INSTR_8;
1053 StgWord witness = xTaggedStackWord(offset);
1054 witness += xPopTaggedWord();
1055 xPushTaggedWord(witness);
1058 Case(i_ADD_WORD_VAR_big):
1060 StgWord offset = BCO_INSTR_16;
1061 StgWord witness = xTaggedStackWord(offset);
1062 witness += xPopTaggedWord();
1063 xPushTaggedWord(witness);
1066 Case(i_ADD_WORD_VAR_8):
1068 StgWord offset = BCO_INSTR_8;
1069 StgWord inc = BCO_INSTR_8;
1070 StgWord witness = xTaggedStackWord(offset);
1071 xPushTaggedWord(witness + inc);
1074 #endif /* XMLAMBA */
1078 SSS; PushTaggedRealWorld(); LLL;
1083 StgInt i = xTaggedStackInt(BCO_INSTR_8);
1089 xPushTaggedInt(bcoConstInt(bco,BCO_INSTR_8));
1092 Case(i_CONST_INT_big):
1094 int n = BCO_INSTR_16;
1095 xPushTaggedInt(bcoConstInt(bco,n));
1101 SSS; o = (StgClosure*)grabHpNonUpd(Izh_sizeW); LLL;
1102 SET_HDR(o,Izh_con_info,??);
1103 payloadWord(o,0) = xPopTaggedInt();
1105 fprintf(stderr,"\tBuilt ");
1107 printObj(stgCast(StgClosure*,o));
1110 xPushPtr(stgCast(StgPtr,o));
1115 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1116 /* ASSERT(isIntLike(con)); */
1117 xPushTaggedInt(payloadWord(con,0));
1122 StgWord offset = BCO_INSTR_16;
1123 StgInt x = xPopTaggedInt();
1124 StgInt y = xPopTaggedInt();
1130 Case(i_CONST_INTEGER):
1134 char* s = bcoConstAddr(bco,BCO_INSTR_8);
1136 n = size_fromStr(s);
1137 p = CreateByteArrayToHoldInteger(n);
1138 do_fromStr ( s, n, IntegerInsideByteArray(p));
1139 SloppifyIntegerEnd(p);
1146 StgWord w = xTaggedStackWord(BCO_INSTR_8);
1152 xPushTaggedWord(bcoConstWord(bco,BCO_INSTR_8));
1155 Case(i_CONST_WORD_big):
1157 StgWord n = BCO_INSTR_16;
1158 xPushTaggedWord(bcoConstWord(bco,n));
1164 SSS; o = (StgClosure*)grabHpNonUpd(Wzh_sizeW); LLL;
1165 SET_HDR(o,Wzh_con_info,??);
1166 payloadWord(o,0) = xPopTaggedWord();
1168 fprintf(stderr,"\tBuilt ");
1170 printObj(stgCast(StgClosure*,o));
1173 xPushPtr(stgCast(StgPtr,o));
1176 Case(i_UNPACK_WORD):
1178 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1179 /* ASSERT(isWordLike(con)); */
1180 xPushTaggedWord(payloadWord(con,0));
1185 StgAddr a = xTaggedStackAddr(BCO_INSTR_8);
1191 xPushTaggedAddr(bcoConstAddr(bco,BCO_INSTR_8));
1194 Case(i_CONST_ADDR_big):
1196 int n = BCO_INSTR_16;
1197 xPushTaggedAddr(bcoConstAddr(bco,n));
1203 SSS; o = (StgClosure*)grabHpNonUpd(Azh_sizeW); LLL;
1204 SET_HDR(o,Azh_con_info,??);
1205 payloadPtr(o,0) = xPopTaggedAddr();
1207 fprintf(stderr,"\tBuilt ");
1209 printObj(stgCast(StgClosure*,o));
1212 xPushPtr(stgCast(StgPtr,o));
1215 Case(i_UNPACK_ADDR):
1217 StgClosure* con = (StgClosure*)xStackPtr(0);
1218 /* ASSERT(isAddrLike(con)); */
1219 xPushTaggedAddr(payloadPtr(con,0));
1224 StgChar c = xTaggedStackChar(BCO_INSTR_8);
1230 xPushTaggedChar(bcoConstChar(bco,BCO_INSTR_8));
1236 SSS; o = (StgClosure*)grabHpNonUpd(Czh_sizeW); LLL;
1237 SET_HDR(o,Czh_con_info,??);
1238 payloadWord(o,0) = xPopTaggedChar();
1239 xPushPtr(stgCast(StgPtr,o));
1241 fprintf(stderr,"\tBuilt ");
1243 printObj(stgCast(StgClosure*,o));
1248 Case(i_UNPACK_CHAR):
1250 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1251 /* ASSERT(isCharLike(con)); */
1252 xPushTaggedChar(payloadWord(con,0));
1257 StgFloat f = xTaggedStackFloat(BCO_INSTR_8);
1258 xPushTaggedFloat(f);
1261 Case(i_CONST_FLOAT):
1263 xPushTaggedFloat(bcoConstFloat(bco,BCO_INSTR_8));
1269 SSS; o = (StgClosure*)grabHpNonUpd(Fzh_sizeW); LLL;
1270 SET_HDR(o,Fzh_con_info,??);
1271 ASSIGN_FLT(&payloadWord(o,0),xPopTaggedFloat());
1273 fprintf(stderr,"\tBuilt ");
1275 printObj(stgCast(StgClosure*,o));
1278 xPushPtr(stgCast(StgPtr,o));
1281 Case(i_UNPACK_FLOAT):
1283 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1284 /* ASSERT(isFloatLike(con)); */
1285 xPushTaggedFloat(PK_FLT(&payloadWord(con,0)));
1290 StgDouble d = xTaggedStackDouble(BCO_INSTR_8);
1291 xPushTaggedDouble(d);
1294 Case(i_CONST_DOUBLE):
1296 xPushTaggedDouble(bcoConstDouble(bco,BCO_INSTR_8));
1299 Case(i_CONST_DOUBLE_big):
1301 int n = BCO_INSTR_16;
1302 xPushTaggedDouble(bcoConstDouble(bco,n));
1305 Case(i_PACK_DOUBLE):
1308 SSS; o = (StgClosure*)grabHpNonUpd(Dzh_sizeW); LLL;
1309 SET_HDR(o,Dzh_con_info,??);
1310 ASSIGN_DBL(&payloadWord(o,0),xPopTaggedDouble());
1312 fprintf(stderr,"\tBuilt ");
1313 printObj(stgCast(StgClosure*,o));
1315 xPushPtr(stgCast(StgPtr,o));
1318 Case(i_UNPACK_DOUBLE):
1320 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1321 /* ASSERT(isDoubleLike(con)); */
1322 xPushTaggedDouble(PK_DBL(&payloadWord(con,0)));
1327 StgStablePtr s = xTaggedStackStable(BCO_INSTR_8);
1328 xPushTaggedStable(s);
1331 Case(i_PACK_STABLE):
1334 SSS; o = (StgClosure*)grabHpNonUpd(Stablezh_sizeW); LLL;
1335 SET_HDR(o,StablePtr_con_info,??);
1336 payloadWord(o,0) = (W_)xPopTaggedStable();
1338 fprintf(stderr,"\tBuilt ");
1340 printObj(stgCast(StgClosure*,o));
1343 xPushPtr(stgCast(StgPtr,o));
1346 Case(i_UNPACK_STABLE):
1348 StgClosure* con = (StgClosure*)xStackPtr(0);
1349 /* ASSERT(isStableLike(con)); */
1350 xPushTaggedStable(payloadWord(con,0));
1358 SSS; p = enterBCO_primop1 ( i ); LLL;
1359 if (p) { obj = p; goto enterLoop; };
1364 int i, trc, pc_saved;
1367 trc = 12345678; /* Assume != any StgThreadReturnCode */
1372 p = enterBCO_primop2 ( i, &trc, &bco_tmp, cap,
1376 bciPtr = &(bcoInstr(bco,pc_saved));
1378 if (trc == 12345678) {
1379 /* we want to enter p */
1380 obj = p; goto enterLoop;
1382 /* trc is the the StgThreadReturnCode for
1384 RETURN((StgThreadReturnCode)trc);
1390 /* combined insns, created by peephole opt */
1393 int x = BCO_INSTR_8;
1394 int y = BCO_INSTR_8;
1395 ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
1396 /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
1403 xSetStackWord(x+y,xStackWord(x));
1413 p = xStackPtr(BCO_INSTR_8);
1415 p = xStackPtr(BCO_INSTR_8);
1422 xPushPtr(bcoConstPtr(bco,BCO_INSTR_8));
1423 xPushPtr(stgCast(StgPtr,&ret_bco_info));
1424 p = xStackPtr(BCO_INSTR_8);
1430 StgPtr retaddr = bcoConstPtr(bco,BCO_INSTR_8);
1431 StgPtr ptr = xStackPtr(BCO_INSTR_8);
1433 /* A shortcut. We're going to push the address of a
1434 return continuation, and then enter a variable, so
1435 that when the var is evaluated, we return to the
1436 continuation. The shortcut is: if the var is a
1437 constructor, don't bother to enter it. Instead,
1438 push the variable on the stack (since this is what
1439 the continuation expects) and jump directly to the
1442 if (get_itbl((StgClosure*)ptr)->type == CONSTR) {
1444 obj = (StgClosure*)retaddr;
1446 fprintf(stderr, "object to enter is a constructor -- "
1447 "jumping directly to return continuation\n" );
1452 /* This is the normal, non-short-cut route */
1454 xPushPtr(stgCast(StgPtr,&ret_bco_info));
1455 obj = (StgClosure*)ptr;
1460 Case(i_VAR_DOUBLE_big):
1461 Case(i_CONST_FLOAT_big):
1462 Case(i_VAR_FLOAT_big):
1463 Case(i_CONST_CHAR_big):
1464 Case(i_VAR_CHAR_big):
1465 Case(i_VAR_ADDR_big):
1466 Case(i_VAR_STABLE_big):
1467 Case(i_CONST_INTEGER_big):
1468 Case(i_VAR_INT_big):
1469 Case(i_VAR_WORD_big):
1470 Case(i_RETADDR_big):
1475 Case(i_TEST_INJ_CONST):
1476 Case(i_TEST_INJ_big):
1478 Case(i_PACK_INJ_CONST):
1479 Case(i_PACK_INJ_big):
1481 Case(i_PACK_ROW_big):
1483 Case(i_ALLOC_ROW_big):
1488 disInstr ( bco, PC );
1489 barf("\nUnrecognised instruction");
1493 barf("enterBCO: ran off end of loop");
1497 # undef LoopTopLabel
1503 /* ---------------------------------------------------- */
1504 /* End of the bytecode evaluator */
1505 /* ---------------------------------------------------- */
1509 StgBlockingQueue* bh;
1510 StgCAF* caf = (StgCAF*)obj;
1511 if (xSp - sizeofW(StgUpdateFrame) < xSpLim) {
1512 xPushCPtr(obj); /* code to restart with */
1513 RETURN(StackOverflow);
1515 SSS; bh = (StgBlockingQueue*)grabHpUpd(BLACKHOLE_sizeW()); LLL;
1516 SET_INFO(bh,&CAF_BLACKHOLE_info);
1517 bh->blocking_queue = EndTSOQueue;
1519 fprintf(stderr,"Created CAF_BLACKHOLE %p for CAF %p"
1520 " in evaluator\n",bh,caf));
1521 SET_INFO(caf,&CAF_ENTERED_info);
1522 caf->value = (StgClosure*)bh;
1524 SSS; newCAF_made_by_Hugs(caf); LLL;
1526 xPushUpdateFrame(bh,0);
1527 xSp -= sizeofW(StgUpdateFrame);
1533 StgCAF* caf = (StgCAF*)obj;
1534 obj = caf->value; /* it's just a fancy indirection */
1540 case SE_CAF_BLACKHOLE:
1542 /* Let the scheduler figure out what to do :-) */
1543 cap->rCurrentTSO->what_next = ThreadEnterGHC;
1545 RETURN(ThreadYielding);
1549 StgAP_UPD* ap = stgCast(StgAP_UPD*,obj);
1551 if (xSp - (i + sizeofW(StgUpdateFrame)) < xSpLim) {
1552 xPushCPtr(obj); /* code to restart with */
1553 RETURN(StackOverflow);
1555 /* ToDo: look for xSp==xSu && stackInt(0) == UPD_FRAME
1556 and insert an indirection immediately */
1557 xPushUpdateFrame(ap,0);
1558 xSp -= sizeofW(StgUpdateFrame);
1560 xPushWord(payloadWord(ap,i));
1563 #ifdef EAGER_BLACKHOLING
1564 #warn LAZY_BLACKHOLING is default for StgHugs
1565 #error Dont know if EAGER_BLACKHOLING works in StgHugs
1567 /* superfluous - but makes debugging easier */
1568 StgBlackHole* bh = stgCast(StgBlackHole*,ap);
1569 SET_INFO(bh,&BLACKHOLE_info);
1570 bh->blocking_queue = EndTSOQueue;
1572 fprintf(stderr,"Eagerly blackholed AP_UPD %p in evaluator\n",bh));
1575 #endif /* EAGER_BLACKHOLING */
1580 StgPAP* pap = stgCast(StgPAP*,obj);
1581 int i = pap->n_args; /* ToDo: stack check */
1582 /* ToDo: if PAP is in whnf, we can update any update frames
1586 xPushWord(payloadWord(pap,i));
1593 obj = stgCast(StgInd*,obj)->indirectee;
1598 obj = stgCast(StgIndOldGen*,obj)->indirectee;
1607 case CONSTR_INTLIKE:
1608 case CONSTR_CHARLIKE:
1610 case CONSTR_NOCAF_STATIC:
1612 /* rows are mutarrays and should be treated as constructors. */
1613 case MUT_ARR_PTRS_FROZEN:
1617 switch (get_itbl(stgCast(StgClosure*,xSp))->type) {
1619 SSS; PopCatchFrame(); LLL;
1622 xPopUpdateFrame(obj);
1625 SSS; PopSeqFrame(); LLL;
1629 ASSERT(xSp==(P_)xSu);
1632 fprintf(stderr, "hit a STOP_FRAME\n");
1634 fprintf(stderr,"xSp = %p\txSu = %p\n", xSp, xSu);
1635 printStack(xSp,cap->rCurrentTSO->stack
1636 + cap->rCurrentTSO->stack_size,xSu);
1639 cap->rCurrentTSO->what_next = ThreadComplete;
1640 SSS; PopStopFrame(obj); LLL;
1642 RETURN(ThreadFinished);
1652 /* was: goto enterLoop;
1653 But we know that obj must be a bco now, so jump directly.
1656 case RET_SMALL: /* return to GHC */
1660 cap->rCurrentTSO->what_next = ThreadEnterGHC;
1662 RETURN(ThreadYielding);
1664 belch("entered CONSTR with invalid continuation on stack");
1667 printObj(stgCast(StgClosure*,xSp));
1670 barf("bailing out");
1677 //fprintf(stderr, "enterCountI = %d\n", enterCountI);
1678 //fprintf(stderr, "entering unknown closure -- yielding to sched\n");
1681 cap->rCurrentTSO->what_next = ThreadEnterGHC;
1682 xPushCPtr(obj); /* code to restart with */
1683 RETURN(ThreadYielding);
1686 barf("Ran off the end of enter - yoiks");
1703 #undef xSetStackWord
1706 #undef xPushTaggedInt
1707 #undef xPopTaggedInt
1708 #undef xTaggedStackInt
1709 #undef xPushTaggedWord
1710 #undef xPopTaggedWord
1711 #undef xTaggedStackWord
1712 #undef xPushTaggedAddr
1713 #undef xTaggedStackAddr
1714 #undef xPopTaggedAddr
1715 #undef xPushTaggedStable
1716 #undef xTaggedStackStable
1717 #undef xPopTaggedStable
1718 #undef xPushTaggedChar
1719 #undef xTaggedStackChar
1720 #undef xPopTaggedChar
1721 #undef xPushTaggedFloat
1722 #undef xTaggedStackFloat
1723 #undef xPopTaggedFloat
1724 #undef xPushTaggedDouble
1725 #undef xTaggedStackDouble
1726 #undef xPopTaggedDouble
1727 #undef xPopUpdateFrame
1728 #undef xPushUpdateFrame
1731 /* --------------------------------------------------------------------------
1732 * Supporting routines for primops
1733 * ------------------------------------------------------------------------*/
1735 static inline void PushTag ( StackTag t )
1737 inline void PushPtr ( StgPtr x )
1738 { *(--stgCast(StgPtr*,gSp)) = x; }
1739 static inline void PushCPtr ( StgClosure* x )
1740 { *(--stgCast(StgClosure**,gSp)) = x; }
1741 static inline void PushInt ( StgInt x )
1742 { *(--stgCast(StgInt*,gSp)) = x; }
1743 static inline void PushWord ( StgWord x )
1744 { *(--stgCast(StgWord*,gSp)) = x; }
1747 static inline void checkTag ( StackTag t1, StackTag t2 )
1748 { ASSERT(t1 == t2);}
1749 static inline void PopTag ( StackTag t )
1750 { checkTag(t,*(gSp++)); }
1751 inline StgPtr PopPtr ( void )
1752 { return *stgCast(StgPtr*,gSp)++; }
1753 static inline StgClosure* PopCPtr ( void )
1754 { return *stgCast(StgClosure**,gSp)++; }
1755 static inline StgInt PopInt ( void )
1756 { return *stgCast(StgInt*,gSp)++; }
1757 static inline StgWord PopWord ( void )
1758 { return *stgCast(StgWord*,gSp)++; }
1760 static inline StgPtr stackPtr ( StgStackOffset i )
1761 { return *stgCast(StgPtr*, gSp+i); }
1762 static inline StgInt stackInt ( StgStackOffset i )
1763 { return *stgCast(StgInt*, gSp+i); }
1764 static inline StgWord stackWord ( StgStackOffset i )
1765 { return *stgCast(StgWord*,gSp+i); }
1767 static inline void setStackWord ( StgStackOffset i, StgWord w )
1771 static inline void setStackPtr ( StgStackOffset i, StgPtr p )
1772 { *(stgCast(StgPtr*, gSp+i)) = p; }
1775 static inline void PushTaggedRealWorld( void )
1776 { PushTag(REALWORLD_TAG); }
1777 inline void PushTaggedInt ( StgInt x )
1778 { gSp -= sizeofW(StgInt); *gSp = x; PushTag(INT_TAG); }
1779 inline void PushTaggedWord ( StgWord x )
1780 { gSp -= sizeofW(StgWord); *gSp = x; PushTag(WORD_TAG); }
1781 inline void PushTaggedAddr ( StgAddr x )
1782 { gSp -= sizeofW(StgAddr); *gSp = (W_)x; PushTag(ADDR_TAG); }
1783 inline void PushTaggedChar ( StgChar x )
1784 { gSp -= sizeofW(StgChar); *gSp = stgCast(StgWord,x); PushTag(CHAR_TAG); }
1785 inline void PushTaggedFloat ( StgFloat x )
1786 { gSp -= sizeofW(StgFloat); ASSIGN_FLT(gSp,x); PushTag(FLOAT_TAG); }
1787 inline void PushTaggedDouble ( StgDouble x )
1788 { gSp -= sizeofW(StgDouble); ASSIGN_DBL(gSp,x); PushTag(DOUBLE_TAG); }
1789 inline void PushTaggedStablePtr ( StgStablePtr x )
1790 { gSp -= sizeofW(StgStablePtr); *gSp = (W_)x; PushTag(STABLE_TAG); }
1791 static inline void PushTaggedBool ( int x )
1792 { PushTaggedInt(x); }
1796 static inline void PopTaggedRealWorld ( void )
1797 { PopTag(REALWORLD_TAG); }
1798 inline StgInt PopTaggedInt ( void )
1799 { StgInt r; PopTag(INT_TAG); r = *stgCast(StgInt*, gSp);
1800 gSp += sizeofW(StgInt); return r;}
1801 inline StgWord PopTaggedWord ( void )
1802 { StgWord r; PopTag(WORD_TAG); r = *stgCast(StgWord*, gSp);
1803 gSp += sizeofW(StgWord); return r;}
1804 inline StgAddr PopTaggedAddr ( void )
1805 { StgAddr r; PopTag(ADDR_TAG); r = *stgCast(StgAddr*, gSp);
1806 gSp += sizeofW(StgAddr); return r;}
1807 inline StgChar PopTaggedChar ( void )
1808 { StgChar r; PopTag(CHAR_TAG); r = stgCast(StgChar, *gSp);
1809 gSp += sizeofW(StgChar); return r;}
1810 inline StgFloat PopTaggedFloat ( void )
1811 { StgFloat r; PopTag(FLOAT_TAG); r = PK_FLT(gSp);
1812 gSp += sizeofW(StgFloat); return r;}
1813 inline StgDouble PopTaggedDouble ( void )
1814 { StgDouble r; PopTag(DOUBLE_TAG); r = PK_DBL(gSp);
1815 gSp += sizeofW(StgDouble); return r;}
1816 inline StgStablePtr PopTaggedStablePtr ( void )
1817 { StgStablePtr r; PopTag(STABLE_TAG); r = *stgCast(StgStablePtr*, gSp);
1818 gSp += sizeofW(StgStablePtr); return r;}
1822 static inline StgInt taggedStackInt ( StgStackOffset i )
1823 { checkTag(INT_TAG,gSp[i]); return *stgCast(StgInt*, gSp+1+i); }
1824 static inline StgWord taggedStackWord ( StgStackOffset i )
1825 { checkTag(WORD_TAG,gSp[i]); return *stgCast(StgWord*, gSp+1+i); }
1826 static inline StgAddr taggedStackAddr ( StgStackOffset i )
1827 { checkTag(ADDR_TAG,gSp[i]); return *stgCast(StgAddr*, gSp+1+i); }
1828 static inline StgChar taggedStackChar ( StgStackOffset i )
1829 { checkTag(CHAR_TAG,gSp[i]); return stgCast(StgChar, *(gSp+1+i)) ; }
1830 static inline StgFloat taggedStackFloat ( StgStackOffset i )
1831 { checkTag(FLOAT_TAG,gSp[i]); return PK_FLT(gSp+1+i); }
1832 static inline StgDouble taggedStackDouble ( StgStackOffset i )
1833 { checkTag(DOUBLE_TAG,gSp[i]); return PK_DBL(gSp+1+i); }
1834 static inline StgStablePtr taggedStackStable ( StgStackOffset i )
1835 { checkTag(STABLE_TAG,gSp[i]); return *stgCast(StgStablePtr*, gSp+1+i); }
1838 /* --------------------------------------------------------------------------
1841 * Should we allocate from a nursery or use the
1842 * doYouWantToGC/allocate interface? We'd already implemented a
1843 * nursery-style scheme when the doYouWantToGC/allocate interface
1845 * One reason to prefer the doYouWantToGC/allocate interface is to
1846 * support operations which allocate an unknown amount in the heap
1847 * (array ops, gmp ops, etc)
1848 * ------------------------------------------------------------------------*/
1850 static inline StgPtr grabHpUpd( nat size )
1852 ASSERT( size >= MIN_UPD_SIZE + sizeofW(StgHeader) );
1853 return allocate(size);
1856 static inline StgPtr grabHpNonUpd( nat size )
1858 ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
1859 return allocate(size);
1862 /* --------------------------------------------------------------------------
1863 * Manipulate "update frame" list:
1864 * o Update frames (based on stg_do_update and friends in Updates.hc)
1865 * o Error handling/catching (based on catchzh_fast and friends in Prims.hc)
1866 * o Seq frames (based on seq_frame_entry in Prims.hc)
1868 * ------------------------------------------------------------------------*/
1870 static inline void PopUpdateFrame ( StgClosure* obj )
1872 /* NB: doesn't assume that gSp == gSu */
1874 fprintf(stderr, "Updating ");
1875 printPtr(stgCast(StgPtr,gSu->updatee));
1876 fprintf(stderr, " with ");
1878 fprintf(stderr,"gSp = %p\tgSu = %p\n\n", gSp, gSu);
1880 #ifdef EAGER_BLACKHOLING
1881 #warn LAZY_BLACKHOLING is default for StgHugs
1882 #error Dont know if EAGER_BLACKHOLING works in StgHugs
1883 ASSERT(get_itbl(gSu->updatee)->type == BLACKHOLE
1884 || get_itbl(gSu->updatee)->type == SE_BLACKHOLE
1885 || get_itbl(gSu->updatee)->type == CAF_BLACKHOLE
1886 || get_itbl(gSu->updatee)->type == SE_CAF_BLACKHOLE
1888 #endif /* EAGER_BLACKHOLING */
1889 UPD_IND(gSu->updatee,obj);
1890 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgUpdateFrame);
1894 static inline void PopStopFrame ( StgClosure* obj )
1896 /* Move gSu just off the end of the stack, we're about to gSpam the
1897 * STOP_FRAME with the return value.
1899 gSu = stgCast(StgUpdateFrame*,gSp+1);
1900 *stgCast(StgClosure**,gSp) = obj;
1903 static inline void PushCatchFrame ( StgClosure* handler )
1906 /* ToDo: stack check! */
1907 gSp -= sizeofW(StgCatchFrame);
1908 fp = stgCast(StgCatchFrame*,gSp);
1909 SET_HDR(fp,(StgInfoTable*)&catch_frame_info,CCCS);
1910 fp->handler = handler;
1912 gSu = stgCast(StgUpdateFrame*,fp);
1915 static inline void PopCatchFrame ( void )
1917 /* NB: doesn't assume that gSp == gSu */
1918 /* fprintf(stderr,"Popping catch frame\n"); */
1919 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgCatchFrame);
1920 gSu = stgCast(StgCatchFrame*,gSu)->link;
1923 static inline void PushSeqFrame ( void )
1926 /* ToDo: stack check! */
1927 gSp -= sizeofW(StgSeqFrame);
1928 fp = stgCast(StgSeqFrame*,gSp);
1929 SET_HDR(fp,(StgInfoTable*)&seq_frame_info,CCCS);
1931 gSu = stgCast(StgUpdateFrame*,fp);
1934 static inline void PopSeqFrame ( void )
1936 /* NB: doesn't assume that gSp == gSu */
1937 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgSeqFrame);
1938 gSu = stgCast(StgSeqFrame*,gSu)->link;
1941 static inline StgClosure* raiseAnError ( StgClosure* exception )
1943 /* This closure represents the expression 'primRaise E' where E
1944 * is the exception raised (:: Exception).
1945 * It is used to overwrite all the
1946 * thunks which are currently under evaluation.
1948 HaskellObj primRaiseClosure
1949 = getHugs_BCO_cptr_for("primRaise");
1950 HaskellObj reraiseClosure
1951 = rts_apply ( primRaiseClosure, exception );
1954 switch (get_itbl(gSu)->type) {
1956 UPD_IND(gSu->updatee,reraiseClosure);
1957 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgUpdateFrame);
1963 case CATCH_FRAME: /* found it! */
1965 StgCatchFrame* fp = stgCast(StgCatchFrame*,gSu);
1966 StgClosure *handler = fp->handler;
1968 gSp += sizeofW(StgCatchFrame); /* Pop */
1969 PushCPtr(exception);
1973 barf("raiseError: uncaught exception: STOP_FRAME");
1975 barf("raiseError: weird activation record");
1981 static StgClosure* makeErrorCall ( const char* msg )
1983 /* Note! the msg string should be allocated in a
1984 place which will not get freed -- preferably
1985 read-only data of the program. That's because
1986 the thunk we build here may linger indefinitely.
1987 (thinks: probably not so, but anyway ...)
1990 = getHugs_BCO_cptr_for("error");
1992 = getHugs_BCO_cptr_for("hugsprimUnpackString");
1994 = rts_apply ( unpack, rts_mkAddr ( (void*)msg ) );
1996 = rts_apply ( error, thunk );
1998 (StgClosure*) thunk;
2001 #define raiseIndex(where) makeErrorCall("Array index out of range in " where)
2002 #define raiseDiv0(where) makeErrorCall("Division by zero in " where)
2004 /* --------------------------------------------------------------------------
2006 * ------------------------------------------------------------------------*/
2008 #define OP_CC_B(e) \
2010 unsigned char x = PopTaggedChar(); \
2011 unsigned char y = PopTaggedChar(); \
2012 PushTaggedBool(e); \
2017 unsigned char x = PopTaggedChar(); \
2026 #define OP_IW_I(e) \
2028 StgInt x = PopTaggedInt(); \
2029 StgWord y = PopTaggedWord(); \
2033 #define OP_II_I(e) \
2035 StgInt x = PopTaggedInt(); \
2036 StgInt y = PopTaggedInt(); \
2040 #define OP_II_B(e) \
2042 StgInt x = PopTaggedInt(); \
2043 StgInt y = PopTaggedInt(); \
2044 PushTaggedBool(e); \
2049 PushTaggedAddr(e); \
2054 StgInt x = PopTaggedInt(); \
2055 PushTaggedAddr(e); \
2060 StgInt x = PopTaggedInt(); \
2066 PushTaggedChar(e); \
2071 StgInt x = PopTaggedInt(); \
2072 PushTaggedChar(e); \
2077 PushTaggedWord(e); \
2082 StgInt x = PopTaggedInt(); \
2083 PushTaggedWord(e); \
2088 StgInt x = PopTaggedInt(); \
2089 PushTaggedStablePtr(e); \
2094 PushTaggedFloat(e); \
2099 StgInt x = PopTaggedInt(); \
2100 PushTaggedFloat(e); \
2105 PushTaggedDouble(e); \
2110 StgInt x = PopTaggedInt(); \
2111 PushTaggedDouble(e); \
2114 #define OP_WW_B(e) \
2116 StgWord x = PopTaggedWord(); \
2117 StgWord y = PopTaggedWord(); \
2118 PushTaggedBool(e); \
2121 #define OP_WW_W(e) \
2123 StgWord x = PopTaggedWord(); \
2124 StgWord y = PopTaggedWord(); \
2125 PushTaggedWord(e); \
2130 StgWord x = PopTaggedWord(); \
2136 StgStablePtr x = PopTaggedStablePtr(); \
2142 StgWord x = PopTaggedWord(); \
2143 PushTaggedWord(e); \
2146 #define OP_AA_B(e) \
2148 StgAddr x = PopTaggedAddr(); \
2149 StgAddr y = PopTaggedAddr(); \
2150 PushTaggedBool(e); \
2154 StgAddr x = PopTaggedAddr(); \
2157 #define OP_AI_C(s) \
2159 StgAddr x = PopTaggedAddr(); \
2160 int y = PopTaggedInt(); \
2163 PushTaggedChar(r); \
2165 #define OP_AI_I(s) \
2167 StgAddr x = PopTaggedAddr(); \
2168 int y = PopTaggedInt(); \
2173 #define OP_AI_A(s) \
2175 StgAddr x = PopTaggedAddr(); \
2176 int y = PopTaggedInt(); \
2179 PushTaggedAddr(s); \
2181 #define OP_AI_F(s) \
2183 StgAddr x = PopTaggedAddr(); \
2184 int y = PopTaggedInt(); \
2187 PushTaggedFloat(r); \
2189 #define OP_AI_D(s) \
2191 StgAddr x = PopTaggedAddr(); \
2192 int y = PopTaggedInt(); \
2195 PushTaggedDouble(r); \
2197 #define OP_AI_s(s) \
2199 StgAddr x = PopTaggedAddr(); \
2200 int y = PopTaggedInt(); \
2203 PushTaggedStablePtr(r); \
2205 #define OP_AIC_(s) \
2207 StgAddr x = PopTaggedAddr(); \
2208 int y = PopTaggedInt(); \
2209 StgChar z = PopTaggedChar(); \
2212 #define OP_AII_(s) \
2214 StgAddr x = PopTaggedAddr(); \
2215 int y = PopTaggedInt(); \
2216 StgInt z = PopTaggedInt(); \
2219 #define OP_AIA_(s) \
2221 StgAddr x = PopTaggedAddr(); \
2222 int y = PopTaggedInt(); \
2223 StgAddr z = PopTaggedAddr(); \
2226 #define OP_AIF_(s) \
2228 StgAddr x = PopTaggedAddr(); \
2229 int y = PopTaggedInt(); \
2230 StgFloat z = PopTaggedFloat(); \
2233 #define OP_AID_(s) \
2235 StgAddr x = PopTaggedAddr(); \
2236 int y = PopTaggedInt(); \
2237 StgDouble z = PopTaggedDouble(); \
2240 #define OP_AIs_(s) \
2242 StgAddr x = PopTaggedAddr(); \
2243 int y = PopTaggedInt(); \
2244 StgStablePtr z = PopTaggedStablePtr(); \
2249 #define OP_FF_B(e) \
2251 StgFloat x = PopTaggedFloat(); \
2252 StgFloat y = PopTaggedFloat(); \
2253 PushTaggedBool(e); \
2256 #define OP_FF_F(e) \
2258 StgFloat x = PopTaggedFloat(); \
2259 StgFloat y = PopTaggedFloat(); \
2260 PushTaggedFloat(e); \
2265 StgFloat x = PopTaggedFloat(); \
2266 PushTaggedFloat(e); \
2271 StgFloat x = PopTaggedFloat(); \
2272 PushTaggedBool(e); \
2277 StgFloat x = PopTaggedFloat(); \
2283 StgFloat x = PopTaggedFloat(); \
2284 PushTaggedDouble(e); \
2287 #define OP_DD_B(e) \
2289 StgDouble x = PopTaggedDouble(); \
2290 StgDouble y = PopTaggedDouble(); \
2291 PushTaggedBool(e); \
2294 #define OP_DD_D(e) \
2296 StgDouble x = PopTaggedDouble(); \
2297 StgDouble y = PopTaggedDouble(); \
2298 PushTaggedDouble(e); \
2303 StgDouble x = PopTaggedDouble(); \
2304 PushTaggedBool(e); \
2309 StgDouble x = PopTaggedDouble(); \
2310 PushTaggedDouble(e); \
2315 StgDouble x = PopTaggedDouble(); \
2321 StgDouble x = PopTaggedDouble(); \
2322 PushTaggedFloat(e); \
2326 StgPtr CreateByteArrayToHoldInteger ( int nbytes )
2328 StgWord words = (nbytes+sizeof(W_)-1)/sizeof(W_);
2329 StgWord size = sizeofW(StgArrWords) + words;
2330 StgArrWords* arr = (StgArrWords*)allocate(size);
2331 SET_HDR(arr,&ARR_WORDS_info,CCCS);
2333 ASSERT((W_)nbytes <= arr->words * sizeof(W_));
2336 for (i = 0; i < words; ++i) {
2337 arr->payload[i] = 0xdeadbeef;
2339 { B* b = (B*) &(arr->payload[0]);
2340 b->used = b->sign = 0;
2346 B* IntegerInsideByteArray ( StgPtr arr0 )
2349 StgArrWords* arr = (StgArrWords*)arr0;
2350 ASSERT(GET_INFO(arr) == &ARR_WORDS_info);
2351 b = (B*) &(arr->payload[0]);
2355 void SloppifyIntegerEnd ( StgPtr arr0 )
2357 StgArrWords* arr = (StgArrWords*)arr0;
2358 B* b = (B*) & (arr->payload[0]);
2359 I_ nwunused = arr->words - sizeofW(B) - (b->used+sizeof(W_)-1)/sizeof(W_);
2360 if (nwunused >= ((I_)sizeofW(StgArrWords))) {
2362 b->size -= nwunused * sizeof(W_);
2363 if (b->size < b->used) b->size = b->used;
2366 arr->words -= nwunused;
2367 slop = (StgArrWords*)&(arr->payload[arr->words]);
2368 SET_HDR(slop,&ARR_WORDS_info,CCCS);
2369 slop->words = nwunused - sizeofW(StgArrWords);
2370 ASSERT( &(slop->payload[slop->words]) ==
2371 &(arr->payload[arr->words + nwunused]) );
2375 #define OP_Z_Z(op) \
2377 B* x = IntegerInsideByteArray(PopPtr()); \
2378 int n = mycat2(size_,op)(x); \
2379 StgPtr p = CreateByteArrayToHoldInteger(n); \
2380 mycat2(do_,op)(x,n,IntegerInsideByteArray(p)); \
2381 SloppifyIntegerEnd(p); \
2384 #define OP_ZZ_Z(op) \
2386 B* x = IntegerInsideByteArray(PopPtr()); \
2387 B* y = IntegerInsideByteArray(PopPtr()); \
2388 int n = mycat2(size_,op)(x,y); \
2389 StgPtr p = CreateByteArrayToHoldInteger(n); \
2390 mycat2(do_,op)(x,y,n,IntegerInsideByteArray(p)); \
2391 SloppifyIntegerEnd(p); \
2398 #define HEADER_mI(ty,where) \
2399 StgArrWords* x = stgCast(StgArrWords*,PopPtr()); \
2400 nat i = PopTaggedInt(); \
2401 if (i * sizeof(ty) + (sizeof(ty)) > sizeof(StgWord) * x->words) { \
2402 return (raiseIndex(where)); \
2404 #define OP_mI_ty(ty,where,s) \
2406 HEADER_mI(mycat2(Stg,ty),where) \
2407 { mycat2(Stg,ty) r; \
2409 mycat2(PushTagged,ty)(r); \
2412 #define OP_mIty_(ty,where,s) \
2414 HEADER_mI(mycat2(Stg,ty),where) \
2416 mycat2(Stg,ty) z = mycat2(PopTagged,ty)(); \
2422 __attribute__ ((unused))
2423 static void myStackCheck ( Capability* cap )
2425 /* fprintf(stderr, "myStackCheck\n"); */
2426 if (!(gSpLim <= gSp && gSp <= stgCast(StgPtr,gSu))) {
2427 fprintf(stderr, "myStackCheck: invalid initial gSp/gSu \n" );
2432 if (!( (P_)gSu >= (P_)cap->rCurrentTSO->stack
2434 (P_)gSu <= (P_)(cap->rCurrentTSO->stack
2435 + cap->rCurrentTSO->stack_size))) {
2436 fprintf ( stderr, "myStackCheck: gSu out of stack\n" );
2440 switch (get_itbl(stgCast(StgClosure*,gSu))->type) {
2442 gSu = (StgUpdateFrame*) ((StgCatchFrame*)(gSu))->link;
2445 gSu = (StgUpdateFrame*) ((StgUpdateFrame*)(gSu))->link;
2448 gSu = (StgUpdateFrame*) ((StgSeqFrame*)(gSu))->link;
2453 fprintf(stderr, "myStackCheck: invalid activation record\n");
2462 /* --------------------------------------------------------------------------
2463 * Primop stuff for bytecode interpreter
2464 * ------------------------------------------------------------------------*/
2466 /* Returns & of the next thing to enter (if throwing an exception),
2467 or NULL in the normal case.
2469 static void* enterBCO_primop1 ( int primop1code )
2472 barf("enterBCO_primop1 in combined mode");
2474 switch (primop1code) {
2475 case i_pushseqframe:
2477 StgClosure* c = PopCPtr();
2482 case i_pushcatchframe:
2484 StgClosure* e = PopCPtr();
2485 StgClosure* h = PopCPtr();
2491 case i_gtChar: OP_CC_B(x>y); break;
2492 case i_geChar: OP_CC_B(x>=y); break;
2493 case i_eqChar: OP_CC_B(x==y); break;
2494 case i_neChar: OP_CC_B(x!=y); break;
2495 case i_ltChar: OP_CC_B(x<y); break;
2496 case i_leChar: OP_CC_B(x<=y); break;
2497 case i_charToInt: OP_C_I(x); break;
2498 case i_intToChar: OP_I_C(x); break;
2500 case i_gtInt: OP_II_B(x>y); break;
2501 case i_geInt: OP_II_B(x>=y); break;
2502 case i_eqInt: OP_II_B(x==y); break;
2503 case i_neInt: OP_II_B(x!=y); break;
2504 case i_ltInt: OP_II_B(x<y); break;
2505 case i_leInt: OP_II_B(x<=y); break;
2506 case i_minInt: OP__I(INT_MIN); break;
2507 case i_maxInt: OP__I(INT_MAX); break;
2508 case i_plusInt: OP_II_I(x+y); break;
2509 case i_minusInt: OP_II_I(x-y); break;
2510 case i_timesInt: OP_II_I(x*y); break;
2513 int x = PopTaggedInt();
2514 int y = PopTaggedInt();
2516 return (raiseDiv0("quotInt"));
2518 /* ToDo: protect against minInt / -1 errors
2519 * (repeat for all other division primops) */
2525 int x = PopTaggedInt();
2526 int y = PopTaggedInt();
2528 return (raiseDiv0("remInt"));
2535 StgInt x = PopTaggedInt();
2536 StgInt y = PopTaggedInt();
2538 return (raiseDiv0("quotRemInt"));
2540 PushTaggedInt(x%y); /* last result */
2541 PushTaggedInt(x/y); /* first result */
2544 case i_negateInt: OP_I_I(-x); break;
2546 case i_andInt: OP_II_I(x&y); break;
2547 case i_orInt: OP_II_I(x|y); break;
2548 case i_xorInt: OP_II_I(x^y); break;
2549 case i_notInt: OP_I_I(~x); break;
2550 case i_shiftLInt: OP_II_I(x<<y); break;
2551 case i_shiftRAInt: OP_II_I(x>>y); break; /* ToDo */
2552 case i_shiftRLInt: OP_II_I(x>>y); break; /* ToDo */
2554 case i_gtWord: OP_WW_B(x>y); break;
2555 case i_geWord: OP_WW_B(x>=y); break;
2556 case i_eqWord: OP_WW_B(x==y); break;
2557 case i_neWord: OP_WW_B(x!=y); break;
2558 case i_ltWord: OP_WW_B(x<y); break;
2559 case i_leWord: OP_WW_B(x<=y); break;
2560 case i_minWord: OP__W(0); break;
2561 case i_maxWord: OP__W(UINT_MAX); break;
2562 case i_plusWord: OP_WW_W(x+y); break;
2563 case i_minusWord: OP_WW_W(x-y); break;
2564 case i_timesWord: OP_WW_W(x*y); break;
2567 StgWord x = PopTaggedWord();
2568 StgWord y = PopTaggedWord();
2570 return (raiseDiv0("quotWord"));
2572 PushTaggedWord(x/y);
2577 StgWord x = PopTaggedWord();
2578 StgWord y = PopTaggedWord();
2580 return (raiseDiv0("remWord"));
2582 PushTaggedWord(x%y);
2587 StgWord x = PopTaggedWord();
2588 StgWord y = PopTaggedWord();
2590 return (raiseDiv0("quotRemWord"));
2592 PushTaggedWord(x%y); /* last result */
2593 PushTaggedWord(x/y); /* first result */
2596 case i_negateWord: OP_W_W(-x); break;
2597 case i_andWord: OP_WW_W(x&y); break;
2598 case i_orWord: OP_WW_W(x|y); break;
2599 case i_xorWord: OP_WW_W(x^y); break;
2600 case i_notWord: OP_W_W(~x); break;
2601 case i_shiftLWord: OP_WW_W(x<<y); break;
2602 case i_shiftRAWord: OP_WW_W(x>>y); break; /* ToDo */
2603 case i_shiftRLWord: OP_WW_W(x>>y); break; /* ToDo */
2604 case i_intToWord: OP_I_W(x); break;
2605 case i_wordToInt: OP_W_I(x); break;
2607 case i_gtAddr: OP_AA_B(x>y); break;
2608 case i_geAddr: OP_AA_B(x>=y); break;
2609 case i_eqAddr: OP_AA_B(x==y); break;
2610 case i_neAddr: OP_AA_B(x!=y); break;
2611 case i_ltAddr: OP_AA_B(x<y); break;
2612 case i_leAddr: OP_AA_B(x<=y); break;
2613 case i_intToAddr: OP_I_A((StgAddr)x); break; /* ToDo */
2614 case i_addrToInt: OP_A_I((StgInt)x); break; /* ToDo */
2616 case i_intToStable: OP_I_s((StgStablePtr)x); break;
2617 case i_stableToInt: OP_s_I((W_)x); break;
2619 case i_indexCharOffAddr: OP_AI_C(indexCharOffAddrzh(r,x,y)); break;
2620 case i_readCharOffAddr: OP_AI_C(indexCharOffAddrzh(r,x,y)); break;
2621 case i_writeCharOffAddr: OP_AIC_(writeCharOffAddrzh(x,y,z)); break;
2623 case i_indexIntOffAddr: OP_AI_I(indexIntOffAddrzh(r,x,y)); break;
2624 case i_readIntOffAddr: OP_AI_I(indexIntOffAddrzh(r,x,y)); break;
2625 case i_writeIntOffAddr: OP_AII_(writeIntOffAddrzh(x,y,z)); break;
2627 case i_indexAddrOffAddr: OP_AI_A(indexAddrOffAddrzh(r,x,y)); break;
2628 case i_readAddrOffAddr: OP_AI_A(indexAddrOffAddrzh(r,x,y)); break;
2629 case i_writeAddrOffAddr: OP_AIA_(writeAddrOffAddrzh(x,y,z)); break;
2631 case i_indexFloatOffAddr: OP_AI_F(indexFloatOffAddrzh(r,x,y)); break;
2632 case i_readFloatOffAddr: OP_AI_F(indexFloatOffAddrzh(r,x,y)); break;
2633 case i_writeFloatOffAddr: OP_AIF_(writeFloatOffAddrzh(x,y,z)); break;
2635 case i_indexDoubleOffAddr: OP_AI_D(indexDoubleOffAddrzh(r,x,y)); break;
2636 case i_readDoubleOffAddr: OP_AI_D(indexDoubleOffAddrzh(r,x,y)); break;
2637 case i_writeDoubleOffAddr: OP_AID_(writeDoubleOffAddrzh(x,y,z)); break;
2639 case i_indexStableOffAddr: OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break;
2640 case i_readStableOffAddr: OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break;
2641 case i_writeStableOffAddr: OP_AIs_(writeStablePtrOffAddrzh(x,y,z)); break;
2643 case i_compareInteger:
2645 B* x = IntegerInsideByteArray(PopPtr());
2646 B* y = IntegerInsideByteArray(PopPtr());
2647 StgInt r = do_cmp(x,y);
2648 PushTaggedInt(r<0 ? -1 : (r>0 ? 1 : 0));
2651 case i_negateInteger: OP_Z_Z(neg); break;
2652 case i_plusInteger: OP_ZZ_Z(add); break;
2653 case i_minusInteger: OP_ZZ_Z(sub); break;
2654 case i_timesInteger: OP_ZZ_Z(mul); break;
2655 case i_quotRemInteger:
2657 B* x = IntegerInsideByteArray(PopPtr());
2658 B* y = IntegerInsideByteArray(PopPtr());
2659 int n = size_qrm(x,y);
2660 StgPtr q = CreateByteArrayToHoldInteger(n);
2661 StgPtr r = CreateByteArrayToHoldInteger(n);
2662 if (do_getsign(y)==0)
2663 return (raiseDiv0("quotRemInteger"));
2664 do_qrm(x,y,n,IntegerInsideByteArray(q),
2665 IntegerInsideByteArray(r));
2666 SloppifyIntegerEnd(q);
2667 SloppifyIntegerEnd(r);
2672 case i_intToInteger:
2674 int n = size_fromInt();
2675 StgPtr p = CreateByteArrayToHoldInteger(n);
2676 do_fromInt( PopTaggedInt(), n, IntegerInsideByteArray(p));
2680 case i_wordToInteger:
2682 int n = size_fromWord();
2683 StgPtr p = CreateByteArrayToHoldInteger(n);
2684 do_fromWord( PopTaggedWord(), n, IntegerInsideByteArray(p));
2688 case i_integerToInt: PushTaggedInt(do_toInt(
2689 IntegerInsideByteArray(PopPtr())
2693 case i_integerToWord: PushTaggedWord(do_toWord(
2694 IntegerInsideByteArray(PopPtr())
2698 case i_integerToFloat: PushTaggedFloat(do_toFloat(
2699 IntegerInsideByteArray(PopPtr())
2703 case i_integerToDouble: PushTaggedDouble(do_toDouble(
2704 IntegerInsideByteArray(PopPtr())
2708 case i_gtFloat: OP_FF_B(x>y); break;
2709 case i_geFloat: OP_FF_B(x>=y); break;
2710 case i_eqFloat: OP_FF_B(x==y); break;
2711 case i_neFloat: OP_FF_B(x!=y); break;
2712 case i_ltFloat: OP_FF_B(x<y); break;
2713 case i_leFloat: OP_FF_B(x<=y); break;
2714 case i_minFloat: OP__F(FLT_MIN); break;
2715 case i_maxFloat: OP__F(FLT_MAX); break;
2716 case i_radixFloat: OP__I(FLT_RADIX); break;
2717 case i_digitsFloat: OP__I(FLT_MANT_DIG); break;
2718 case i_minExpFloat: OP__I(FLT_MIN_EXP); break;
2719 case i_maxExpFloat: OP__I(FLT_MAX_EXP); break;
2720 case i_plusFloat: OP_FF_F(x+y); break;
2721 case i_minusFloat: OP_FF_F(x-y); break;
2722 case i_timesFloat: OP_FF_F(x*y); break;
2725 StgFloat x = PopTaggedFloat();
2726 StgFloat y = PopTaggedFloat();
2727 PushTaggedFloat(x/y);
2730 case i_negateFloat: OP_F_F(-x); break;
2731 case i_floatToInt: OP_F_I(x); break;
2732 case i_intToFloat: OP_I_F(x); break;
2733 case i_expFloat: OP_F_F(exp(x)); break;
2734 case i_logFloat: OP_F_F(log(x)); break;
2735 case i_sqrtFloat: OP_F_F(sqrt(x)); break;
2736 case i_sinFloat: OP_F_F(sin(x)); break;
2737 case i_cosFloat: OP_F_F(cos(x)); break;
2738 case i_tanFloat: OP_F_F(tan(x)); break;
2739 case i_asinFloat: OP_F_F(asin(x)); break;
2740 case i_acosFloat: OP_F_F(acos(x)); break;
2741 case i_atanFloat: OP_F_F(atan(x)); break;
2742 case i_sinhFloat: OP_F_F(sinh(x)); break;
2743 case i_coshFloat: OP_F_F(cosh(x)); break;
2744 case i_tanhFloat: OP_F_F(tanh(x)); break;
2745 case i_powerFloat: OP_FF_F(pow(x,y)); break;
2747 case i_encodeFloatZ:
2749 StgPtr sig = PopPtr();
2750 StgInt exp = PopTaggedInt();
2752 B__encodeFloat(IntegerInsideByteArray(sig), exp)
2756 case i_decodeFloatZ:
2758 StgFloat f = PopTaggedFloat();
2759 StgPtr sig = CreateByteArrayToHoldInteger(size_fltmantissa());
2761 B__decodeFloat(IntegerInsideByteArray(sig), &exp, f);
2767 case i_isNaNFloat: OP_F_B(isFloatNaN(x)); break;
2768 case i_isInfiniteFloat: OP_F_B(isFloatInfinite(x)); break;
2769 case i_isNegativeZeroFloat: OP_F_B(isFloatNegativeZero(x)); break;
2770 case i_isDenormalizedFloat: OP_F_B(isFloatDenormalized(x)); break;
2771 case i_gtDouble: OP_DD_B(x>y); break;
2772 case i_geDouble: OP_DD_B(x>=y); break;
2773 case i_eqDouble: OP_DD_B(x==y); break;
2774 case i_neDouble: OP_DD_B(x!=y); break;
2775 case i_ltDouble: OP_DD_B(x<y); break;
2776 case i_leDouble: OP_DD_B(x<=y) break;
2777 case i_minDouble: OP__D(DBL_MIN); break;
2778 case i_maxDouble: OP__D(DBL_MAX); break;
2779 case i_radixDouble: OP__I(FLT_RADIX); break;
2780 case i_digitsDouble: OP__I(DBL_MANT_DIG); break;
2781 case i_minExpDouble: OP__I(DBL_MIN_EXP); break;
2782 case i_maxExpDouble: OP__I(DBL_MAX_EXP); break;
2783 case i_plusDouble: OP_DD_D(x+y); break;
2784 case i_minusDouble: OP_DD_D(x-y); break;
2785 case i_timesDouble: OP_DD_D(x*y); break;
2786 case i_divideDouble:
2788 StgDouble x = PopTaggedDouble();
2789 StgDouble y = PopTaggedDouble();
2790 PushTaggedDouble(x/y);
2793 case i_negateDouble: OP_D_D(-x); break;
2794 case i_doubleToInt: OP_D_I(x); break;
2795 case i_intToDouble: OP_I_D(x); break;
2796 case i_doubleToFloat: OP_D_F(x); break;
2797 case i_floatToDouble: OP_F_F(x); break;
2798 case i_expDouble: OP_D_D(exp(x)); break;
2799 case i_logDouble: OP_D_D(log(x)); break;
2800 case i_sqrtDouble: OP_D_D(sqrt(x)); break;
2801 case i_sinDouble: OP_D_D(sin(x)); break;
2802 case i_cosDouble: OP_D_D(cos(x)); break;
2803 case i_tanDouble: OP_D_D(tan(x)); break;
2804 case i_asinDouble: OP_D_D(asin(x)); break;
2805 case i_acosDouble: OP_D_D(acos(x)); break;
2806 case i_atanDouble: OP_D_D(atan(x)); break;
2807 case i_sinhDouble: OP_D_D(sinh(x)); break;
2808 case i_coshDouble: OP_D_D(cosh(x)); break;
2809 case i_tanhDouble: OP_D_D(tanh(x)); break;
2810 case i_powerDouble: OP_DD_D(pow(x,y)); break;
2812 case i_encodeDoubleZ:
2814 StgPtr sig = PopPtr();
2815 StgInt exp = PopTaggedInt();
2817 B__encodeDouble(IntegerInsideByteArray(sig), exp)
2821 case i_decodeDoubleZ:
2823 StgDouble d = PopTaggedDouble();
2824 StgPtr sig = CreateByteArrayToHoldInteger(size_dblmantissa());
2826 B__decodeDouble(IntegerInsideByteArray(sig), &exp, d);
2832 case i_isNaNDouble: OP_D_B(isDoubleNaN(x)); break;
2833 case i_isInfiniteDouble: OP_D_B(isDoubleInfinite(x)); break;
2834 case i_isNegativeZeroDouble: OP_D_B(isDoubleNegativeZero(x)); break;
2835 case i_isDenormalizedDouble: OP_D_B(isDoubleDenormalized(x)); break;
2836 case i_isIEEEDouble:
2838 PushTaggedBool(rtsTrue);
2842 barf("Unrecognised primop1");
2849 /* For normal cases, return NULL and leave *return2 unchanged.
2850 To return the address of the next thing to enter,
2851 return the address of it and leave *return2 unchanged.
2852 To return a StgThreadReturnCode to the scheduler,
2853 set *return2 to it and return a non-NULL value.
2854 To cause a context switch, set context_switch (its a global),
2855 and optionally set hugsBlock to your rational.
2857 static void* enterBCO_primop2 ( int primop2code,
2858 int* /*StgThreadReturnCode* */ return2,
2861 HugsBlock *hugsBlock )
2864 /* A small concession: we need to allow ccalls,
2865 even in combined mode.
2867 if (primop2code != i_ccall_ccall_IO &&
2868 primop2code != i_ccall_stdcall_IO)
2869 barf("enterBCO_primop2 in combined mode");
2872 switch (primop2code) {
2873 case i_raise: /* raise#{err} */
2875 StgClosure* err = PopCPtr();
2876 return (raiseAnError(err));
2879 /*------------------------------------------------------------------------
2880 Insert and Remove primitives on Rows. This is important stuff for
2881 XMlambda, these prims are called *all* the time. That's the reason
2882 for all the specialized versions of the basic instructions.
2883 note: A Gc might move rows around => allocate first, than pop the arguments.
2884 ------------------------------------------------------------------------*/
2886 /*------------------------------------------------------------------------
2887 i_rowInsertAt: insert an element into a row
2888 ------------------------------------------------------------------------*/
2896 /* allocate a new row before popping arguments */
2897 StgMutArrPtrs* row = stgCast(StgMutArrPtrs*,stackPtr(0));
2898 StgMutArrPtrs* newRow
2899 = stgCast(StgMutArrPtrs*,allocate(sizeofW(StgMutArrPtrs) + row->ptrs + 1));
2900 SET_HDR(newRow,&MUT_ARR_PTRS_FROZEN_info,CCCS);
2902 /* pop row again and pop index and value */
2903 row = stgCast(StgMutArrPtrs*,PopPtr());
2907 i = PopTaggedWord();
2912 /* copy the fields, inserting the new value */
2913 for (j = 0; j < i; j++) {
2914 newRow->payload[j] = row->payload[j];
2916 newRow->payload[i] = x;
2917 for (j = i+1; j <= n; j++)
2919 newRow->payload[j] = row->payload[j-1];
2922 PushPtr(stgCast(StgPtr,newRow));
2926 /*------------------------------------------------------------------------
2927 i_rowChainInsert: behaves like a chain of [i_rowInsertAt] calls. This
2928 instruction is vital for XMLambda since we would otherwise allocate
2929 a lot of intermediate rows.
2930 It assumes that the RTS has no NULL pointers.
2931 It behaves 'optimal' if the witnesses are ordered, (lowest on the
2932 bottom of the stack).
2933 ------------------------------------------------------------------------*/
2935 case i_rowChainInsert:
2937 StgWord witness, topWitness;
2942 /* pop the number of arguments (=witness/value pairs) */
2943 StgWord n = PopTaggedWord();
2945 /* allocate a new row before popping boxed arguments */
2946 StgMutArrPtrs* row = stgCast(StgMutArrPtrs*,stackPtr(0));
2947 StgMutArrPtrs* newRow
2948 = stgCast(StgMutArrPtrs*,allocate(sizeofW(StgMutArrPtrs) + n + row->ptrs));
2949 SET_HDR(newRow,&MUT_ARR_PTRS_FROZEN_info,CCCS);
2951 /* pop the row and assign again (it may have moved during gc!) */
2952 row = stgCast(StgMutArrPtrs*,PopPtr());
2953 newRow->ptrs = n + row->ptrs;
2955 /* zero the fields */
2956 for (i = 0; i < newRow->ptrs; i++)
2958 newRow->payload[i] = ROW_HOLE;
2961 /* insert all values */
2962 topWitness = 0; /*invariant: 1 + maximal witness */
2963 for (i = 0; i < n; i++)
2965 witness = PopTaggedWord();
2967 if (witness < topWitness)
2969 /* shoot, unordered witnesses, we have to bump up everything */
2970 for (j = topWitness; j > witness; j--)
2972 newRow->payload[j] = newRow->payload[j-1];
2978 topWitness = witness+1;
2981 ASSERT(topWitness <= n);
2982 ASSERT(witness < n);
2983 newRow->payload[witness] = value;
2986 /* copy the values from the old row into the holes */
2987 for (j =0, i = 0; i < row->ptrs; j++,i++)
2989 while (newRow->payload[j] != ROW_HOLE) j++;
2991 newRow->payload[j] = row->payload[i];
2994 /* push the result */
2995 PushPtr(stgCast(StgPtr,newRow));
2999 /*------------------------------------------------------------------------
3000 i_rowChainBuild: exactly as [i_rowChainInsert] but builds a row from scratch.
3001 ------------------------------------------------------------------------*/
3002 case i_rowChainBuild:
3004 StgWord witness, topWitness;
3009 /* pop the number of arguments (=witness/value pairs) */
3010 StgWord n = PopTaggedWord();
3012 /* allocate a new row before popping boxed arguments */
3013 StgMutArrPtrs* newRow
3014 = stgCast(StgMutArrPtrs*,allocate(sizeofW(StgMutArrPtrs) + n));
3015 SET_HDR(newRow,&MUT_ARR_PTRS_FROZEN_info,CCCS);
3018 /* insert all values */
3019 topWitness = 0; /*invariant: 1 + maximal witness */
3020 for (i = 0; i < n; i++)
3022 witness = PopTaggedWord();
3024 if (witness < topWitness)
3026 /* shoot, unordered witnesses, we have to bump up everything */
3027 for (j = topWitness; j > witness; j--)
3029 newRow->payload[j] = newRow->payload[j-1];
3035 topWitness = witness+1;
3038 ASSERT(topWitness <= n);
3039 ASSERT(witness < n);
3040 newRow->payload[witness] = value;
3043 /* push the result */
3044 PushPtr(stgCast(StgPtr,newRow));
3048 /*------------------------------------------------------------------------
3049 i_rowRemoveAt: remove an element from a row
3050 ------------------------------------------------------------------------*/
3057 /* allocate new row before popping the arguments */
3058 StgMutArrPtrs* row = stgCast(StgMutArrPtrs*,stackPtr(0));
3059 StgMutArrPtrs* newRow
3060 = stgCast(StgMutArrPtrs*,allocate(sizeofW(StgMutArrPtrs) + row->ptrs - 1));
3061 SET_HDR(newRow,&MUT_ARR_PTRS_FROZEN_info,CCCS);
3063 /* pop row again and pop the index */
3064 row = stgCast(StgMutArrPtrs*,PopPtr());
3068 i = PopTaggedWord();
3072 /* copy the fields, except for the removed value. */
3073 for (j = 0; j < i; j++) {
3074 newRow->payload[j] = row->payload[j];
3076 for (j = i+1; j < n; j++)
3078 newRow->payload[j-1] = row->payload[j];
3081 PushCPtr(row->payload[i]);
3082 PushPtr(stgCast(StgPtr,newRow));
3086 /*------------------------------------------------------------------------
3087 i_rowChainRemove: behaves like a chain of [i_rowRemoveAt] calls. Again,
3088 this is a vital instruction to avoid lots of intermediate rows.
3089 It behaves 'optimal' if the witnessses are ordered, lowest on the
3090 bottom of the stack.
3091 The implementation is quite dirty, blame Daan for this :-)
3092 (It overwrites witnesses on the stack with results and marks pointers
3093 using their lowest bit.)
3094 ------------------------------------------------------------------------*/
3095 #define MARK(p) (stgCast(StgClosure*,(stgCast(StgWord,(p)) | 0x01)))
3096 #define UNMARK(p) (stgCast(StgClosure*,(stgCast(StgWord,(p)) & ~0x01)))
3097 #define ISMARKED(p) ((stgCast(StgWord,(p)) & 0x01) == 0x01)
3099 case i_rowChainRemove:
3101 const nat sizeofTaggedWord = sizeofW(StgWord) + sizeofW(StackTag);
3109 /* pop number of arguments (=witnesses) */
3110 StgWord n = PopTaggedWord();
3112 /* allocate new row before popping boxed arguments */
3113 StgMutArrPtrs* row = stgCast(StgMutArrPtrs*,stackPtr(0));
3114 StgMutArrPtrs* newRow
3115 = stgCast(StgMutArrPtrs*,allocate(sizeofW(StgMutArrPtrs) + row->ptrs - n));
3116 SET_HDR(newRow,&MUT_ARR_PTRS_FROZEN_info,CCCS);
3118 /* pop row and assign again (gc might have moved it) */
3119 row = stgCast(StgMutArrPtrs*,PopPtr());
3120 newRow->ptrs = row->ptrs - n;
3121 ASSERT( row->ptrs > n );
3123 /* 'push' all elements that are removed */
3124 base = n*sizeofTaggedWord;
3125 minWitness = row->ptrs;
3126 for (i = 1; i <= n; i++)
3130 witness = taggedStackWord( base - i*sizeofTaggedWord );
3131 if (witness >= minWitness)
3133 /* shoot, unordered witnesses, we have to search for the value */
3136 count = witness - minWitness;
3137 witness = minWitness;
3140 do{ witness++; } while (ISMARKED(row->payload[witness]));
3141 if (count == 0) break;
3147 minWitness = witness;
3149 ASSERT( witness < row->ptrs );
3150 ASSERT( !ISMARKED(row->payload[witness]) );
3152 /* mark the element */
3153 value = row->payload[witness];
3154 row->payload[witness] = MARK(value);
3156 /* set the value in the stack (overwriting old witnesses!) */
3157 setStackPtr( base - i*sizeofW(StgPtr), stgCast(StgPtr,value) );
3160 /* pop the garbage from the stack */
3161 gSp = gSp + base - n*sizeofW(StgPtr);
3163 /* copy all remaining elements and clear the marks */
3164 for (j = 0, i = 0; i < newRow->ptrs; j++,i++)
3166 while (ISMARKED(row->payload[j]))
3168 row->payload[j] = UNMARK(row->payload[j]);
3171 newRow->payload[i] = row->payload[j];
3175 while (j < row->ptrs)
3177 value = row->payload[j];
3178 if (ISMARKED(value)) row->payload[j] = UNMARK(value);
3183 for (i = 0; i < row->ptrs; i++)
3185 ASSERT(!ISMARKED(row->payload[i]));
3189 /* and push the result row */
3190 PushPtr(stgCast(StgPtr,newRow));
3194 /*------------------------------------------------------------------------
3195 i_rowChainSelect: behaves exactly like [i_rowChainRemove] but doesn't return
3196 the resulting row, only the removed elements.
3197 ------------------------------------------------------------------------*/
3198 case i_rowChainSelect:
3200 const nat sizeofTaggedWord = sizeofW(StgWord) + sizeofW(StackTag);
3206 /* pop number of arguments (=witnesses) and row*/
3207 StgWord n = PopTaggedWord();
3208 StgMutArrPtrs* row = stgCast(StgMutArrPtrs*,PopPtr());
3209 ASSERT( row->ptrs > n );
3211 /* 'push' all elements that are removed */
3212 base = n*sizeofTaggedWord;
3213 minWitness = row->ptrs;
3214 for (i = 1; i <= n; i++)
3218 witness = taggedStackWord( base - i*sizeofTaggedWord );
3219 if (witness >= minWitness)
3221 /* shoot, unordered witnesses, we have to search for the value */
3224 count = witness - minWitness;
3225 witness = minWitness;
3228 do{ witness++; } while (ISMARKED(row->payload[witness]));
3229 if (count == 0) break;
3235 minWitness = witness;
3237 ASSERT( witness < row->ptrs );
3238 ASSERT( !ISMARKED(row->payload[witness]) );
3240 /* mark the element */
3241 value = row->payload[witness];
3242 row->payload[witness] = MARK(value);
3244 /* set the value in the stack (overwriting old witnesses!) */
3245 setStackPtr( base - i*sizeofW(StgPtr), stgCast(StgPtr,value) );
3248 /* pop the garbage from the stack */
3249 gSp = gSp + base - n*sizeofW(StgPtr);
3251 /* unmark elements */
3252 for( i = 0; i < row->ptrs; i++)
3254 value = row->payload[i];
3255 if (ISMARKED(value)) row->payload[i] = UNMARK(value);
3259 for (i = 0; i < row->ptrs; i++)
3261 ASSERT(!ISMARKED(row->payload[i]));
3267 #endif /* XMLAMBDA */
3271 StgClosure* init = PopCPtr();
3273 = stgCast(StgMutVar*,allocate(sizeofW(StgMutVar)));
3274 SET_HDR(mv,&MUT_VAR_info,CCCS);
3276 PushPtr(stgCast(StgPtr,mv));
3281 StgMutVar* mv = stgCast(StgMutVar*,PopPtr());
3287 StgMutVar* mv = stgCast(StgMutVar*,PopPtr());
3288 StgClosure* value = PopCPtr();
3294 nat n = PopTaggedInt(); /* or Word?? */
3295 StgClosure* init = PopCPtr();
3296 StgWord size = sizeofW(StgMutArrPtrs) + n;
3299 = stgCast(StgMutArrPtrs*,allocate(size));
3300 SET_HDR(arr,&MUT_ARR_PTRS_info,CCCS);
3302 for (i = 0; i < n; ++i) {
3303 arr->payload[i] = init;
3305 PushPtr(stgCast(StgPtr,arr));
3311 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
3312 nat i = PopTaggedInt(); /* or Word?? */
3313 StgWord n = arr->ptrs;
3315 return (raiseIndex("{index,read}Array"));
3317 PushCPtr(arr->payload[i]);
3322 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
3323 nat i = PopTaggedInt(); /* or Word? */
3324 StgClosure* v = PopCPtr();
3325 StgWord n = arr->ptrs;
3327 return (raiseIndex("{index,read}Array"));
3329 arr->payload[i] = v;
3333 case i_sizeMutableArray:
3335 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
3336 PushTaggedInt(arr->ptrs);
3339 case i_unsafeFreezeArray:
3341 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
3342 SET_INFO(arr,&MUT_ARR_PTRS_FROZEN_info);
3343 PushPtr(stgCast(StgPtr,arr));
3346 case i_unsafeFreezeByteArray:
3348 /* Delightfully simple :-) */
3352 case i_sameMutableArray:
3353 case i_sameMutableByteArray:
3355 StgPtr x = PopPtr();
3356 StgPtr y = PopPtr();
3357 PushTaggedBool(x==y);
3361 case i_newByteArray:
3363 nat n = PopTaggedInt(); /* or Word?? */
3364 StgInt words = (n+sizeof(W_)-1)/sizeof(W_);
3365 StgWord size = sizeofW(StgArrWords) + words;
3366 StgArrWords* arr = stgCast(StgArrWords*,allocate(size));
3367 SET_HDR(arr,&ARR_WORDS_info,CCCS);
3371 for (i = 0; i < n; ++i) {
3372 arr->payload[i] = 0xdeadbeef;
3375 PushPtr(stgCast(StgPtr,arr));
3379 /* Most of these generate alignment warnings on Sparcs and similar architectures.
3380 * These are harmless and are caused by the cast to C* in BYTE_ARR_CTS.
3382 case i_indexCharArray:
3383 OP_mI_ty(Char,"indexCharArray", indexCharArrayzh(r,x,i)); break;
3384 case i_readCharArray:
3385 OP_mI_ty(Char,"readCharArray", readCharArrayzh(r,x,i)); break;
3386 case i_writeCharArray:
3387 OP_mIty_(Char,"writeCharArray", writeCharArrayzh(x,i,z)); break;
3389 case i_indexIntArray:
3390 OP_mI_ty(Int,"indexIntArray", indexIntArrayzh(r,x,i)); break;
3391 case i_readIntArray:
3392 OP_mI_ty(Int,"readIntArray", readIntArrayzh(r,x,i)); break;
3393 case i_writeIntArray:
3394 OP_mIty_(Int,"writeIntArray", writeIntArrayzh(x,i,z)); break;
3396 case i_indexAddrArray:
3397 OP_mI_ty(Addr,"indexAddrArray", indexAddrArrayzh(r,x,i)); break;
3398 case i_readAddrArray:
3399 OP_mI_ty(Addr,"readAddrArray", readAddrArrayzh(r,x,i)); break;
3400 case i_writeAddrArray:
3401 OP_mIty_(Addr,"writeAddrArray", writeAddrArrayzh(x,i,z)); break;
3403 case i_indexFloatArray:
3404 OP_mI_ty(Float,"indexFloatArray", indexFloatArrayzh(r,x,i)); break;
3405 case i_readFloatArray:
3406 OP_mI_ty(Float,"readFloatArray", readFloatArrayzh(r,x,i)); break;
3407 case i_writeFloatArray:
3408 OP_mIty_(Float,"writeFloatArray", writeFloatArrayzh(x,i,z)); break;
3410 case i_indexDoubleArray:
3411 OP_mI_ty(Double,"indexDoubleArray", indexDoubleArrayzh(r,x,i)); break;
3412 case i_readDoubleArray:
3413 OP_mI_ty(Double,"readDoubleArray", readDoubleArrayzh(r,x,i)); break;
3414 case i_writeDoubleArray:
3415 OP_mIty_(Double,"writeDoubleArray", writeDoubleArrayzh(x,i,z)); break;
3418 #ifdef PROVIDE_STABLE
3419 case i_indexStableArray:
3420 OP_mI_ty(StablePtr,"indexStableArray", indexStablePtrArrayzh(r,x,i)); break;
3421 case i_readStableArray:
3422 OP_mI_ty(StablePtr,"readStableArray", readStablePtrArrayzh(r,x,i)); break;
3423 case i_writeStableArray:
3424 OP_mIty_(StablePtr,"writeStableArray", writeStablePtrArrayzh(x,i,z)); break;
3430 #ifdef PROVIDE_COERCE
3431 case i_unsafeCoerce:
3433 /* Another nullop */
3437 #ifdef PROVIDE_PTREQUALITY
3438 case i_reallyUnsafePtrEquality:
3439 { /* identical to i_sameRef */
3440 StgPtr x = PopPtr();
3441 StgPtr y = PopPtr();
3442 PushTaggedBool(x==y);
3446 #ifdef PROVIDE_FOREIGN
3447 /* ForeignObj# operations */
3448 case i_mkForeignObj:
3450 StgForeignObj *result
3451 = stgCast(StgForeignObj*,allocate(sizeofW(StgForeignObj)));
3452 SET_HDR(result,&FOREIGN_info,CCCS);
3453 result -> data = PopTaggedAddr();
3454 PushPtr(stgCast(StgPtr,result));
3457 #endif /* PROVIDE_FOREIGN */
3462 = stgCast(StgWeak*,allocate(sizeofW(StgWeak)));
3463 SET_HDR(w, &WEAK_info, CCCS);
3465 w->value = PopCPtr();
3466 w->finaliser = PopCPtr();
3467 w->link = weak_ptr_list;
3469 IF_DEBUG(weak, fprintf(stderr,"New weak pointer at %p\n",w));
3470 PushPtr(stgCast(StgPtr,w));
3475 StgWeak *w = stgCast(StgWeak*,PopPtr());
3476 if (w->header.info == &WEAK_info) {
3477 PushCPtr(w->value); /* last result */
3478 PushTaggedInt(1); /* first result */
3480 PushPtr(stgCast(StgPtr,w));
3481 /* ToDo: error thunk would be better */
3486 #endif /* PROVIDE_WEAK */
3488 case i_makeStablePtr:
3490 StgPtr p = PopPtr();
3491 StgStablePtr sp = getStablePtr ( p );
3492 PushTaggedStablePtr(sp);
3495 case i_deRefStablePtr:
3498 StgStablePtr sp = PopTaggedStablePtr();
3499 p = deRefStablePtr(sp);
3503 case i_freeStablePtr:
3505 StgStablePtr sp = PopTaggedStablePtr();
3510 case i_createAdjThunkARCH:
3512 StgStablePtr stableptr = PopTaggedStablePtr();
3513 StgAddr typestr = PopTaggedAddr();
3514 StgChar callconv = PopTaggedChar();
3515 StgAddr adj_thunk = createAdjThunk(stableptr,typestr,callconv);
3516 PushTaggedAddr(adj_thunk);
3522 StgInt n = prog_argc;
3528 StgInt n = PopTaggedInt();
3529 StgAddr a = (StgAddr)prog_argv[n];
3536 StgMVar *mvar = stgCast(StgMVar*,allocate(sizeofW(StgMVar)));
3537 SET_INFO(mvar,&EMPTY_MVAR_info);
3538 mvar->head = mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
3539 mvar->value = stgCast(StgClosure*,&END_TSO_QUEUE_closure);
3540 PushPtr(stgCast(StgPtr,mvar));
3545 StgMVar *mvar = (StgMVar*)PopCPtr();
3546 if (GET_INFO(mvar) == &EMPTY_MVAR_info) {
3548 /* The MVar is empty. Attach ourselves to the TSO's
3551 if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
3552 mvar->head = cap->rCurrentTSO;
3554 mvar->tail->link = cap->rCurrentTSO;
3556 cap->rCurrentTSO->link = (StgTSO *)&END_TSO_QUEUE_closure;
3557 cap->rCurrentTSO->why_blocked = BlockedOnMVar;
3558 cap->rCurrentTSO->block_info.closure = (StgClosure *)mvar;
3559 mvar->tail = cap->rCurrentTSO;
3561 /* At this point, the top-of-stack holds the MVar,
3562 and underneath is the world token (). So the
3563 stack is in the same state as when primTakeMVar
3564 was entered (primTakeMVar is handwritten bytecode).
3565 Push obj, which is this BCO, and return to the
3566 scheduler. When the MVar is filled, the scheduler
3567 will re-enter primTakeMVar, with the args still on
3568 the top of the stack.
3570 PushCPtr((StgClosure*)(*bco));
3571 *return2 = ThreadBlocked;
3572 return (void*)(1+(char*)(NULL));
3575 PushCPtr(mvar->value);
3576 mvar->value = (StgClosure *)&END_TSO_QUEUE_closure;
3577 SET_INFO(mvar,&EMPTY_MVAR_info);
3583 StgMVar* mvar = stgCast(StgMVar*,PopPtr());
3584 StgClosure* value = PopCPtr();
3585 if (GET_INFO(mvar) == &FULL_MVAR_info) {
3586 return (makeErrorCall("putMVar {full MVar}"));
3588 /* wake up the first thread on the
3589 * queue, it will continue with the
3590 * takeMVar operation and mark the
3593 mvar->value = value;
3595 if (mvar->head != (StgTSO *)&END_TSO_QUEUE_closure) {
3596 ASSERT(mvar->head->why_blocked == BlockedOnMVar);
3597 mvar->head = unblockOne(mvar->head);
3598 if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
3599 mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
3603 /* unlocks the MVar in the SMP case */
3604 SET_INFO(mvar,&FULL_MVAR_info);
3606 /* yield for better communication performance */
3612 { /* identical to i_sameRef */
3613 StgMVar* x = (StgMVar*)PopPtr();
3614 StgMVar* y = (StgMVar*)PopPtr();
3615 PushTaggedBool(x==y);
3618 #ifdef PROVIDE_CONCURRENT
3621 StgClosure* closure;
3624 closure = PopCPtr();
3625 tso = createGenThread (RtsFlags.GcFlags.initialStkSize,closure);
3627 scheduleThread(tso);
3629 /* Later: Change to use tso as the ThreadId */
3630 PushTaggedWord(tid);
3636 StgWord n = PopTaggedWord();
3640 // Map from ThreadId to Thread Structure */
3641 for (t = all_threads; t != END_TSO_QUEUE; t = t->global_link) {
3650 while (tso->what_next == ThreadRelocated) {
3655 if (tso == cap->rCurrentTSO) { /* suicide */
3656 *return2 = ThreadFinished;
3657 return (void*)(1+(char*)(NULL));
3661 case i_raiseInThread:
3662 barf("raiseInThread");
3663 ASSERT(0); /* not (yet) supported */
3666 StgInt n = PopTaggedInt();
3668 hugsBlock->reason = BlockedOnDelay;
3669 hugsBlock->delay = n;
3674 StgInt n = PopTaggedInt();
3676 hugsBlock->reason = BlockedOnRead;
3677 hugsBlock->delay = n;
3682 StgInt n = PopTaggedInt();
3684 hugsBlock->reason = BlockedOnWrite;
3685 hugsBlock->delay = n;
3690 /* The definition of yield include an enter right after
3691 * the primYield, at which time context_switch is tested.
3698 StgWord tid = cap->rCurrentTSO->id;
3699 PushTaggedWord(tid);
3702 case i_cmpThreadIds:
3704 StgWord tid1 = PopTaggedWord();
3705 StgWord tid2 = PopTaggedWord();
3706 if (tid1 < tid2) PushTaggedInt(-1);
3707 else if (tid1 > tid2) PushTaggedInt(1);
3708 else PushTaggedInt(0);
3711 #endif /* PROVIDE_CONCURRENT */
3716 CFunDescriptor descriptor;
3717 void (*funPtr)(void);
3719 StgWord offset = PopTaggedWord(); /* offset into bco nonptr section */
3720 funPtr = PopTaggedAddr();
3722 ASSERT(funPtr != NULL);
3724 /* copy the complete callinfo, the bco might move during GC! */
3725 callInfo = *stgCast(CallInfo*, (*bco)->payload + (*bco)->n_ptrs + offset);
3727 /* copy info to a CFunDescriptor. just for compatibility. */
3728 descriptor.num_args = callInfo.argCount;
3729 descriptor.arg_tys = callInfo.data;
3730 descriptor.num_results = callInfo.resultCount;
3731 descriptor.result_tys = callInfo.data + callInfo.argCount + 1;
3734 switch (ccall( &descriptor, funPtr, bco, callInfo.callConv, cap ))
3737 case 1: barf( "unhandled type or too many args/results in ccall"); break;
3738 case 2: barf("ccall not configured correctly for this platform"); break;
3739 default: barf("unknown return code from ccall"); break;
3746 case i_ccall_ccall_Id:
3747 case i_ccall_ccall_IO:
3748 case i_ccall_stdcall_Id:
3749 case i_ccall_stdcall_IO:
3752 CFunDescriptor* descriptor;
3753 void (*funPtr)(void);
3755 descriptor = PopTaggedAddr();
3756 funPtr = PopTaggedAddr();
3757 cc = (primop2code == i_ccall_stdcall_Id ||
3758 primop2code == i_ccall_stdcall_IO)
3760 r = ccall(descriptor,funPtr,bco,cc,cap);
3763 return makeErrorCall(
3764 "unhandled type or too many args/results in ccall");
3766 barf("ccall not configured correctly for this platform");
3767 barf("unknown return code from ccall");
3770 barf("Unrecognised primop2");
3776 /* -----------------------------------------------------------------------------
3777 * ccall support code:
3778 * marshall moves args from C stack to Haskell stack
3779 * unmarshall moves args from Haskell stack to C stack
3780 * argSize calculates how much gSpace you need on the C stack
3781 * ---------------------------------------------------------------------------*/
3783 /* Pop arguments off the C stack and Push them onto the Hugs stack.
3784 * Used when preparing for C calling Haskell or in regSponse to
3785 * Haskell calling C.
3787 nat marshall(char arg_ty, void* arg)
3791 PushTaggedInt(*((int*)arg));
3792 return ARG_SIZE(INT_TAG);
3795 PushTaggedInteger(*((mpz_ptr*)arg));
3796 return ARG_SIZE(INTEGER_TAG);
3799 PushTaggedWord(*((unsigned int*)arg));
3800 return ARG_SIZE(WORD_TAG);
3802 PushTaggedChar(*((char*)arg));
3803 return ARG_SIZE(CHAR_TAG);
3805 PushTaggedFloat(*((float*)arg));
3806 return ARG_SIZE(FLOAT_TAG);
3808 PushTaggedDouble(*((double*)arg));
3809 return ARG_SIZE(DOUBLE_TAG);
3811 PushTaggedAddr(*((void**)arg));
3812 return ARG_SIZE(ADDR_TAG);
3814 PushTaggedStablePtr(*((StgStablePtr*)arg));
3815 return ARG_SIZE(STABLE_TAG);
3816 #ifdef PROVIDE_FOREIGN
3818 /* Not allowed in this direction - you have to
3819 * call makeForeignPtr explicitly
3821 barf("marshall: ForeignPtr#\n");
3826 /* Not allowed in this direction */
3827 barf("marshall: [Mutable]ByteArray#\n");
3830 barf("marshall: unrecognised arg type %d\n",arg_ty);
3835 /* Pop arguments off the Hugs stack and Push them onto the C stack.
3836 * Used when preparing for Haskell calling C or in regSponse to
3837 * C calling Haskell.
3839 nat unmarshall(char res_ty, void* res)
3843 *((int*)res) = PopTaggedInt();
3844 return ARG_SIZE(INT_TAG);
3847 *((mpz_ptr*)res) = PopTaggedInteger();
3848 return ARG_SIZE(INTEGER_TAG);
3851 *((unsigned int*)res) = PopTaggedWord();
3852 return ARG_SIZE(WORD_TAG);
3854 *((int*)res) = PopTaggedChar();
3855 return ARG_SIZE(CHAR_TAG);
3857 *((float*)res) = PopTaggedFloat();
3858 return ARG_SIZE(FLOAT_TAG);
3860 *((double*)res) = PopTaggedDouble();
3861 return ARG_SIZE(DOUBLE_TAG);
3863 *((void**)res) = PopTaggedAddr();
3864 return ARG_SIZE(ADDR_TAG);
3866 *((StgStablePtr*)res) = PopTaggedStablePtr();
3867 return ARG_SIZE(STABLE_TAG);
3868 #ifdef PROVIDE_FOREIGN
3871 StgForeignObj *result = stgCast(StgForeignObj*,PopPtr());
3872 *((void**)res) = result->data;
3873 return sizeofW(StgPtr);
3879 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
3880 *((void**)res) = stgCast(void*,&(arr->payload));
3881 return sizeofW(StgPtr);
3884 barf("unmarshall: unrecognised result type %d\n",res_ty);
3888 nat argSize( const char* ks )
3891 for( ; *ks != '\0'; ++ks) {
3894 sz += sizeof(StgWord) * ARG_SIZE(INT_TAG);
3898 sz += sizeof(StgWord) * ARG_SIZE(INTEGER_TAG);
3902 sz += sizeof(StgWord) * ARG_SIZE(WORD_TAG);
3905 sz += sizeof(StgWord) * ARG_SIZE(CHAR_TAG);
3908 sz += sizeof(StgWord) * ARG_SIZE(FLOAT_TAG);
3911 sz += sizeof(StgWord) * ARG_SIZE(DOUBLE_TAG);
3914 sz += sizeof(StgWord) * ARG_SIZE(ADDR_TAG);
3917 sz += sizeof(StgWord) * ARG_SIZE(STABLE_TAG);
3919 #ifdef PROVIDE_FOREIGN
3924 sz += sizeof(StgPtr);
3927 barf("argSize: unrecognised result type %d\n",*ks);
3935 /* -----------------------------------------------------------------------------
3936 * encode/decode Float/Double code for standalone Hugs
3937 * Code based on the HBC code (lib/fltcode.c) and more recently GHC
3938 * (ghc/rts/StgPrimFloat.c)
3939 * ---------------------------------------------------------------------------*/
3941 #if IEEE_FLOATING_POINT
3942 #define MY_DMINEXP ((DBL_MIN_EXP) - (DBL_MANT_DIG) - 1)
3943 /* DMINEXP is defined in values.h on Linux (for example) */
3944 #define DHIGHBIT 0x00100000
3945 #define DMSBIT 0x80000000
3947 #define MY_FMINEXP ((FLT_MIN_EXP) - (FLT_MANT_DIG) - 1)
3948 #define FHIGHBIT 0x00800000
3949 #define FMSBIT 0x80000000
3951 #error The following code doesnt work in a non-IEEE FP environment
3954 #ifdef WORDS_BIGENDIAN
3963 StgDouble B__encodeDouble (B* s, I_ e) /* result = s * 2^e */
3968 /* Convert a B to a double; knows a lot about internal rep! */
3969 for(r = 0.0, i = s->used-1; i >= 0; i--)
3970 r = (r * B_BASE_FLT) + s->stuff[i];
3972 /* Now raise to the exponent */
3973 if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
3976 /* handle the sign */
3977 if (s->sign < 0) r = -r;
3984 StgFloat B__encodeFloat (B* s, I_ e) /* result = s * 2^e */
3989 /* Convert a B to a float; knows a lot about internal rep! */
3990 for(r = 0.0, i = s->used-1; i >= 0; i--)
3991 r = (r * B_BASE_FLT) + s->stuff[i];
3993 /* Now raise to the exponent */
3994 if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
3997 /* handle the sign */
3998 if (s->sign < 0) r = -r;
4005 /* This only supports IEEE floating point */
4006 void B__decodeDouble (B* man, I_* exp, StgDouble dbl)
4008 /* Do some bit fiddling on IEEE */
4009 nat low, high; /* assuming 32 bit ints */
4011 union { double d; int i[2]; } u; /* assuming 32 bit ints, 64 bit double */
4013 u.d = dbl; /* grab chunks of the double */
4017 ASSERT(B_BASE == 256);
4019 /* Assume that the supplied B is the right size */
4022 if (low == 0 && (high & ~DMSBIT) == 0) {
4023 man->sign = man->used = 0;
4028 iexp = ((high >> 20) & 0x7ff) + MY_DMINEXP;
4032 if (iexp != MY_DMINEXP) /* don't add hidden bit to denorms */
4036 /* A denorm, normalize the mantissa */
4037 while (! (high & DHIGHBIT)) {
4047 man->stuff[7] = (((W_)high) >> 24) & 0xff;
4048 man->stuff[6] = (((W_)high) >> 16) & 0xff;
4049 man->stuff[5] = (((W_)high) >> 8) & 0xff;
4050 man->stuff[4] = (((W_)high) ) & 0xff;
4052 man->stuff[3] = (((W_)low) >> 24) & 0xff;
4053 man->stuff[2] = (((W_)low) >> 16) & 0xff;
4054 man->stuff[1] = (((W_)low) >> 8) & 0xff;
4055 man->stuff[0] = (((W_)low) ) & 0xff;
4057 if (sign < 0) man->sign = -1;
4059 do_renormalise(man);
4063 void B__decodeFloat (B* man, I_* exp, StgFloat flt)
4065 /* Do some bit fiddling on IEEE */
4066 int high, sign; /* assuming 32 bit ints */
4067 union { float f; int i; } u; /* assuming 32 bit float and int */
4069 u.f = flt; /* grab the float */
4072 ASSERT(B_BASE == 256);
4074 /* Assume that the supplied B is the right size */
4077 if ((high & ~FMSBIT) == 0) {
4078 man->sign = man->used = 0;
4083 *exp = ((high >> 23) & 0xff) + MY_FMINEXP;
4087 if (*exp != MY_FMINEXP) /* don't add hidden bit to denorms */
4091 /* A denorm, normalize the mantissa */
4092 while (! (high & FHIGHBIT)) {
4097 man->stuff[3] = (((W_)high) >> 24) & 0xff;
4098 man->stuff[2] = (((W_)high) >> 16) & 0xff;
4099 man->stuff[1] = (((W_)high) >> 8) & 0xff;
4100 man->stuff[0] = (((W_)high) ) & 0xff;
4102 if (sign < 0) man->sign = -1;
4104 do_renormalise(man);
4107 #endif /* INTERPRETER */