2 /* -----------------------------------------------------------------------------
5 * Copyright (c) 1994-2000.
7 * $RCSfile: Evaluator.c,v $
9 * $Date: 2000/11/20 11:15: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 #error Dont know if EAGER_BLACKHOLING works in StgHugs
1566 /* superfluous - but makes debugging easier */
1567 StgBlackHole* bh = stgCast(StgBlackHole*,ap);
1568 SET_INFO(bh,&BLACKHOLE_info);
1569 bh->blocking_queue = EndTSOQueue;
1571 fprintf(stderr,"Eagerly blackholed AP_UPD %p in evaluator\n",bh));
1574 #endif /* EAGER_BLACKHOLING */
1579 StgPAP* pap = stgCast(StgPAP*,obj);
1580 int i = pap->n_args; /* ToDo: stack check */
1581 /* ToDo: if PAP is in whnf, we can update any update frames
1585 xPushWord(payloadWord(pap,i));
1592 obj = stgCast(StgInd*,obj)->indirectee;
1597 obj = stgCast(StgIndOldGen*,obj)->indirectee;
1606 case CONSTR_INTLIKE:
1607 case CONSTR_CHARLIKE:
1609 case CONSTR_NOCAF_STATIC:
1611 /* rows are mutarrays and should be treated as constructors. */
1612 case MUT_ARR_PTRS_FROZEN:
1616 switch (get_itbl(stgCast(StgClosure*,xSp))->type) {
1618 SSS; PopCatchFrame(); LLL;
1621 xPopUpdateFrame(obj);
1624 SSS; PopSeqFrame(); LLL;
1628 ASSERT(xSp==(P_)xSu);
1631 fprintf(stderr, "hit a STOP_FRAME\n");
1633 fprintf(stderr,"xSp = %p\txSu = %p\n", xSp, xSu);
1634 printStack(xSp,cap->rCurrentTSO->stack
1635 + cap->rCurrentTSO->stack_size,xSu);
1638 cap->rCurrentTSO->what_next = ThreadComplete;
1639 SSS; PopStopFrame(obj); LLL;
1641 RETURN(ThreadFinished);
1651 /* was: goto enterLoop;
1652 But we know that obj must be a bco now, so jump directly.
1655 case RET_SMALL: /* return to GHC */
1659 cap->rCurrentTSO->what_next = ThreadEnterGHC;
1661 RETURN(ThreadYielding);
1663 belch("entered CONSTR with invalid continuation on stack");
1666 printObj(stgCast(StgClosure*,xSp));
1669 barf("bailing out");
1676 //fprintf(stderr, "enterCountI = %d\n", enterCountI);
1677 //fprintf(stderr, "entering unknown closure -- yielding to sched\n");
1680 cap->rCurrentTSO->what_next = ThreadEnterGHC;
1681 xPushCPtr(obj); /* code to restart with */
1682 RETURN(ThreadYielding);
1685 barf("Ran off the end of enter - yoiks");
1702 #undef xSetStackWord
1705 #undef xPushTaggedInt
1706 #undef xPopTaggedInt
1707 #undef xTaggedStackInt
1708 #undef xPushTaggedWord
1709 #undef xPopTaggedWord
1710 #undef xTaggedStackWord
1711 #undef xPushTaggedAddr
1712 #undef xTaggedStackAddr
1713 #undef xPopTaggedAddr
1714 #undef xPushTaggedStable
1715 #undef xTaggedStackStable
1716 #undef xPopTaggedStable
1717 #undef xPushTaggedChar
1718 #undef xTaggedStackChar
1719 #undef xPopTaggedChar
1720 #undef xPushTaggedFloat
1721 #undef xTaggedStackFloat
1722 #undef xPopTaggedFloat
1723 #undef xPushTaggedDouble
1724 #undef xTaggedStackDouble
1725 #undef xPopTaggedDouble
1726 #undef xPopUpdateFrame
1727 #undef xPushUpdateFrame
1730 /* --------------------------------------------------------------------------
1731 * Supporting routines for primops
1732 * ------------------------------------------------------------------------*/
1734 static inline void PushTag ( StackTag t )
1736 inline void PushPtr ( StgPtr x )
1737 { *(--stgCast(StgPtr*,gSp)) = x; }
1738 static inline void PushCPtr ( StgClosure* x )
1739 { *(--stgCast(StgClosure**,gSp)) = x; }
1740 static inline void PushInt ( StgInt x )
1741 { *(--stgCast(StgInt*,gSp)) = x; }
1742 static inline void PushWord ( StgWord x )
1743 { *(--stgCast(StgWord*,gSp)) = x; }
1746 static inline void checkTag ( StackTag t1, StackTag t2 )
1747 { ASSERT(t1 == t2);}
1748 static inline void PopTag ( StackTag t )
1749 { checkTag(t,*(gSp++)); }
1750 inline StgPtr PopPtr ( void )
1751 { return *stgCast(StgPtr*,gSp)++; }
1752 static inline StgClosure* PopCPtr ( void )
1753 { return *stgCast(StgClosure**,gSp)++; }
1754 static inline StgInt PopInt ( void )
1755 { return *stgCast(StgInt*,gSp)++; }
1756 static inline StgWord PopWord ( void )
1757 { return *stgCast(StgWord*,gSp)++; }
1759 static inline StgPtr stackPtr ( StgStackOffset i )
1760 { return *stgCast(StgPtr*, gSp+i); }
1761 static inline StgInt stackInt ( StgStackOffset i )
1762 { return *stgCast(StgInt*, gSp+i); }
1763 static inline StgWord stackWord ( StgStackOffset i )
1764 { return *stgCast(StgWord*,gSp+i); }
1766 static inline void setStackWord ( StgStackOffset i, StgWord w )
1770 static inline void setStackPtr ( StgStackOffset i, StgPtr p )
1771 { *(stgCast(StgPtr*, gSp+i)) = p; }
1774 static inline void PushTaggedRealWorld( void )
1775 { PushTag(REALWORLD_TAG); }
1776 inline void PushTaggedInt ( StgInt x )
1777 { gSp -= sizeofW(StgInt); *gSp = x; PushTag(INT_TAG); }
1778 inline void PushTaggedWord ( StgWord x )
1779 { gSp -= sizeofW(StgWord); *gSp = x; PushTag(WORD_TAG); }
1780 inline void PushTaggedAddr ( StgAddr x )
1781 { gSp -= sizeofW(StgAddr); *gSp = (W_)x; PushTag(ADDR_TAG); }
1782 inline void PushTaggedChar ( StgChar x )
1783 { gSp -= sizeofW(StgChar); *gSp = stgCast(StgWord,x); PushTag(CHAR_TAG); }
1784 inline void PushTaggedFloat ( StgFloat x )
1785 { gSp -= sizeofW(StgFloat); ASSIGN_FLT(gSp,x); PushTag(FLOAT_TAG); }
1786 inline void PushTaggedDouble ( StgDouble x )
1787 { gSp -= sizeofW(StgDouble); ASSIGN_DBL(gSp,x); PushTag(DOUBLE_TAG); }
1788 inline void PushTaggedStablePtr ( StgStablePtr x )
1789 { gSp -= sizeofW(StgStablePtr); *gSp = (W_)x; PushTag(STABLE_TAG); }
1790 static inline void PushTaggedBool ( int x )
1791 { PushTaggedInt(x); }
1795 static inline void PopTaggedRealWorld ( void )
1796 { PopTag(REALWORLD_TAG); }
1797 inline StgInt PopTaggedInt ( void )
1798 { StgInt r; PopTag(INT_TAG); r = *stgCast(StgInt*, gSp);
1799 gSp += sizeofW(StgInt); return r;}
1800 inline StgWord PopTaggedWord ( void )
1801 { StgWord r; PopTag(WORD_TAG); r = *stgCast(StgWord*, gSp);
1802 gSp += sizeofW(StgWord); return r;}
1803 inline StgAddr PopTaggedAddr ( void )
1804 { StgAddr r; PopTag(ADDR_TAG); r = *stgCast(StgAddr*, gSp);
1805 gSp += sizeofW(StgAddr); return r;}
1806 inline StgChar PopTaggedChar ( void )
1807 { StgChar r; PopTag(CHAR_TAG); r = stgCast(StgChar, *gSp);
1808 gSp += sizeofW(StgChar); return r;}
1809 inline StgFloat PopTaggedFloat ( void )
1810 { StgFloat r; PopTag(FLOAT_TAG); r = PK_FLT(gSp);
1811 gSp += sizeofW(StgFloat); return r;}
1812 inline StgDouble PopTaggedDouble ( void )
1813 { StgDouble r; PopTag(DOUBLE_TAG); r = PK_DBL(gSp);
1814 gSp += sizeofW(StgDouble); return r;}
1815 inline StgStablePtr PopTaggedStablePtr ( void )
1816 { StgStablePtr r; PopTag(STABLE_TAG); r = *stgCast(StgStablePtr*, gSp);
1817 gSp += sizeofW(StgStablePtr); return r;}
1821 static inline StgInt taggedStackInt ( StgStackOffset i )
1822 { checkTag(INT_TAG,gSp[i]); return *stgCast(StgInt*, gSp+1+i); }
1823 static inline StgWord taggedStackWord ( StgStackOffset i )
1824 { checkTag(WORD_TAG,gSp[i]); return *stgCast(StgWord*, gSp+1+i); }
1825 static inline StgAddr taggedStackAddr ( StgStackOffset i )
1826 { checkTag(ADDR_TAG,gSp[i]); return *stgCast(StgAddr*, gSp+1+i); }
1827 static inline StgChar taggedStackChar ( StgStackOffset i )
1828 { checkTag(CHAR_TAG,gSp[i]); return stgCast(StgChar, *(gSp+1+i)) ; }
1829 static inline StgFloat taggedStackFloat ( StgStackOffset i )
1830 { checkTag(FLOAT_TAG,gSp[i]); return PK_FLT(gSp+1+i); }
1831 static inline StgDouble taggedStackDouble ( StgStackOffset i )
1832 { checkTag(DOUBLE_TAG,gSp[i]); return PK_DBL(gSp+1+i); }
1833 static inline StgStablePtr taggedStackStable ( StgStackOffset i )
1834 { checkTag(STABLE_TAG,gSp[i]); return *stgCast(StgStablePtr*, gSp+1+i); }
1837 /* --------------------------------------------------------------------------
1840 * Should we allocate from a nursery or use the
1841 * doYouWantToGC/allocate interface? We'd already implemented a
1842 * nursery-style scheme when the doYouWantToGC/allocate interface
1844 * One reason to prefer the doYouWantToGC/allocate interface is to
1845 * support operations which allocate an unknown amount in the heap
1846 * (array ops, gmp ops, etc)
1847 * ------------------------------------------------------------------------*/
1849 static inline StgPtr grabHpUpd( nat size )
1851 ASSERT( size >= MIN_UPD_SIZE + sizeofW(StgHeader) );
1852 return allocate(size);
1855 static inline StgPtr grabHpNonUpd( nat size )
1857 ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
1858 return allocate(size);
1861 /* --------------------------------------------------------------------------
1862 * Manipulate "update frame" list:
1863 * o Update frames (based on stg_do_update and friends in Updates.hc)
1864 * o Error handling/catching (based on catchzh_fast and friends in Prims.hc)
1865 * o Seq frames (based on seq_frame_entry in Prims.hc)
1867 * ------------------------------------------------------------------------*/
1869 static inline void PopUpdateFrame ( StgClosure* obj )
1871 /* NB: doesn't assume that gSp == gSu */
1873 fprintf(stderr, "Updating ");
1874 printPtr(stgCast(StgPtr,gSu->updatee));
1875 fprintf(stderr, " with ");
1877 fprintf(stderr,"gSp = %p\tgSu = %p\n\n", gSp, gSu);
1879 #ifdef EAGER_BLACKHOLING
1880 #error Dont know if EAGER_BLACKHOLING works in StgHugs
1881 ASSERT(get_itbl(gSu->updatee)->type == BLACKHOLE
1882 || get_itbl(gSu->updatee)->type == SE_BLACKHOLE
1883 || get_itbl(gSu->updatee)->type == CAF_BLACKHOLE
1884 || get_itbl(gSu->updatee)->type == SE_CAF_BLACKHOLE
1886 #endif /* EAGER_BLACKHOLING */
1887 UPD_IND(gSu->updatee,obj);
1888 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgUpdateFrame);
1892 static inline void PopStopFrame ( StgClosure* obj )
1894 /* Move gSu just off the end of the stack, we're about to gSpam the
1895 * STOP_FRAME with the return value.
1897 gSu = stgCast(StgUpdateFrame*,gSp+1);
1898 *stgCast(StgClosure**,gSp) = obj;
1901 static inline void PushCatchFrame ( StgClosure* handler )
1904 /* ToDo: stack check! */
1905 gSp -= sizeofW(StgCatchFrame);
1906 fp = stgCast(StgCatchFrame*,gSp);
1907 SET_HDR(fp,(StgInfoTable*)&catch_frame_info,CCCS);
1908 fp->handler = handler;
1910 gSu = stgCast(StgUpdateFrame*,fp);
1913 static inline void PopCatchFrame ( void )
1915 /* NB: doesn't assume that gSp == gSu */
1916 /* fprintf(stderr,"Popping catch frame\n"); */
1917 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgCatchFrame);
1918 gSu = stgCast(StgCatchFrame*,gSu)->link;
1921 static inline void PushSeqFrame ( void )
1924 /* ToDo: stack check! */
1925 gSp -= sizeofW(StgSeqFrame);
1926 fp = stgCast(StgSeqFrame*,gSp);
1927 SET_HDR(fp,(StgInfoTable*)&seq_frame_info,CCCS);
1929 gSu = stgCast(StgUpdateFrame*,fp);
1932 static inline void PopSeqFrame ( void )
1934 /* NB: doesn't assume that gSp == gSu */
1935 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgSeqFrame);
1936 gSu = stgCast(StgSeqFrame*,gSu)->link;
1939 static inline StgClosure* raiseAnError ( StgClosure* exception )
1941 /* This closure represents the expression 'primRaise E' where E
1942 * is the exception raised (:: Exception).
1943 * It is used to overwrite all the
1944 * thunks which are currently under evaluation.
1946 HaskellObj primRaiseClosure
1947 = getHugs_BCO_cptr_for("primRaise");
1948 HaskellObj reraiseClosure
1949 = rts_apply ( primRaiseClosure, exception );
1952 switch (get_itbl(gSu)->type) {
1954 UPD_IND(gSu->updatee,reraiseClosure);
1955 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgUpdateFrame);
1961 case CATCH_FRAME: /* found it! */
1963 StgCatchFrame* fp = stgCast(StgCatchFrame*,gSu);
1964 StgClosure *handler = fp->handler;
1966 gSp += sizeofW(StgCatchFrame); /* Pop */
1967 PushCPtr(exception);
1971 barf("raiseError: uncaught exception: STOP_FRAME");
1973 barf("raiseError: weird activation record");
1979 static StgClosure* makeErrorCall ( const char* msg )
1981 /* Note! the msg string should be allocated in a
1982 place which will not get freed -- preferably
1983 read-only data of the program. That's because
1984 the thunk we build here may linger indefinitely.
1985 (thinks: probably not so, but anyway ...)
1988 = getHugs_BCO_cptr_for("error");
1990 = getHugs_BCO_cptr_for("hugsprimUnpackString");
1992 = rts_apply ( unpack, rts_mkAddr ( (void*)msg ) );
1994 = rts_apply ( error, thunk );
1996 (StgClosure*) thunk;
1999 #define raiseIndex(where) makeErrorCall("Array index out of range in " where)
2000 #define raiseDiv0(where) makeErrorCall("Division by zero in " where)
2002 /* --------------------------------------------------------------------------
2004 * ------------------------------------------------------------------------*/
2006 #define OP_CC_B(e) \
2008 unsigned char x = PopTaggedChar(); \
2009 unsigned char y = PopTaggedChar(); \
2010 PushTaggedBool(e); \
2015 unsigned char x = PopTaggedChar(); \
2024 #define OP_IW_I(e) \
2026 StgInt x = PopTaggedInt(); \
2027 StgWord y = PopTaggedWord(); \
2031 #define OP_II_I(e) \
2033 StgInt x = PopTaggedInt(); \
2034 StgInt y = PopTaggedInt(); \
2038 #define OP_II_B(e) \
2040 StgInt x = PopTaggedInt(); \
2041 StgInt y = PopTaggedInt(); \
2042 PushTaggedBool(e); \
2047 PushTaggedAddr(e); \
2052 StgInt x = PopTaggedInt(); \
2053 PushTaggedAddr(e); \
2058 StgInt x = PopTaggedInt(); \
2064 PushTaggedChar(e); \
2069 StgInt x = PopTaggedInt(); \
2070 PushTaggedChar(e); \
2075 PushTaggedWord(e); \
2080 StgInt x = PopTaggedInt(); \
2081 PushTaggedWord(e); \
2086 StgInt x = PopTaggedInt(); \
2087 PushTaggedStablePtr(e); \
2092 PushTaggedFloat(e); \
2097 StgInt x = PopTaggedInt(); \
2098 PushTaggedFloat(e); \
2103 PushTaggedDouble(e); \
2108 StgInt x = PopTaggedInt(); \
2109 PushTaggedDouble(e); \
2112 #define OP_WW_B(e) \
2114 StgWord x = PopTaggedWord(); \
2115 StgWord y = PopTaggedWord(); \
2116 PushTaggedBool(e); \
2119 #define OP_WW_W(e) \
2121 StgWord x = PopTaggedWord(); \
2122 StgWord y = PopTaggedWord(); \
2123 PushTaggedWord(e); \
2128 StgWord x = PopTaggedWord(); \
2134 StgStablePtr x = PopTaggedStablePtr(); \
2140 StgWord x = PopTaggedWord(); \
2141 PushTaggedWord(e); \
2144 #define OP_AA_B(e) \
2146 StgAddr x = PopTaggedAddr(); \
2147 StgAddr y = PopTaggedAddr(); \
2148 PushTaggedBool(e); \
2152 StgAddr x = PopTaggedAddr(); \
2155 #define OP_AI_C(s) \
2157 StgAddr x = PopTaggedAddr(); \
2158 int y = PopTaggedInt(); \
2161 PushTaggedChar(r); \
2163 #define OP_AI_I(s) \
2165 StgAddr x = PopTaggedAddr(); \
2166 int y = PopTaggedInt(); \
2171 #define OP_AI_A(s) \
2173 StgAddr x = PopTaggedAddr(); \
2174 int y = PopTaggedInt(); \
2177 PushTaggedAddr(s); \
2179 #define OP_AI_F(s) \
2181 StgAddr x = PopTaggedAddr(); \
2182 int y = PopTaggedInt(); \
2185 PushTaggedFloat(r); \
2187 #define OP_AI_D(s) \
2189 StgAddr x = PopTaggedAddr(); \
2190 int y = PopTaggedInt(); \
2193 PushTaggedDouble(r); \
2195 #define OP_AI_s(s) \
2197 StgAddr x = PopTaggedAddr(); \
2198 int y = PopTaggedInt(); \
2201 PushTaggedStablePtr(r); \
2203 #define OP_AIC_(s) \
2205 StgAddr x = PopTaggedAddr(); \
2206 int y = PopTaggedInt(); \
2207 StgChar z = PopTaggedChar(); \
2210 #define OP_AII_(s) \
2212 StgAddr x = PopTaggedAddr(); \
2213 int y = PopTaggedInt(); \
2214 StgInt z = PopTaggedInt(); \
2217 #define OP_AIA_(s) \
2219 StgAddr x = PopTaggedAddr(); \
2220 int y = PopTaggedInt(); \
2221 StgAddr z = PopTaggedAddr(); \
2224 #define OP_AIF_(s) \
2226 StgAddr x = PopTaggedAddr(); \
2227 int y = PopTaggedInt(); \
2228 StgFloat z = PopTaggedFloat(); \
2231 #define OP_AID_(s) \
2233 StgAddr x = PopTaggedAddr(); \
2234 int y = PopTaggedInt(); \
2235 StgDouble z = PopTaggedDouble(); \
2238 #define OP_AIs_(s) \
2240 StgAddr x = PopTaggedAddr(); \
2241 int y = PopTaggedInt(); \
2242 StgStablePtr z = PopTaggedStablePtr(); \
2247 #define OP_FF_B(e) \
2249 StgFloat x = PopTaggedFloat(); \
2250 StgFloat y = PopTaggedFloat(); \
2251 PushTaggedBool(e); \
2254 #define OP_FF_F(e) \
2256 StgFloat x = PopTaggedFloat(); \
2257 StgFloat y = PopTaggedFloat(); \
2258 PushTaggedFloat(e); \
2263 StgFloat x = PopTaggedFloat(); \
2264 PushTaggedFloat(e); \
2269 StgFloat x = PopTaggedFloat(); \
2270 PushTaggedBool(e); \
2275 StgFloat x = PopTaggedFloat(); \
2281 StgFloat x = PopTaggedFloat(); \
2282 PushTaggedDouble(e); \
2285 #define OP_DD_B(e) \
2287 StgDouble x = PopTaggedDouble(); \
2288 StgDouble y = PopTaggedDouble(); \
2289 PushTaggedBool(e); \
2292 #define OP_DD_D(e) \
2294 StgDouble x = PopTaggedDouble(); \
2295 StgDouble y = PopTaggedDouble(); \
2296 PushTaggedDouble(e); \
2301 StgDouble x = PopTaggedDouble(); \
2302 PushTaggedBool(e); \
2307 StgDouble x = PopTaggedDouble(); \
2308 PushTaggedDouble(e); \
2313 StgDouble x = PopTaggedDouble(); \
2319 StgDouble x = PopTaggedDouble(); \
2320 PushTaggedFloat(e); \
2324 StgPtr CreateByteArrayToHoldInteger ( int nbytes )
2326 StgWord words = (nbytes+sizeof(W_)-1)/sizeof(W_);
2327 StgWord size = sizeofW(StgArrWords) + words;
2328 StgArrWords* arr = (StgArrWords*)allocate(size);
2329 SET_HDR(arr,&ARR_WORDS_info,CCCS);
2331 ASSERT((W_)nbytes <= arr->words * sizeof(W_));
2334 for (i = 0; i < words; ++i) {
2335 arr->payload[i] = 0xdeadbeef;
2337 { B* b = (B*) &(arr->payload[0]);
2338 b->used = b->sign = 0;
2344 B* IntegerInsideByteArray ( StgPtr arr0 )
2347 StgArrWords* arr = (StgArrWords*)arr0;
2348 ASSERT(GET_INFO(arr) == &ARR_WORDS_info);
2349 b = (B*) &(arr->payload[0]);
2353 void SloppifyIntegerEnd ( StgPtr arr0 )
2355 StgArrWords* arr = (StgArrWords*)arr0;
2356 B* b = (B*) & (arr->payload[0]);
2357 I_ nwunused = arr->words - sizeofW(B) - (b->used+sizeof(W_)-1)/sizeof(W_);
2358 if (nwunused >= ((I_)sizeofW(StgArrWords))) {
2360 b->size -= nwunused * sizeof(W_);
2361 if (b->size < b->used) b->size = b->used;
2364 arr->words -= nwunused;
2365 slop = (StgArrWords*)&(arr->payload[arr->words]);
2366 SET_HDR(slop,&ARR_WORDS_info,CCCS);
2367 slop->words = nwunused - sizeofW(StgArrWords);
2368 ASSERT( &(slop->payload[slop->words]) ==
2369 &(arr->payload[arr->words + nwunused]) );
2373 #define OP_Z_Z(op) \
2375 B* x = IntegerInsideByteArray(PopPtr()); \
2376 int n = mycat2(size_,op)(x); \
2377 StgPtr p = CreateByteArrayToHoldInteger(n); \
2378 mycat2(do_,op)(x,n,IntegerInsideByteArray(p)); \
2379 SloppifyIntegerEnd(p); \
2382 #define OP_ZZ_Z(op) \
2384 B* x = IntegerInsideByteArray(PopPtr()); \
2385 B* y = IntegerInsideByteArray(PopPtr()); \
2386 int n = mycat2(size_,op)(x,y); \
2387 StgPtr p = CreateByteArrayToHoldInteger(n); \
2388 mycat2(do_,op)(x,y,n,IntegerInsideByteArray(p)); \
2389 SloppifyIntegerEnd(p); \
2396 #define HEADER_mI(ty,where) \
2397 StgArrWords* x = stgCast(StgArrWords*,PopPtr()); \
2398 nat i = PopTaggedInt(); \
2399 if (i * sizeof(ty) + (sizeof(ty)) > sizeof(StgWord) * x->words) { \
2400 return (raiseIndex(where)); \
2402 #define OP_mI_ty(ty,where,s) \
2404 HEADER_mI(mycat2(Stg,ty),where) \
2405 { mycat2(Stg,ty) r; \
2407 mycat2(PushTagged,ty)(r); \
2410 #define OP_mIty_(ty,where,s) \
2412 HEADER_mI(mycat2(Stg,ty),where) \
2414 mycat2(Stg,ty) z = mycat2(PopTagged,ty)(); \
2420 __attribute__ ((unused))
2421 static void myStackCheck ( Capability* cap )
2423 /* fprintf(stderr, "myStackCheck\n"); */
2424 if (!(gSpLim <= gSp && gSp <= stgCast(StgPtr,gSu))) {
2425 fprintf(stderr, "myStackCheck: invalid initial gSp/gSu \n" );
2430 if (!( (P_)gSu >= (P_)cap->rCurrentTSO->stack
2432 (P_)gSu <= (P_)(cap->rCurrentTSO->stack
2433 + cap->rCurrentTSO->stack_size))) {
2434 fprintf ( stderr, "myStackCheck: gSu out of stack\n" );
2438 switch (get_itbl(stgCast(StgClosure*,gSu))->type) {
2440 gSu = (StgUpdateFrame*) ((StgCatchFrame*)(gSu))->link;
2443 gSu = (StgUpdateFrame*) ((StgUpdateFrame*)(gSu))->link;
2446 gSu = (StgUpdateFrame*) ((StgSeqFrame*)(gSu))->link;
2451 fprintf(stderr, "myStackCheck: invalid activation record\n");
2460 /* --------------------------------------------------------------------------
2461 * Primop stuff for bytecode interpreter
2462 * ------------------------------------------------------------------------*/
2464 /* Returns & of the next thing to enter (if throwing an exception),
2465 or NULL in the normal case.
2467 static void* enterBCO_primop1 ( int primop1code )
2470 barf("enterBCO_primop1 in combined mode");
2472 switch (primop1code) {
2473 case i_pushseqframe:
2475 StgClosure* c = PopCPtr();
2480 case i_pushcatchframe:
2482 StgClosure* e = PopCPtr();
2483 StgClosure* h = PopCPtr();
2489 case i_gtChar: OP_CC_B(x>y); break;
2490 case i_geChar: OP_CC_B(x>=y); break;
2491 case i_eqChar: OP_CC_B(x==y); break;
2492 case i_neChar: OP_CC_B(x!=y); break;
2493 case i_ltChar: OP_CC_B(x<y); break;
2494 case i_leChar: OP_CC_B(x<=y); break;
2495 case i_charToInt: OP_C_I(x); break;
2496 case i_intToChar: OP_I_C(x); break;
2498 case i_gtInt: OP_II_B(x>y); break;
2499 case i_geInt: OP_II_B(x>=y); break;
2500 case i_eqInt: OP_II_B(x==y); break;
2501 case i_neInt: OP_II_B(x!=y); break;
2502 case i_ltInt: OP_II_B(x<y); break;
2503 case i_leInt: OP_II_B(x<=y); break;
2504 case i_minInt: OP__I(INT_MIN); break;
2505 case i_maxInt: OP__I(INT_MAX); break;
2506 case i_plusInt: OP_II_I(x+y); break;
2507 case i_minusInt: OP_II_I(x-y); break;
2508 case i_timesInt: OP_II_I(x*y); break;
2511 int x = PopTaggedInt();
2512 int y = PopTaggedInt();
2514 return (raiseDiv0("quotInt"));
2516 /* ToDo: protect against minInt / -1 errors
2517 * (repeat for all other division primops) */
2523 int x = PopTaggedInt();
2524 int y = PopTaggedInt();
2526 return (raiseDiv0("remInt"));
2533 StgInt x = PopTaggedInt();
2534 StgInt y = PopTaggedInt();
2536 return (raiseDiv0("quotRemInt"));
2538 PushTaggedInt(x%y); /* last result */
2539 PushTaggedInt(x/y); /* first result */
2542 case i_negateInt: OP_I_I(-x); break;
2544 case i_andInt: OP_II_I(x&y); break;
2545 case i_orInt: OP_II_I(x|y); break;
2546 case i_xorInt: OP_II_I(x^y); break;
2547 case i_notInt: OP_I_I(~x); break;
2548 case i_shiftLInt: OP_II_I(x<<y); break;
2549 case i_shiftRAInt: OP_II_I(x>>y); break; /* ToDo */
2550 case i_shiftRLInt: OP_II_I(x>>y); break; /* ToDo */
2552 case i_gtWord: OP_WW_B(x>y); break;
2553 case i_geWord: OP_WW_B(x>=y); break;
2554 case i_eqWord: OP_WW_B(x==y); break;
2555 case i_neWord: OP_WW_B(x!=y); break;
2556 case i_ltWord: OP_WW_B(x<y); break;
2557 case i_leWord: OP_WW_B(x<=y); break;
2558 case i_minWord: OP__W(0); break;
2559 case i_maxWord: OP__W(UINT_MAX); break;
2560 case i_plusWord: OP_WW_W(x+y); break;
2561 case i_minusWord: OP_WW_W(x-y); break;
2562 case i_timesWord: OP_WW_W(x*y); break;
2565 StgWord x = PopTaggedWord();
2566 StgWord y = PopTaggedWord();
2568 return (raiseDiv0("quotWord"));
2570 PushTaggedWord(x/y);
2575 StgWord x = PopTaggedWord();
2576 StgWord y = PopTaggedWord();
2578 return (raiseDiv0("remWord"));
2580 PushTaggedWord(x%y);
2585 StgWord x = PopTaggedWord();
2586 StgWord y = PopTaggedWord();
2588 return (raiseDiv0("quotRemWord"));
2590 PushTaggedWord(x%y); /* last result */
2591 PushTaggedWord(x/y); /* first result */
2594 case i_negateWord: OP_W_W(-x); break;
2595 case i_andWord: OP_WW_W(x&y); break;
2596 case i_orWord: OP_WW_W(x|y); break;
2597 case i_xorWord: OP_WW_W(x^y); break;
2598 case i_notWord: OP_W_W(~x); break;
2599 case i_shiftLWord: OP_WW_W(x<<y); break;
2600 case i_shiftRAWord: OP_WW_W(x>>y); break; /* ToDo */
2601 case i_shiftRLWord: OP_WW_W(x>>y); break; /* ToDo */
2602 case i_intToWord: OP_I_W(x); break;
2603 case i_wordToInt: OP_W_I(x); break;
2605 case i_gtAddr: OP_AA_B(x>y); break;
2606 case i_geAddr: OP_AA_B(x>=y); break;
2607 case i_eqAddr: OP_AA_B(x==y); break;
2608 case i_neAddr: OP_AA_B(x!=y); break;
2609 case i_ltAddr: OP_AA_B(x<y); break;
2610 case i_leAddr: OP_AA_B(x<=y); break;
2611 case i_intToAddr: OP_I_A((StgAddr)x); break; /* ToDo */
2612 case i_addrToInt: OP_A_I((StgInt)x); break; /* ToDo */
2614 case i_intToStable: OP_I_s((StgStablePtr)x); break;
2615 case i_stableToInt: OP_s_I((W_)x); break;
2617 case i_indexCharOffAddr: OP_AI_C(indexCharOffAddrzh(r,x,y)); break;
2618 case i_readCharOffAddr: OP_AI_C(indexCharOffAddrzh(r,x,y)); break;
2619 case i_writeCharOffAddr: OP_AIC_(writeCharOffAddrzh(x,y,z)); break;
2621 case i_indexIntOffAddr: OP_AI_I(indexIntOffAddrzh(r,x,y)); break;
2622 case i_readIntOffAddr: OP_AI_I(indexIntOffAddrzh(r,x,y)); break;
2623 case i_writeIntOffAddr: OP_AII_(writeIntOffAddrzh(x,y,z)); break;
2625 case i_indexAddrOffAddr: OP_AI_A(indexAddrOffAddrzh(r,x,y)); break;
2626 case i_readAddrOffAddr: OP_AI_A(indexAddrOffAddrzh(r,x,y)); break;
2627 case i_writeAddrOffAddr: OP_AIA_(writeAddrOffAddrzh(x,y,z)); break;
2629 case i_indexFloatOffAddr: OP_AI_F(indexFloatOffAddrzh(r,x,y)); break;
2630 case i_readFloatOffAddr: OP_AI_F(indexFloatOffAddrzh(r,x,y)); break;
2631 case i_writeFloatOffAddr: OP_AIF_(writeFloatOffAddrzh(x,y,z)); break;
2633 case i_indexDoubleOffAddr: OP_AI_D(indexDoubleOffAddrzh(r,x,y)); break;
2634 case i_readDoubleOffAddr: OP_AI_D(indexDoubleOffAddrzh(r,x,y)); break;
2635 case i_writeDoubleOffAddr: OP_AID_(writeDoubleOffAddrzh(x,y,z)); break;
2637 case i_indexStableOffAddr: OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break;
2638 case i_readStableOffAddr: OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break;
2639 case i_writeStableOffAddr: OP_AIs_(writeStablePtrOffAddrzh(x,y,z)); break;
2641 case i_compareInteger:
2643 B* x = IntegerInsideByteArray(PopPtr());
2644 B* y = IntegerInsideByteArray(PopPtr());
2645 StgInt r = do_cmp(x,y);
2646 PushTaggedInt(r<0 ? -1 : (r>0 ? 1 : 0));
2649 case i_negateInteger: OP_Z_Z(neg); break;
2650 case i_plusInteger: OP_ZZ_Z(add); break;
2651 case i_minusInteger: OP_ZZ_Z(sub); break;
2652 case i_timesInteger: OP_ZZ_Z(mul); break;
2653 case i_quotRemInteger:
2655 B* x = IntegerInsideByteArray(PopPtr());
2656 B* y = IntegerInsideByteArray(PopPtr());
2657 int n = size_qrm(x,y);
2658 StgPtr q = CreateByteArrayToHoldInteger(n);
2659 StgPtr r = CreateByteArrayToHoldInteger(n);
2660 if (do_getsign(y)==0)
2661 return (raiseDiv0("quotRemInteger"));
2662 do_qrm(x,y,n,IntegerInsideByteArray(q),
2663 IntegerInsideByteArray(r));
2664 SloppifyIntegerEnd(q);
2665 SloppifyIntegerEnd(r);
2670 case i_intToInteger:
2672 int n = size_fromInt();
2673 StgPtr p = CreateByteArrayToHoldInteger(n);
2674 do_fromInt( PopTaggedInt(), n, IntegerInsideByteArray(p));
2678 case i_wordToInteger:
2680 int n = size_fromWord();
2681 StgPtr p = CreateByteArrayToHoldInteger(n);
2682 do_fromWord( PopTaggedWord(), n, IntegerInsideByteArray(p));
2686 case i_integerToInt: PushTaggedInt(do_toInt(
2687 IntegerInsideByteArray(PopPtr())
2691 case i_integerToWord: PushTaggedWord(do_toWord(
2692 IntegerInsideByteArray(PopPtr())
2696 case i_integerToFloat: PushTaggedFloat(do_toFloat(
2697 IntegerInsideByteArray(PopPtr())
2701 case i_integerToDouble: PushTaggedDouble(do_toDouble(
2702 IntegerInsideByteArray(PopPtr())
2706 case i_gtFloat: OP_FF_B(x>y); break;
2707 case i_geFloat: OP_FF_B(x>=y); break;
2708 case i_eqFloat: OP_FF_B(x==y); break;
2709 case i_neFloat: OP_FF_B(x!=y); break;
2710 case i_ltFloat: OP_FF_B(x<y); break;
2711 case i_leFloat: OP_FF_B(x<=y); break;
2712 case i_minFloat: OP__F(FLT_MIN); break;
2713 case i_maxFloat: OP__F(FLT_MAX); break;
2714 case i_radixFloat: OP__I(FLT_RADIX); break;
2715 case i_digitsFloat: OP__I(FLT_MANT_DIG); break;
2716 case i_minExpFloat: OP__I(FLT_MIN_EXP); break;
2717 case i_maxExpFloat: OP__I(FLT_MAX_EXP); break;
2718 case i_plusFloat: OP_FF_F(x+y); break;
2719 case i_minusFloat: OP_FF_F(x-y); break;
2720 case i_timesFloat: OP_FF_F(x*y); break;
2723 StgFloat x = PopTaggedFloat();
2724 StgFloat y = PopTaggedFloat();
2725 PushTaggedFloat(x/y);
2728 case i_negateFloat: OP_F_F(-x); break;
2729 case i_floatToInt: OP_F_I(x); break;
2730 case i_intToFloat: OP_I_F(x); break;
2731 case i_expFloat: OP_F_F(exp(x)); break;
2732 case i_logFloat: OP_F_F(log(x)); break;
2733 case i_sqrtFloat: OP_F_F(sqrt(x)); break;
2734 case i_sinFloat: OP_F_F(sin(x)); break;
2735 case i_cosFloat: OP_F_F(cos(x)); break;
2736 case i_tanFloat: OP_F_F(tan(x)); break;
2737 case i_asinFloat: OP_F_F(asin(x)); break;
2738 case i_acosFloat: OP_F_F(acos(x)); break;
2739 case i_atanFloat: OP_F_F(atan(x)); break;
2740 case i_sinhFloat: OP_F_F(sinh(x)); break;
2741 case i_coshFloat: OP_F_F(cosh(x)); break;
2742 case i_tanhFloat: OP_F_F(tanh(x)); break;
2743 case i_powerFloat: OP_FF_F(pow(x,y)); break;
2745 case i_encodeFloatZ:
2747 StgPtr sig = PopPtr();
2748 StgInt exp = PopTaggedInt();
2750 B__encodeFloat(IntegerInsideByteArray(sig), exp)
2754 case i_decodeFloatZ:
2756 StgFloat f = PopTaggedFloat();
2757 StgPtr sig = CreateByteArrayToHoldInteger(size_fltmantissa());
2759 B__decodeFloat(IntegerInsideByteArray(sig), &exp, f);
2765 case i_isNaNFloat: OP_F_B(isFloatNaN(x)); break;
2766 case i_isInfiniteFloat: OP_F_B(isFloatInfinite(x)); break;
2767 case i_isNegativeZeroFloat: OP_F_B(isFloatNegativeZero(x)); break;
2768 case i_isDenormalizedFloat: OP_F_B(isFloatDenormalized(x)); break;
2769 case i_gtDouble: OP_DD_B(x>y); break;
2770 case i_geDouble: OP_DD_B(x>=y); break;
2771 case i_eqDouble: OP_DD_B(x==y); break;
2772 case i_neDouble: OP_DD_B(x!=y); break;
2773 case i_ltDouble: OP_DD_B(x<y); break;
2774 case i_leDouble: OP_DD_B(x<=y) break;
2775 case i_minDouble: OP__D(DBL_MIN); break;
2776 case i_maxDouble: OP__D(DBL_MAX); break;
2777 case i_radixDouble: OP__I(FLT_RADIX); break;
2778 case i_digitsDouble: OP__I(DBL_MANT_DIG); break;
2779 case i_minExpDouble: OP__I(DBL_MIN_EXP); break;
2780 case i_maxExpDouble: OP__I(DBL_MAX_EXP); break;
2781 case i_plusDouble: OP_DD_D(x+y); break;
2782 case i_minusDouble: OP_DD_D(x-y); break;
2783 case i_timesDouble: OP_DD_D(x*y); break;
2784 case i_divideDouble:
2786 StgDouble x = PopTaggedDouble();
2787 StgDouble y = PopTaggedDouble();
2788 PushTaggedDouble(x/y);
2791 case i_negateDouble: OP_D_D(-x); break;
2792 case i_doubleToInt: OP_D_I(x); break;
2793 case i_intToDouble: OP_I_D(x); break;
2794 case i_doubleToFloat: OP_D_F(x); break;
2795 case i_floatToDouble: OP_F_F(x); break;
2796 case i_expDouble: OP_D_D(exp(x)); break;
2797 case i_logDouble: OP_D_D(log(x)); break;
2798 case i_sqrtDouble: OP_D_D(sqrt(x)); break;
2799 case i_sinDouble: OP_D_D(sin(x)); break;
2800 case i_cosDouble: OP_D_D(cos(x)); break;
2801 case i_tanDouble: OP_D_D(tan(x)); break;
2802 case i_asinDouble: OP_D_D(asin(x)); break;
2803 case i_acosDouble: OP_D_D(acos(x)); break;
2804 case i_atanDouble: OP_D_D(atan(x)); break;
2805 case i_sinhDouble: OP_D_D(sinh(x)); break;
2806 case i_coshDouble: OP_D_D(cosh(x)); break;
2807 case i_tanhDouble: OP_D_D(tanh(x)); break;
2808 case i_powerDouble: OP_DD_D(pow(x,y)); break;
2810 case i_encodeDoubleZ:
2812 StgPtr sig = PopPtr();
2813 StgInt exp = PopTaggedInt();
2815 B__encodeDouble(IntegerInsideByteArray(sig), exp)
2819 case i_decodeDoubleZ:
2821 StgDouble d = PopTaggedDouble();
2822 StgPtr sig = CreateByteArrayToHoldInteger(size_dblmantissa());
2824 B__decodeDouble(IntegerInsideByteArray(sig), &exp, d);
2830 case i_isNaNDouble: OP_D_B(isDoubleNaN(x)); break;
2831 case i_isInfiniteDouble: OP_D_B(isDoubleInfinite(x)); break;
2832 case i_isNegativeZeroDouble: OP_D_B(isDoubleNegativeZero(x)); break;
2833 case i_isDenormalizedDouble: OP_D_B(isDoubleDenormalized(x)); break;
2834 case i_isIEEEDouble:
2836 PushTaggedBool(rtsTrue);
2840 barf("Unrecognised primop1");
2847 /* For normal cases, return NULL and leave *return2 unchanged.
2848 To return the address of the next thing to enter,
2849 return the address of it and leave *return2 unchanged.
2850 To return a StgThreadReturnCode to the scheduler,
2851 set *return2 to it and return a non-NULL value.
2852 To cause a context switch, set context_switch (its a global),
2853 and optionally set hugsBlock to your rational.
2855 static void* enterBCO_primop2 ( int primop2code,
2856 int* /*StgThreadReturnCode* */ return2,
2859 HugsBlock *hugsBlock )
2862 /* A small concession: we need to allow ccalls,
2863 even in combined mode.
2865 if (primop2code != i_ccall_ccall_IO &&
2866 primop2code != i_ccall_stdcall_IO)
2867 barf("enterBCO_primop2 in combined mode");
2870 switch (primop2code) {
2871 case i_raise: /* raise#{err} */
2873 StgClosure* err = PopCPtr();
2874 return (raiseAnError(err));
2877 /*------------------------------------------------------------------------
2878 Insert and Remove primitives on Rows. This is important stuff for
2879 XMlambda, these prims are called *all* the time. That's the reason
2880 for all the specialized versions of the basic instructions.
2881 note: A Gc might move rows around => allocate first, than pop the arguments.
2882 ------------------------------------------------------------------------*/
2884 /*------------------------------------------------------------------------
2885 i_rowInsertAt: insert an element into a row
2886 ------------------------------------------------------------------------*/
2894 /* allocate a new row before popping arguments */
2895 StgMutArrPtrs* row = stgCast(StgMutArrPtrs*,stackPtr(0));
2896 StgMutArrPtrs* newRow
2897 = stgCast(StgMutArrPtrs*,allocate(sizeofW(StgMutArrPtrs) + row->ptrs + 1));
2898 SET_HDR(newRow,&MUT_ARR_PTRS_FROZEN_info,CCCS);
2900 /* pop row again and pop index and value */
2901 row = stgCast(StgMutArrPtrs*,PopPtr());
2905 i = PopTaggedWord();
2910 /* copy the fields, inserting the new value */
2911 for (j = 0; j < i; j++) {
2912 newRow->payload[j] = row->payload[j];
2914 newRow->payload[i] = x;
2915 for (j = i+1; j <= n; j++)
2917 newRow->payload[j] = row->payload[j-1];
2920 PushPtr(stgCast(StgPtr,newRow));
2924 /*------------------------------------------------------------------------
2925 i_rowChainInsert: behaves like a chain of [i_rowInsertAt] calls. This
2926 instruction is vital for XMLambda since we would otherwise allocate
2927 a lot of intermediate rows.
2928 It assumes that the RTS has no NULL pointers.
2929 It behaves 'optimal' if the witnesses are ordered, (lowest on the
2930 bottom of the stack).
2931 ------------------------------------------------------------------------*/
2933 case i_rowChainInsert:
2935 StgWord witness, topWitness;
2940 /* pop the number of arguments (=witness/value pairs) */
2941 StgWord n = PopTaggedWord();
2943 /* allocate a new row before popping boxed arguments */
2944 StgMutArrPtrs* row = stgCast(StgMutArrPtrs*,stackPtr(0));
2945 StgMutArrPtrs* newRow
2946 = stgCast(StgMutArrPtrs*,allocate(sizeofW(StgMutArrPtrs) + n + row->ptrs));
2947 SET_HDR(newRow,&MUT_ARR_PTRS_FROZEN_info,CCCS);
2949 /* pop the row and assign again (it may have moved during gc!) */
2950 row = stgCast(StgMutArrPtrs*,PopPtr());
2951 newRow->ptrs = n + row->ptrs;
2953 /* zero the fields */
2954 for (i = 0; i < newRow->ptrs; i++)
2956 newRow->payload[i] = ROW_HOLE;
2959 /* insert all values */
2960 topWitness = 0; /*invariant: 1 + maximal witness */
2961 for (i = 0; i < n; i++)
2963 witness = PopTaggedWord();
2965 if (witness < topWitness)
2967 /* shoot, unordered witnesses, we have to bump up everything */
2968 for (j = topWitness; j > witness; j--)
2970 newRow->payload[j] = newRow->payload[j-1];
2976 topWitness = witness+1;
2979 ASSERT(topWitness <= n);
2980 ASSERT(witness < n);
2981 newRow->payload[witness] = value;
2984 /* copy the values from the old row into the holes */
2985 for (j =0, i = 0; i < row->ptrs; j++,i++)
2987 while (newRow->payload[j] != ROW_HOLE) j++;
2989 newRow->payload[j] = row->payload[i];
2992 /* push the result */
2993 PushPtr(stgCast(StgPtr,newRow));
2997 /*------------------------------------------------------------------------
2998 i_rowChainBuild: exactly as [i_rowChainInsert] but builds a row from scratch.
2999 ------------------------------------------------------------------------*/
3000 case i_rowChainBuild:
3002 StgWord witness, topWitness;
3007 /* pop the number of arguments (=witness/value pairs) */
3008 StgWord n = PopTaggedWord();
3010 /* allocate a new row before popping boxed arguments */
3011 StgMutArrPtrs* newRow
3012 = stgCast(StgMutArrPtrs*,allocate(sizeofW(StgMutArrPtrs) + n));
3013 SET_HDR(newRow,&MUT_ARR_PTRS_FROZEN_info,CCCS);
3016 /* insert all values */
3017 topWitness = 0; /*invariant: 1 + maximal witness */
3018 for (i = 0; i < n; i++)
3020 witness = PopTaggedWord();
3022 if (witness < topWitness)
3024 /* shoot, unordered witnesses, we have to bump up everything */
3025 for (j = topWitness; j > witness; j--)
3027 newRow->payload[j] = newRow->payload[j-1];
3033 topWitness = witness+1;
3036 ASSERT(topWitness <= n);
3037 ASSERT(witness < n);
3038 newRow->payload[witness] = value;
3041 /* push the result */
3042 PushPtr(stgCast(StgPtr,newRow));
3046 /*------------------------------------------------------------------------
3047 i_rowRemoveAt: remove an element from a row
3048 ------------------------------------------------------------------------*/
3055 /* allocate new row before popping the arguments */
3056 StgMutArrPtrs* row = stgCast(StgMutArrPtrs*,stackPtr(0));
3057 StgMutArrPtrs* newRow
3058 = stgCast(StgMutArrPtrs*,allocate(sizeofW(StgMutArrPtrs) + row->ptrs - 1));
3059 SET_HDR(newRow,&MUT_ARR_PTRS_FROZEN_info,CCCS);
3061 /* pop row again and pop the index */
3062 row = stgCast(StgMutArrPtrs*,PopPtr());
3066 i = PopTaggedWord();
3070 /* copy the fields, except for the removed value. */
3071 for (j = 0; j < i; j++) {
3072 newRow->payload[j] = row->payload[j];
3074 for (j = i+1; j < n; j++)
3076 newRow->payload[j-1] = row->payload[j];
3079 PushCPtr(row->payload[i]);
3080 PushPtr(stgCast(StgPtr,newRow));
3084 /*------------------------------------------------------------------------
3085 i_rowChainRemove: behaves like a chain of [i_rowRemoveAt] calls. Again,
3086 this is a vital instruction to avoid lots of intermediate rows.
3087 It behaves 'optimal' if the witnessses are ordered, lowest on the
3088 bottom of the stack.
3089 The implementation is quite dirty, blame Daan for this :-)
3090 (It overwrites witnesses on the stack with results and marks pointers
3091 using their lowest bit.)
3092 ------------------------------------------------------------------------*/
3093 #define MARK(p) (stgCast(StgClosure*,(stgCast(StgWord,(p)) | 0x01)))
3094 #define UNMARK(p) (stgCast(StgClosure*,(stgCast(StgWord,(p)) & ~0x01)))
3095 #define ISMARKED(p) ((stgCast(StgWord,(p)) & 0x01) == 0x01)
3097 case i_rowChainRemove:
3099 const nat sizeofTaggedWord = sizeofW(StgWord) + sizeofW(StackTag);
3107 /* pop number of arguments (=witnesses) */
3108 StgWord n = PopTaggedWord();
3110 /* allocate new row before popping boxed arguments */
3111 StgMutArrPtrs* row = stgCast(StgMutArrPtrs*,stackPtr(0));
3112 StgMutArrPtrs* newRow
3113 = stgCast(StgMutArrPtrs*,allocate(sizeofW(StgMutArrPtrs) + row->ptrs - n));
3114 SET_HDR(newRow,&MUT_ARR_PTRS_FROZEN_info,CCCS);
3116 /* pop row and assign again (gc might have moved it) */
3117 row = stgCast(StgMutArrPtrs*,PopPtr());
3118 newRow->ptrs = row->ptrs - n;
3119 ASSERT( row->ptrs > n );
3121 /* 'push' all elements that are removed */
3122 base = n*sizeofTaggedWord;
3123 minWitness = row->ptrs;
3124 for (i = 1; i <= n; i++)
3128 witness = taggedStackWord( base - i*sizeofTaggedWord );
3129 if (witness >= minWitness)
3131 /* shoot, unordered witnesses, we have to search for the value */
3134 count = witness - minWitness;
3135 witness = minWitness;
3138 do{ witness++; } while (ISMARKED(row->payload[witness]));
3139 if (count == 0) break;
3145 minWitness = witness;
3147 ASSERT( witness < row->ptrs );
3148 ASSERT( !ISMARKED(row->payload[witness]) );
3150 /* mark the element */
3151 value = row->payload[witness];
3152 row->payload[witness] = MARK(value);
3154 /* set the value in the stack (overwriting old witnesses!) */
3155 setStackPtr( base - i*sizeofW(StgPtr), stgCast(StgPtr,value) );
3158 /* pop the garbage from the stack */
3159 gSp = gSp + base - n*sizeofW(StgPtr);
3161 /* copy all remaining elements and clear the marks */
3162 for (j = 0, i = 0; i < newRow->ptrs; j++,i++)
3164 while (ISMARKED(row->payload[j]))
3166 row->payload[j] = UNMARK(row->payload[j]);
3169 newRow->payload[i] = row->payload[j];
3173 while (j < row->ptrs)
3175 value = row->payload[j];
3176 if (ISMARKED(value)) row->payload[j] = UNMARK(value);
3181 for (i = 0; i < row->ptrs; i++)
3183 ASSERT(!ISMARKED(row->payload[i]));
3187 /* and push the result row */
3188 PushPtr(stgCast(StgPtr,newRow));
3192 /*------------------------------------------------------------------------
3193 i_rowChainSelect: behaves exactly like [i_rowChainRemove] but doesn't return
3194 the resulting row, only the removed elements.
3195 ------------------------------------------------------------------------*/
3196 case i_rowChainSelect:
3198 const nat sizeofTaggedWord = sizeofW(StgWord) + sizeofW(StackTag);
3204 /* pop number of arguments (=witnesses) and row*/
3205 StgWord n = PopTaggedWord();
3206 StgMutArrPtrs* row = stgCast(StgMutArrPtrs*,PopPtr());
3207 ASSERT( row->ptrs > n );
3209 /* 'push' all elements that are removed */
3210 base = n*sizeofTaggedWord;
3211 minWitness = row->ptrs;
3212 for (i = 1; i <= n; i++)
3216 witness = taggedStackWord( base - i*sizeofTaggedWord );
3217 if (witness >= minWitness)
3219 /* shoot, unordered witnesses, we have to search for the value */
3222 count = witness - minWitness;
3223 witness = minWitness;
3226 do{ witness++; } while (ISMARKED(row->payload[witness]));
3227 if (count == 0) break;
3233 minWitness = witness;
3235 ASSERT( witness < row->ptrs );
3236 ASSERT( !ISMARKED(row->payload[witness]) );
3238 /* mark the element */
3239 value = row->payload[witness];
3240 row->payload[witness] = MARK(value);
3242 /* set the value in the stack (overwriting old witnesses!) */
3243 setStackPtr( base - i*sizeofW(StgPtr), stgCast(StgPtr,value) );
3246 /* pop the garbage from the stack */
3247 gSp = gSp + base - n*sizeofW(StgPtr);
3249 /* unmark elements */
3250 for( i = 0; i < row->ptrs; i++)
3252 value = row->payload[i];
3253 if (ISMARKED(value)) row->payload[i] = UNMARK(value);
3257 for (i = 0; i < row->ptrs; i++)
3259 ASSERT(!ISMARKED(row->payload[i]));
3265 #endif /* XMLAMBDA */
3269 StgClosure* init = PopCPtr();
3271 = stgCast(StgMutVar*,allocate(sizeofW(StgMutVar)));
3272 SET_HDR(mv,&MUT_VAR_info,CCCS);
3274 PushPtr(stgCast(StgPtr,mv));
3279 StgMutVar* mv = stgCast(StgMutVar*,PopPtr());
3285 StgMutVar* mv = stgCast(StgMutVar*,PopPtr());
3286 StgClosure* value = PopCPtr();
3292 nat n = PopTaggedInt(); /* or Word?? */
3293 StgClosure* init = PopCPtr();
3294 StgWord size = sizeofW(StgMutArrPtrs) + n;
3297 = stgCast(StgMutArrPtrs*,allocate(size));
3298 SET_HDR(arr,&MUT_ARR_PTRS_info,CCCS);
3300 for (i = 0; i < n; ++i) {
3301 arr->payload[i] = init;
3303 PushPtr(stgCast(StgPtr,arr));
3309 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
3310 nat i = PopTaggedInt(); /* or Word?? */
3311 StgWord n = arr->ptrs;
3313 return (raiseIndex("{index,read}Array"));
3315 PushCPtr(arr->payload[i]);
3320 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
3321 nat i = PopTaggedInt(); /* or Word? */
3322 StgClosure* v = PopCPtr();
3323 StgWord n = arr->ptrs;
3325 return (raiseIndex("{index,read}Array"));
3327 arr->payload[i] = v;
3331 case i_sizeMutableArray:
3333 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
3334 PushTaggedInt(arr->ptrs);
3337 case i_unsafeFreezeArray:
3339 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
3340 SET_INFO(arr,&MUT_ARR_PTRS_FROZEN_info);
3341 PushPtr(stgCast(StgPtr,arr));
3344 case i_unsafeFreezeByteArray:
3346 /* Delightfully simple :-) */
3350 case i_sameMutableArray:
3351 case i_sameMutableByteArray:
3353 StgPtr x = PopPtr();
3354 StgPtr y = PopPtr();
3355 PushTaggedBool(x==y);
3359 case i_newByteArray:
3361 nat n = PopTaggedInt(); /* or Word?? */
3362 StgInt words = (n+sizeof(W_)-1)/sizeof(W_);
3363 StgWord size = sizeofW(StgArrWords) + words;
3364 StgArrWords* arr = stgCast(StgArrWords*,allocate(size));
3365 SET_HDR(arr,&ARR_WORDS_info,CCCS);
3369 for (i = 0; i < n; ++i) {
3370 arr->payload[i] = 0xdeadbeef;
3373 PushPtr(stgCast(StgPtr,arr));
3377 /* Most of these generate alignment warnings on Sparcs and similar architectures.
3378 * These are harmless and are caused by the cast to C* in BYTE_ARR_CTS.
3380 case i_indexCharArray:
3381 OP_mI_ty(Char,"indexCharArray", indexCharArrayzh(r,x,i)); break;
3382 case i_readCharArray:
3383 OP_mI_ty(Char,"readCharArray", readCharArrayzh(r,x,i)); break;
3384 case i_writeCharArray:
3385 OP_mIty_(Char,"writeCharArray", writeCharArrayzh(x,i,z)); break;
3387 case i_indexIntArray:
3388 OP_mI_ty(Int,"indexIntArray", indexIntArrayzh(r,x,i)); break;
3389 case i_readIntArray:
3390 OP_mI_ty(Int,"readIntArray", readIntArrayzh(r,x,i)); break;
3391 case i_writeIntArray:
3392 OP_mIty_(Int,"writeIntArray", writeIntArrayzh(x,i,z)); break;
3394 case i_indexAddrArray:
3395 OP_mI_ty(Addr,"indexAddrArray", indexAddrArrayzh(r,x,i)); break;
3396 case i_readAddrArray:
3397 OP_mI_ty(Addr,"readAddrArray", readAddrArrayzh(r,x,i)); break;
3398 case i_writeAddrArray:
3399 OP_mIty_(Addr,"writeAddrArray", writeAddrArrayzh(x,i,z)); break;
3401 case i_indexFloatArray:
3402 OP_mI_ty(Float,"indexFloatArray", indexFloatArrayzh(r,x,i)); break;
3403 case i_readFloatArray:
3404 OP_mI_ty(Float,"readFloatArray", readFloatArrayzh(r,x,i)); break;
3405 case i_writeFloatArray:
3406 OP_mIty_(Float,"writeFloatArray", writeFloatArrayzh(x,i,z)); break;
3408 case i_indexDoubleArray:
3409 OP_mI_ty(Double,"indexDoubleArray", indexDoubleArrayzh(r,x,i)); break;
3410 case i_readDoubleArray:
3411 OP_mI_ty(Double,"readDoubleArray", readDoubleArrayzh(r,x,i)); break;
3412 case i_writeDoubleArray:
3413 OP_mIty_(Double,"writeDoubleArray", writeDoubleArrayzh(x,i,z)); break;
3416 #ifdef PROVIDE_STABLE
3417 case i_indexStableArray:
3418 OP_mI_ty(StablePtr,"indexStableArray", indexStablePtrArrayzh(r,x,i)); break;
3419 case i_readStableArray:
3420 OP_mI_ty(StablePtr,"readStableArray", readStablePtrArrayzh(r,x,i)); break;
3421 case i_writeStableArray:
3422 OP_mIty_(StablePtr,"writeStableArray", writeStablePtrArrayzh(x,i,z)); break;
3428 #ifdef PROVIDE_COERCE
3429 case i_unsafeCoerce:
3431 /* Another nullop */
3435 #ifdef PROVIDE_PTREQUALITY
3436 case i_reallyUnsafePtrEquality:
3437 { /* identical to i_sameRef */
3438 StgPtr x = PopPtr();
3439 StgPtr y = PopPtr();
3440 PushTaggedBool(x==y);
3444 #ifdef PROVIDE_FOREIGN
3445 /* ForeignObj# operations */
3446 case i_mkForeignObj:
3448 StgForeignObj *result
3449 = stgCast(StgForeignObj*,allocate(sizeofW(StgForeignObj)));
3450 SET_HDR(result,&FOREIGN_info,CCCS);
3451 result -> data = PopTaggedAddr();
3452 PushPtr(stgCast(StgPtr,result));
3455 #endif /* PROVIDE_FOREIGN */
3460 = stgCast(StgWeak*,allocate(sizeofW(StgWeak)));
3461 SET_HDR(w, &WEAK_info, CCCS);
3463 w->value = PopCPtr();
3464 w->finaliser = PopCPtr();
3465 w->link = weak_ptr_list;
3467 IF_DEBUG(weak, fprintf(stderr,"New weak pointer at %p\n",w));
3468 PushPtr(stgCast(StgPtr,w));
3473 StgWeak *w = stgCast(StgWeak*,PopPtr());
3474 if (w->header.info == &WEAK_info) {
3475 PushCPtr(w->value); /* last result */
3476 PushTaggedInt(1); /* first result */
3478 PushPtr(stgCast(StgPtr,w));
3479 /* ToDo: error thunk would be better */
3484 #endif /* PROVIDE_WEAK */
3486 case i_makeStablePtr:
3488 StgPtr p = PopPtr();
3489 StgStablePtr sp = getStablePtr ( p );
3490 PushTaggedStablePtr(sp);
3493 case i_deRefStablePtr:
3496 StgStablePtr sp = PopTaggedStablePtr();
3497 p = deRefStablePtr(sp);
3501 case i_freeStablePtr:
3503 StgStablePtr sp = PopTaggedStablePtr();
3508 case i_createAdjThunkARCH:
3510 StgStablePtr stableptr = PopTaggedStablePtr();
3511 StgAddr typestr = PopTaggedAddr();
3512 StgChar callconv = PopTaggedChar();
3513 StgAddr adj_thunk = createAdjThunk(stableptr,typestr,callconv);
3514 PushTaggedAddr(adj_thunk);
3520 StgInt n = prog_argc;
3526 StgInt n = PopTaggedInt();
3527 StgAddr a = (StgAddr)prog_argv[n];
3534 StgMVar *mvar = stgCast(StgMVar*,allocate(sizeofW(StgMVar)));
3535 SET_INFO(mvar,&EMPTY_MVAR_info);
3536 mvar->head = mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
3537 mvar->value = stgCast(StgClosure*,&END_TSO_QUEUE_closure);
3538 PushPtr(stgCast(StgPtr,mvar));
3543 StgMVar *mvar = (StgMVar*)PopCPtr();
3544 if (GET_INFO(mvar) == &EMPTY_MVAR_info) {
3546 /* The MVar is empty. Attach ourselves to the TSO's
3549 if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
3550 mvar->head = cap->rCurrentTSO;
3552 mvar->tail->link = cap->rCurrentTSO;
3554 cap->rCurrentTSO->link = (StgTSO *)&END_TSO_QUEUE_closure;
3555 cap->rCurrentTSO->why_blocked = BlockedOnMVar;
3556 cap->rCurrentTSO->block_info.closure = (StgClosure *)mvar;
3557 mvar->tail = cap->rCurrentTSO;
3559 /* At this point, the top-of-stack holds the MVar,
3560 and underneath is the world token (). So the
3561 stack is in the same state as when primTakeMVar
3562 was entered (primTakeMVar is handwritten bytecode).
3563 Push obj, which is this BCO, and return to the
3564 scheduler. When the MVar is filled, the scheduler
3565 will re-enter primTakeMVar, with the args still on
3566 the top of the stack.
3568 PushCPtr((StgClosure*)(*bco));
3569 *return2 = ThreadBlocked;
3570 return (void*)(1+(char*)(NULL));
3573 PushCPtr(mvar->value);
3574 mvar->value = (StgClosure *)&END_TSO_QUEUE_closure;
3575 SET_INFO(mvar,&EMPTY_MVAR_info);
3581 StgMVar* mvar = stgCast(StgMVar*,PopPtr());
3582 StgClosure* value = PopCPtr();
3583 if (GET_INFO(mvar) == &FULL_MVAR_info) {
3584 return (makeErrorCall("putMVar {full MVar}"));
3586 /* wake up the first thread on the
3587 * queue, it will continue with the
3588 * takeMVar operation and mark the
3591 mvar->value = value;
3593 if (mvar->head != (StgTSO *)&END_TSO_QUEUE_closure) {
3594 ASSERT(mvar->head->why_blocked == BlockedOnMVar);
3595 mvar->head = unblockOne(mvar->head);
3596 if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
3597 mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
3601 /* unlocks the MVar in the SMP case */
3602 SET_INFO(mvar,&FULL_MVAR_info);
3604 /* yield for better communication performance */
3610 { /* identical to i_sameRef */
3611 StgMVar* x = (StgMVar*)PopPtr();
3612 StgMVar* y = (StgMVar*)PopPtr();
3613 PushTaggedBool(x==y);
3616 #ifdef PROVIDE_CONCURRENT
3619 StgClosure* closure;
3622 closure = PopCPtr();
3623 tso = createGenThread (RtsFlags.GcFlags.initialStkSize,closure);
3625 scheduleThread(tso);
3627 /* Later: Change to use tso as the ThreadId */
3628 PushTaggedWord(tid);
3634 StgWord n = PopTaggedWord();
3638 // Map from ThreadId to Thread Structure */
3639 for (t = all_threads; t != END_TSO_QUEUE; t = t->global_link) {
3648 while (tso->what_next == ThreadRelocated) {
3653 if (tso == cap->rCurrentTSO) { /* suicide */
3654 *return2 = ThreadFinished;
3655 return (void*)(1+(char*)(NULL));
3659 case i_raiseInThread:
3660 barf("raiseInThread");
3661 ASSERT(0); /* not (yet) supported */
3664 StgInt n = PopTaggedInt();
3666 hugsBlock->reason = BlockedOnDelay;
3667 hugsBlock->delay = n;
3672 StgInt n = PopTaggedInt();
3674 hugsBlock->reason = BlockedOnRead;
3675 hugsBlock->delay = n;
3680 StgInt n = PopTaggedInt();
3682 hugsBlock->reason = BlockedOnWrite;
3683 hugsBlock->delay = n;
3688 /* The definition of yield include an enter right after
3689 * the primYield, at which time context_switch is tested.
3696 StgWord tid = cap->rCurrentTSO->id;
3697 PushTaggedWord(tid);
3700 case i_cmpThreadIds:
3702 StgWord tid1 = PopTaggedWord();
3703 StgWord tid2 = PopTaggedWord();
3704 if (tid1 < tid2) PushTaggedInt(-1);
3705 else if (tid1 > tid2) PushTaggedInt(1);
3706 else PushTaggedInt(0);
3709 #endif /* PROVIDE_CONCURRENT */
3714 CFunDescriptor descriptor;
3715 void (*funPtr)(void);
3717 StgWord offset = PopTaggedWord(); /* offset into bco nonptr section */
3718 funPtr = PopTaggedAddr();
3720 ASSERT(funPtr != NULL);
3722 /* copy the complete callinfo, the bco might move during GC! */
3723 callInfo = *stgCast(CallInfo*, (*bco)->payload + (*bco)->n_ptrs + offset);
3725 /* copy info to a CFunDescriptor. just for compatibility. */
3726 descriptor.num_args = callInfo.argCount;
3727 descriptor.arg_tys = callInfo.data;
3728 descriptor.num_results = callInfo.resultCount;
3729 descriptor.result_tys = callInfo.data + callInfo.argCount + 1;
3732 switch (ccall( &descriptor, funPtr, bco, callInfo.callConv, cap ))
3735 case 1: barf( "unhandled type or too many args/results in ccall"); break;
3736 case 2: barf("ccall not configured correctly for this platform"); break;
3737 default: barf("unknown return code from ccall"); break;
3744 case i_ccall_ccall_Id:
3745 case i_ccall_ccall_IO:
3746 case i_ccall_stdcall_Id:
3747 case i_ccall_stdcall_IO:
3750 CFunDescriptor* descriptor;
3751 void (*funPtr)(void);
3753 descriptor = PopTaggedAddr();
3754 funPtr = PopTaggedAddr();
3755 cc = (primop2code == i_ccall_stdcall_Id ||
3756 primop2code == i_ccall_stdcall_IO)
3758 r = ccall(descriptor,funPtr,bco,cc,cap);
3761 return makeErrorCall(
3762 "unhandled type or too many args/results in ccall");
3764 barf("ccall not configured correctly for this platform");
3765 barf("unknown return code from ccall");
3768 barf("Unrecognised primop2");
3774 /* -----------------------------------------------------------------------------
3775 * ccall support code:
3776 * marshall moves args from C stack to Haskell stack
3777 * unmarshall moves args from Haskell stack to C stack
3778 * argSize calculates how much gSpace you need on the C stack
3779 * ---------------------------------------------------------------------------*/
3781 /* Pop arguments off the C stack and Push them onto the Hugs stack.
3782 * Used when preparing for C calling Haskell or in regSponse to
3783 * Haskell calling C.
3785 nat marshall(char arg_ty, void* arg)
3789 PushTaggedInt(*((int*)arg));
3790 return ARG_SIZE(INT_TAG);
3793 PushTaggedInteger(*((mpz_ptr*)arg));
3794 return ARG_SIZE(INTEGER_TAG);
3797 PushTaggedWord(*((unsigned int*)arg));
3798 return ARG_SIZE(WORD_TAG);
3800 PushTaggedChar(*((char*)arg));
3801 return ARG_SIZE(CHAR_TAG);
3803 PushTaggedFloat(*((float*)arg));
3804 return ARG_SIZE(FLOAT_TAG);
3806 PushTaggedDouble(*((double*)arg));
3807 return ARG_SIZE(DOUBLE_TAG);
3809 PushTaggedAddr(*((void**)arg));
3810 return ARG_SIZE(ADDR_TAG);
3812 PushTaggedStablePtr(*((StgStablePtr*)arg));
3813 return ARG_SIZE(STABLE_TAG);
3814 #ifdef PROVIDE_FOREIGN
3816 /* Not allowed in this direction - you have to
3817 * call makeForeignPtr explicitly
3819 barf("marshall: ForeignPtr#\n");
3824 /* Not allowed in this direction */
3825 barf("marshall: [Mutable]ByteArray#\n");
3828 barf("marshall: unrecognised arg type %d\n",arg_ty);
3833 /* Pop arguments off the Hugs stack and Push them onto the C stack.
3834 * Used when preparing for Haskell calling C or in regSponse to
3835 * C calling Haskell.
3837 nat unmarshall(char res_ty, void* res)
3841 *((int*)res) = PopTaggedInt();
3842 return ARG_SIZE(INT_TAG);
3845 *((mpz_ptr*)res) = PopTaggedInteger();
3846 return ARG_SIZE(INTEGER_TAG);
3849 *((unsigned int*)res) = PopTaggedWord();
3850 return ARG_SIZE(WORD_TAG);
3852 *((int*)res) = PopTaggedChar();
3853 return ARG_SIZE(CHAR_TAG);
3855 *((float*)res) = PopTaggedFloat();
3856 return ARG_SIZE(FLOAT_TAG);
3858 *((double*)res) = PopTaggedDouble();
3859 return ARG_SIZE(DOUBLE_TAG);
3861 *((void**)res) = PopTaggedAddr();
3862 return ARG_SIZE(ADDR_TAG);
3864 *((StgStablePtr*)res) = PopTaggedStablePtr();
3865 return ARG_SIZE(STABLE_TAG);
3866 #ifdef PROVIDE_FOREIGN
3869 StgForeignObj *result = stgCast(StgForeignObj*,PopPtr());
3870 *((void**)res) = result->data;
3871 return sizeofW(StgPtr);
3877 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
3878 *((void**)res) = stgCast(void*,&(arr->payload));
3879 return sizeofW(StgPtr);
3882 barf("unmarshall: unrecognised result type %d\n",res_ty);
3886 nat argSize( const char* ks )
3889 for( ; *ks != '\0'; ++ks) {
3892 sz += sizeof(StgWord) * ARG_SIZE(INT_TAG);
3896 sz += sizeof(StgWord) * ARG_SIZE(INTEGER_TAG);
3900 sz += sizeof(StgWord) * ARG_SIZE(WORD_TAG);
3903 sz += sizeof(StgWord) * ARG_SIZE(CHAR_TAG);
3906 sz += sizeof(StgWord) * ARG_SIZE(FLOAT_TAG);
3909 sz += sizeof(StgWord) * ARG_SIZE(DOUBLE_TAG);
3912 sz += sizeof(StgWord) * ARG_SIZE(ADDR_TAG);
3915 sz += sizeof(StgWord) * ARG_SIZE(STABLE_TAG);
3917 #ifdef PROVIDE_FOREIGN
3922 sz += sizeof(StgPtr);
3925 barf("argSize: unrecognised result type %d\n",*ks);
3933 /* -----------------------------------------------------------------------------
3934 * encode/decode Float/Double code for standalone Hugs
3935 * Code based on the HBC code (lib/fltcode.c) and more recently GHC
3936 * (ghc/rts/StgPrimFloat.c)
3937 * ---------------------------------------------------------------------------*/
3939 #if IEEE_FLOATING_POINT
3940 #define MY_DMINEXP ((DBL_MIN_EXP) - (DBL_MANT_DIG) - 1)
3941 /* DMINEXP is defined in values.h on Linux (for example) */
3942 #define DHIGHBIT 0x00100000
3943 #define DMSBIT 0x80000000
3945 #define MY_FMINEXP ((FLT_MIN_EXP) - (FLT_MANT_DIG) - 1)
3946 #define FHIGHBIT 0x00800000
3947 #define FMSBIT 0x80000000
3949 #error The following code doesnt work in a non-IEEE FP environment
3952 #ifdef WORDS_BIGENDIAN
3961 StgDouble B__encodeDouble (B* s, I_ e) /* result = s * 2^e */
3966 /* Convert a B to a double; knows a lot about internal rep! */
3967 for(r = 0.0, i = s->used-1; i >= 0; i--)
3968 r = (r * B_BASE_FLT) + s->stuff[i];
3970 /* Now raise to the exponent */
3971 if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
3974 /* handle the sign */
3975 if (s->sign < 0) r = -r;
3982 StgFloat B__encodeFloat (B* s, I_ e) /* result = s * 2^e */
3987 /* Convert a B to a float; knows a lot about internal rep! */
3988 for(r = 0.0, i = s->used-1; i >= 0; i--)
3989 r = (r * B_BASE_FLT) + s->stuff[i];
3991 /* Now raise to the exponent */
3992 if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
3995 /* handle the sign */
3996 if (s->sign < 0) r = -r;
4003 /* This only supports IEEE floating point */
4004 void B__decodeDouble (B* man, I_* exp, StgDouble dbl)
4006 /* Do some bit fiddling on IEEE */
4007 nat low, high; /* assuming 32 bit ints */
4009 union { double d; int i[2]; } u; /* assuming 32 bit ints, 64 bit double */
4011 u.d = dbl; /* grab chunks of the double */
4015 ASSERT(B_BASE == 256);
4017 /* Assume that the supplied B is the right size */
4020 if (low == 0 && (high & ~DMSBIT) == 0) {
4021 man->sign = man->used = 0;
4026 iexp = ((high >> 20) & 0x7ff) + MY_DMINEXP;
4030 if (iexp != MY_DMINEXP) /* don't add hidden bit to denorms */
4034 /* A denorm, normalize the mantissa */
4035 while (! (high & DHIGHBIT)) {
4045 man->stuff[7] = (((W_)high) >> 24) & 0xff;
4046 man->stuff[6] = (((W_)high) >> 16) & 0xff;
4047 man->stuff[5] = (((W_)high) >> 8) & 0xff;
4048 man->stuff[4] = (((W_)high) ) & 0xff;
4050 man->stuff[3] = (((W_)low) >> 24) & 0xff;
4051 man->stuff[2] = (((W_)low) >> 16) & 0xff;
4052 man->stuff[1] = (((W_)low) >> 8) & 0xff;
4053 man->stuff[0] = (((W_)low) ) & 0xff;
4055 if (sign < 0) man->sign = -1;
4057 do_renormalise(man);
4061 void B__decodeFloat (B* man, I_* exp, StgFloat flt)
4063 /* Do some bit fiddling on IEEE */
4064 int high, sign; /* assuming 32 bit ints */
4065 union { float f; int i; } u; /* assuming 32 bit float and int */
4067 u.f = flt; /* grab the float */
4070 ASSERT(B_BASE == 256);
4072 /* Assume that the supplied B is the right size */
4075 if ((high & ~FMSBIT) == 0) {
4076 man->sign = man->used = 0;
4081 *exp = ((high >> 23) & 0xff) + MY_FMINEXP;
4085 if (*exp != MY_FMINEXP) /* don't add hidden bit to denorms */
4089 /* A denorm, normalize the mantissa */
4090 while (! (high & FHIGHBIT)) {
4095 man->stuff[3] = (((W_)high) >> 24) & 0xff;
4096 man->stuff[2] = (((W_)high) >> 16) & 0xff;
4097 man->stuff[1] = (((W_)high) >> 8) & 0xff;
4098 man->stuff[0] = (((W_)high) ) & 0xff;
4100 if (sign < 0) man->sign = -1;
4102 do_renormalise(man);
4105 #endif /* INTERPRETER */