2 /* -----------------------------------------------------------------------------
5 * Copyright (c) 1994-1998.
7 * $RCSfile: Evaluator.c,v $
9 * $Date: 2000/06/23 12:09:00 $
10 * ---------------------------------------------------------------------------*/
20 #include "SchedAPI.h" /* for createGenThread */
21 #include "Schedule.h" /* for context_switch */
22 #include "Bytecodes.h"
23 #include "Assembler.h" /* for CFun stuff */
24 #include "ForeignCall.h"
25 #include "PrimOps.h" /* for __{encode,decode}{Float,Double} */
28 #include "Evaluator.h"
29 #include "sainteger.h"
33 #include "Disassembler.h"
38 #include <math.h> /* These are for primops */
39 #include <limits.h> /* These are for primops */
40 #include <float.h> /* These are for primops */
42 #include <ieee754.h> /* These are for primops */
46 /* Allegedly useful macro, taken from ClosureMacros.h */
47 #define payloadWord( c, i ) (*stgCast(StgWord*, ((c)->payload+(i))))
48 #define payloadPtr( c, i ) (*stgCast(StgPtr*, ((c)->payload+(i))))
50 /* An incredibly useful abbreviation.
51 * Interestingly, there are some uses of END_TSO_QUEUE_closure that
52 * can't use it because they use the closure at type StgClosure* or
53 * even StgPtr*. I suspect they should be changed. -- ADR
55 #define EndTSOQueue stgCast(StgTSO*,(void*)&END_TSO_QUEUE_closure)
57 /* These macros are rather delicate - read a good ANSI C book carefully
61 #define mycat(x,y) x##y
62 #define mycat2(x,y) mycat(x,y)
63 #define mycat3(x,y,z) mycat2(x,mycat2(y,z))
65 #if defined(__GNUC__) && !defined(DEBUG)
66 #define USE_GCC_LABELS 1
68 #define USE_GCC_LABELS 0
71 /* Make it possible for the evaluator to get hold of bytecode
72 for a given function by name. Useful but a hack. Sigh.
74 extern void* /* StgClosure* */ getHugs_BCO_cptr_for ( char* s );
75 extern int /* Bool */ combined;
79 /* --------------------------------------------------------------------------
80 * Hugs Hooks - a bit of a hack
81 * ------------------------------------------------------------------------*/
83 void setRtsFlags( int x );
84 void setRtsFlags( int x )
86 unsigned int w = 0x12345678;
87 unsigned char* pw = (unsigned char *)&w;
90 *(int*)(&(RtsFlags.DebugFlags)) = x;
95 w2 |= (w1 && 0xFF); w2 <<= 8; w1 >>= 8;
96 w2 |= (w1 && 0xFF); w2 <<= 8; w1 >>= 8;
97 w2 |= (w1 && 0xFF); w2 <<= 8; w1 >>= 8;
98 w2 |= (w1 && 0xFF); w2 <<= 8; w1 >>= 8;
99 *(int*)(&(RtsFlags.DebugFlags)) = (int)w2;
105 StgTSOBlockReason reason;
110 /* --------------------------------------------------------------------------
111 * Entering-objects and bytecode interpreter part of evaluator
112 * ------------------------------------------------------------------------*/
114 /* The primop (and all other) parts of this evaluator operate upon the
115 machine state which lives in MainRegTable. enter is different:
116 to make its closure- and bytecode-interpreting loops go fast, some of that
117 state is pulled out into local vars (viz, registers, if we are lucky).
118 That means that we need to save(load) the local state at every exit(reentry)
119 into enter. That is, around every procedure call it makes. Blargh!
120 If you modify this code, __be warned__ it will fail in mysterious ways if
121 you fail to preserve this property.
123 Currently the pulled-out state is Sp in xSp, Su in xSu and SpLim in xSpLim.
124 The SSS macros saves the state back in MainRegTable, and LLL loads it from
125 MainRegTable. RETURN(v) does SSS and then returns v; all exits should
126 be via RETURN and not plain return.
128 Since xSp, xSu and xSpLim are local vars in enter, they are not visible
129 in procedures called from enter. To fix this, either (1) turn the
130 procedures into macros, so they get copied inline, or (2) bracket
131 the procedure call with SSS and LLL so that the local and global
132 machine states are synchronised for the duration of the call.
136 /* Forward decls ... */
137 static void* enterBCO_primop1 ( int );
138 static void* enterBCO_primop2 ( int , int* /*StgThreadReturnCode* */,
139 StgBCO**, Capability*, HugsBlock * );
140 static inline void PopUpdateFrame ( StgClosure* obj );
141 static inline void PopCatchFrame ( void );
142 static inline void PopSeqFrame ( void );
143 static inline void PopStopFrame( StgClosure* obj );
144 static inline void PushTaggedRealWorld( void );
145 /* static inline void PushTaggedInteger ( mpz_ptr ); */
146 static inline StgPtr grabHpUpd( nat size );
147 static inline StgPtr grabHpNonUpd( nat size );
148 static StgClosure* raiseAnError ( StgClosure* exception );
150 static int enterCountI = 0;
152 StgDouble B__encodeDouble (B* s, I_ e);
153 void B__decodeDouble (B* man, I_* exp, StgDouble dbl);
154 #if ! FLOATS_AS_DOUBLES
155 StgFloat B__encodeFloat (B* s, I_ e);
156 void B__decodeFloat (B* man, I_* exp, StgFloat flt);
157 StgPtr CreateByteArrayToHoldInteger ( int );
158 B* IntegerInsideByteArray ( StgPtr );
159 void SloppifyIntegerEnd ( StgPtr );
165 #define gSp MainRegTable.rSp
166 #define gSu MainRegTable.rSu
167 #define gSpLim MainRegTable.rSpLim
170 /* Macros to save/load local state. */
172 #define SSS { tSp=gSp = xSp; tSu=gSu = xSu; tSpLim=gSpLim = xSpLim; }
173 #define LLL { tSp=xSp = gSp; tSu=xSu = gSu; tSpLim=xSpLim = gSpLim; }
175 #define SSS { gSp = xSp; gSu = xSu; gSpLim = xSpLim; }
176 #define LLL { xSp = gSp; xSu = gSu; xSpLim = gSpLim; }
179 #define RETURN(vvv) { \
180 StgThreadReturnCode retVal=(vvv); \
182 cap->rCurrentTSO->sp = gSp; \
183 cap->rCurrentTSO->su = gSu; \
184 cap->rCurrentTSO->splim = gSpLim; \
189 /* Macros to operate directly on the pulled-out machine state.
190 These mirror some of the small procedures used in the primop code
191 below, except you have to be careful about side effects,
192 ie xPushPtr(xStackPtr(n)) won't work! It certainly isn't the
193 same as PushPtr(StackPtr(n)). Also note that (1) some of
194 the macros, in particular xPopTagged*, do not make the tag
195 sanity checks that their non-x cousins do, and (2) some of
196 the macros depend critically on the semantics of C comma
197 expressions to work properly.
199 #define xPushPtr(ppp) { xSp--; *xSp=(StgWord)(ppp); }
200 #define xPopPtr() ((StgPtr)(*xSp++))
202 #define xPushCPtr(ppp) { xSp--; *xSp=(StgWord)(ppp); }
203 #define xPopCPtr() ((StgClosure*)(*xSp++))
205 #define xPushWord(ppp) { xSp--; *xSp=(StgWord)(ppp); }
206 #define xPopWord() ((StgWord)(*xSp++))
208 #define xStackPtr(nnn) ((StgPtr)(*(xSp+(nnn))))
209 #define xStackWord(nnn) ((StgWord)(*(xSp+(nnn))))
210 #define xSetStackWord(iii,www) xSp[iii]=(StgWord)(www)
212 #define xPushTag(ttt) { xSp--; *xSp=(StgWord)(ttt); }
213 #define xPopTag(ttt) { StackTag t = (StackTag)(*xSp++); \
216 #define xPushTaggedInt(xxx) { xSp -= sizeofW(StgInt); \
217 *xSp = (xxx); xPushTag(INT_TAG); }
218 #define xTaggedStackInt(iii) ((StgInt)(*(xSp+1+(iii))))
219 #define xPopTaggedInt() ((xSp++,xSp+=sizeofW(StgInt), \
220 (StgInt)(*(xSp-sizeofW(StgInt)))))
222 #define xPushTaggedWord(xxx) { xSp -= sizeofW(StgWord); \
223 *xSp = (xxx); xPushTag(WORD_TAG); }
224 #define xTaggedStackWord(iii) ((StgWord)(*(xSp+1+(iii))))
225 #define xPopTaggedWord() ((xSp++,xSp+=sizeofW(StgWord), \
226 (StgWord)(*(xSp-sizeofW(StgWord)))))
228 #define xPushTaggedAddr(xxx) { xSp -= sizeofW(StgAddr); \
229 *xSp = (StgWord)(xxx); xPushTag(ADDR_TAG); }
230 #define xTaggedStackAddr(iii) ((StgAddr)(*(xSp+1+(iii))))
231 #define xPopTaggedAddr() ((xSp++,xSp+=sizeofW(StgAddr), \
232 (StgAddr)(*(xSp-sizeofW(StgAddr)))))
234 #define xPushTaggedStable(xxx) { xSp -= sizeofW(StgStablePtr); \
235 *xSp = (StgWord)(xxx); xPushTag(STABLE_TAG); }
236 #define xTaggedStackStable(iii) ((StgStablePtr)(*(xSp+1+(iii))))
237 #define xPopTaggedStable() ((xSp++,xSp+=sizeofW(StgStablePtr), \
238 (StgStablePtr)(*(xSp-sizeofW(StgStablePtr)))))
240 #define xPushTaggedChar(xxx) { xSp -= sizeofW(StgChar); \
241 *xSp = (StgWord)(xxx); xPushTag(CHAR_TAG); }
242 #define xTaggedStackChar(iii) ((StgChar)(*(xSp+1+(iii))))
243 #define xPopTaggedChar() ((xSp++,xSp+=sizeofW(StgChar), \
244 (StgChar)(*(xSp-sizeofW(StgChar)))))
246 #define xPushTaggedFloat(xxx) { xSp -= sizeofW(StgFloat); \
247 ASSIGN_FLT(xSp,xxx); xPushTag(FLOAT_TAG); }
248 #define xTaggedStackFloat(iii) PK_FLT(xSp+1+(iii))
249 #define xPopTaggedFloat() ((xSp++,xSp+=sizeofW(StgFloat), \
250 PK_FLT(xSp-sizeofW(StgFloat))))
252 #define xPushTaggedDouble(xxx) { xSp -= sizeofW(StgDouble); \
253 ASSIGN_DBL(xSp,xxx); xPushTag(DOUBLE_TAG); }
254 #define xTaggedStackDouble(iii) PK_DBL(xSp+1+(iii))
255 #define xPopTaggedDouble() ((xSp++,xSp+=sizeofW(StgDouble), \
256 PK_DBL(xSp-sizeofW(StgDouble))))
259 #define xPushUpdateFrame(target, xSp_offset) \
261 StgUpdateFrame *__frame; \
262 __frame = (StgUpdateFrame *)(xSp + (xSp_offset)) - 1; \
263 SET_INFO(__frame, (StgInfoTable *)&upd_frame_info); \
264 __frame->link = xSu; \
265 __frame->updatee = (StgClosure *)(target); \
269 #define xPopUpdateFrame(ooo) \
271 /* NB: doesn't assume that Sp == Su */ \
272 IF_DEBUG(evaluator, \
273 fprintf(stderr, "Updating "); \
274 printPtr(stgCast(StgPtr,xSu->updatee)); \
275 fprintf(stderr, " with "); \
277 fprintf(stderr,"xSp = %p\txSu = %p\n\n", xSp, xSu); \
279 UPD_IND(xSu->updatee,ooo); \
280 xSp = stgCast(StgStackPtr,xSu) + sizeofW(StgUpdateFrame); \
286 /* Instruction stream macros */
287 #define BCO_INSTR_8 *bciPtr++
288 #define BCO_INSTR_16 ((bciPtr += 2, (*(bciPtr-2) << 8) + *(bciPtr-1)))
289 #define PC (bciPtr - &(bcoInstr(bco,0)))
292 /* State on entry to enter():
293 * - current thread is in cap->rCurrentTSO;
294 * - allocation area is in cap->rCurrentNursery & cap->rNursery
297 StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 )
299 /* use of register here is primarily to make it clear to compilers
300 that these entities are non-aliasable.
302 register StgPtr xSp; /* local state -- stack pointer */
303 register StgUpdateFrame* xSu; /* local state -- frame pointer */
304 register StgPtr xSpLim; /* local state -- stack lim pointer */
305 register StgClosure* obj; /* object currently under evaluation */
306 char eCount; /* enter counter, for context switching */
309 HugsBlock hugsBlock = { NotBlocked, 0 };
313 StgPtr tSp; StgUpdateFrame* tSu; StgPtr tSpLim;
316 gSp = cap->rCurrentTSO->sp;
317 gSu = cap->rCurrentTSO->su;
318 gSpLim = cap->rCurrentTSO->splim;
321 /* use the t values to check that Su/Sp/SpLim do not change unexpectedly */
322 tSp = gSp; tSu = gSu; tSpLim = gSpLim;
328 /* Load the local state from global state, and Party On, Dudes! */
329 /* From here onwards, we operate with the local state and
330 save/reload it as necessary.
341 ASSERT(gSpLim == tSpLim);
345 ASSERT(xSpLim <= xSp && xSp <= stgCast(StgPtr,xSu));
347 "\n---------------------------------------------------------------\n");
348 fprintf(stderr,"(%d) Entering: ",enterCountI); printObj(obj);
349 fprintf(stderr,"xSp = %p\txSu = %p\n", xSp, xSu);
350 fprintf(stderr, "\n" );
351 printStack(xSp,cap->rCurrentTSO->stack+cap->rCurrentTSO->stack_size,xSu);
352 fprintf(stderr, "\n\n");
359 ((++eCount) & 0x0F) == 0
364 if (context_switch) {
365 switch(hugsBlock.reason) {
367 xPushCPtr(obj); /* code to restart with */
368 RETURN(ThreadYielding);
370 case BlockedOnDelay: /* fall through */
371 case BlockedOnRead: /* fall through */
372 case BlockedOnWrite: {
373 ASSERT(cap->rCurrentTSO->why_blocked == NotBlocked);
374 cap->rCurrentTSO->why_blocked = BlockedOnDelay;
375 ACQUIRE_LOCK(&sched_mutex);
377 #if defined(HAVE_SETITIMER) || defined(mingw32_TARGET_OS)
378 cap->rCurrentTSO->block_info.delay
379 = hugsBlock.delay + ticks_since_select;
381 cap->rCurrentTSO->block_info.target
382 = hugsBlock.delay + getourtimeofday();
384 APPEND_TO_BLOCKED_QUEUE(cap->rCurrentTSO);
386 RELEASE_LOCK(&sched_mutex);
388 xPushCPtr(obj); /* code to restart with */
389 RETURN(ThreadBlocked);
392 barf("Unknown context switch reasoning");
397 switch ( get_itbl(obj)->type ) {
399 barf("Invalid object %p",obj);
403 /* ---------------------------------------------------- */
404 /* Start of the bytecode evaluator */
405 /* ---------------------------------------------------- */
408 # define Ins(x) &&l##x
409 static void *labs[] = { INSTRLIST };
411 # define LoopTopLabel
412 # define Case(x) l##x
413 # define Continue goto *labs[BCO_INSTR_8]
414 # define Dispatch Continue;
417 # define LoopTopLabel insnloop:
418 # define Case(x) case x
419 # define Continue goto insnloop
420 # define Dispatch switch (BCO_INSTR_8) {
421 # define EndDispatch }
424 register StgWord8* bciPtr; /* instruction pointer */
425 register StgBCO* bco = (StgBCO*)obj;
428 /* Don't need to SSS ... LLL around doYouWantToGC */
429 wantToGC = doYouWantToGC();
431 xPushCPtr((StgClosure*)bco); /* code to restart with */
432 RETURN(HeapOverflow);
435 bciPtr = &(bcoInstr(bco,0));
439 ASSERT((StgWord)(PC) < bco->n_instrs);
441 fprintf(stderr,"Sp = %p\tSu = %p\tpc = %d\t", xSp, xSu, PC);
445 fprintf(stderr,"\n");
446 for (i = 8; i >= 0; i--)
447 fprintf(stderr, "%d %p\n", i, (StgPtr)(*(gSp+i)));
449 fprintf(stderr,"\n");
455 Case(i_INTERNAL_ERROR):
456 barf("INTERNAL_ERROR at %p:%d",bco,PC-1);
458 barf("PANIC at %p:%d",bco,PC-1);
462 if (xSp - n < xSpLim) {
463 xPushCPtr((StgClosure*)bco); /* code to restart with */
464 RETURN(StackOverflow);
468 Case(i_STK_CHECK_big):
470 int n = BCO_INSTR_16;
471 if (xSp - n < xSpLim) {
472 xPushCPtr((StgClosure*)bco); /* code to restart with */
473 RETURN(StackOverflow);
480 if ((StgPtr*)(xSp + n) > (StgPtr*)xSu) {
481 StgWord words = (P_)xSu - xSp;
483 /* first build a PAP */
484 ASSERT((P_)xSu >= xSp); /* was (words >= 0) but that's always true */
485 if (words == 0) { /* optimisation */
486 /* Skip building the PAP and update with an indirection. */
489 /* In the evaluator, we avoid the need to do
490 * a heap check here by including the size of
491 * the PAP in the heap check we performed
492 * when we entered the BCO.
496 SSS; pap = (StgPAP*)grabHpNonUpd(PAP_sizeW(words)); LLL;
497 SET_HDR(pap,&PAP_info,CC_pap);
500 for (i = 0; i < (I_)words; ++i) {
501 payloadWord(pap,i) = xSp[i];
504 obj = stgCast(StgClosure*,pap);
507 /* now deal with "update frame" */
508 /* as an optimisation, we process all on top of stack */
509 /* instead of just the top one */
510 ASSERT(xSp==(P_)xSu);
512 switch (get_itbl(xSu)->type) {
514 /* Hit a catch frame during an arg satisfaction check,
515 * so the thing returning (1) has not thrown an
516 * exception, and (2) is of functional type. Just
517 * zap the catch frame and carry on down the stack
518 * (looking for more arguments, basically).
520 SSS; PopCatchFrame(); LLL;
523 xPopUpdateFrame(obj);
526 barf("STOP frame during pap update");
528 cap->rCurrentTSO->what_next = ThreadComplete;
529 SSS; PopStopFrame(obj); LLL;
530 RETURN(ThreadFinished);
533 SSS; PopSeqFrame(); LLL;
534 ASSERT(xSp != (P_)xSu);
535 /* Hit a SEQ frame during an arg satisfaction check.
536 * So now return to bco_info which is under the
537 * SEQ frame. The following code is copied from a
538 * case RET_BCO further down. (The reason why we're
539 * here is that something of functional type has
540 * been seq-d on, and we're now returning to the
541 * algebraic-case-continuation which forced the
542 * evaluation in the first place.)
554 barf("Invalid update frame during argcheck");
556 } while (xSp==(P_)xSu);
564 int words = BCO_INSTR_8;
565 SSS; p = grabHpUpd(AP_sizeW(words)); LLL;
569 Case(i_ALLOC_CONSTR):
572 StgInfoTable* info = bcoConstAddr(bco,BCO_INSTR_8);
573 SSS; p = grabHpNonUpd(sizeW_fromITBL(info)); LLL;
574 SET_HDR((StgClosure*)p,info,??);
578 Case(i_ALLOC_CONSTR_big):
581 int x = BCO_INSTR_16;
582 StgInfoTable* info = bcoConstAddr(bco,x);
583 SSS; p = grabHpNonUpd(sizeW_fromITBL(info)); LLL;
584 SET_HDR((StgClosure*)p,info,??);
589 /* allocate rows, implemented on top of Arrays */
594 SSS; p = stgCast(StgMutArrPtrs*,grabHpNonUpd(sizeofW(StgMutArrPtrs) + n)); LLL;
595 SET_HDR(p,&MUT_ARR_PTRS_FROZEN_info,CCCS);
600 Case(i_ALLOC_ROW_big):
603 int n = BCO_INSTR_16;
604 SSS; p = stgCast(StgMutArrPtrs*,grabHpNonUpd(sizeofW(StgMutArrPtrs) + n)); LLL;
605 SET_HDR(p,&MUT_ARR_PTRS_FROZEN_info,CCCS);
613 int x = BCO_INSTR_8; /* ToDo: Word not Int! */
615 StgAP_UPD* o = stgCast(StgAP_UPD*,xStackPtr(x));
616 SET_HDR(o,&AP_UPD_info,??);
618 o->fun = stgCast(StgClosure*,xPopPtr());
619 for(x=0; x < y; ++x) {
620 payloadWord(o,x) = xPopWord();
623 fprintf(stderr,"\tBuilt ");
625 printObj(stgCast(StgClosure*,o));
636 o = stgCast(StgAP_UPD*,xStackPtr(x));
637 SET_HDR(o,&AP_UPD_info,??);
639 o->fun = stgCast(StgClosure*,xPopPtr());
640 for(x=0; x < y; ++x) {
641 payloadWord(o,x) = xPopWord();
644 fprintf(stderr,"\tBuilt ");
646 printObj(stgCast(StgClosure*,o));
655 StgPAP* o = stgCast(StgPAP*,xStackPtr(x));
656 SET_HDR(o,&PAP_info,??);
658 o->fun = stgCast(StgClosure*,xPopPtr());
659 for(x=0; x < y; ++x) {
660 payloadWord(o,x) = xPopWord();
663 fprintf(stderr,"\tBuilt ");
665 printObj(stgCast(StgClosure*,o));
672 int offset = BCO_INSTR_8;
673 StgClosure* o = stgCast(StgClosure*,xStackPtr(offset));
674 const StgInfoTable* info = get_itbl(o);
675 nat p = info->layout.payload.ptrs;
676 nat np = info->layout.payload.nptrs;
678 for(i=0; i < p; ++i) {
679 o->payload[i] = xPopCPtr();
681 for(i=0; i < np; ++i) {
682 payloadWord(o,p+i) = 0xdeadbeef;
685 fprintf(stderr,"\tBuilt ");
687 printObj(stgCast(StgClosure*,o));
694 int offset = BCO_INSTR_16;
695 StgClosure* o = stgCast(StgClosure*,xStackPtr(offset));
696 const StgInfoTable* info = get_itbl(o);
697 nat p = info->layout.payload.ptrs;
698 nat np = info->layout.payload.nptrs;
700 for(i=0; i < p; ++i) {
701 o->payload[i] = xPopCPtr();
703 for(i=0; i < np; ++i) {
704 payloadWord(o,p+i) = 0xdeadbeef;
707 fprintf(stderr,"\tBuilt ");
709 printObj(stgCast(StgClosure*,o));
715 /* pack values into a row. */
718 int offset = BCO_INSTR_8;
719 StgMutArrPtrs* p = stgCast(StgMutArrPtrs*,xStackPtr(offset));
725 p->payload[i] = xPopCPtr();
728 fprintf(stderr,"\tBuilt ");
730 printObj(stgCast(StgClosure*,p));
735 Case(i_PACK_ROW_big):
737 int offset = BCO_INSTR_16;
738 StgMutArrPtrs* p = stgCast(StgMutArrPtrs*,xStackPtr(offset));
744 p->payload[i] = xPopCPtr();
747 fprintf(stderr,"\tBuilt ");
749 printObj(stgCast(StgClosure*,p));
754 /* pack values into an Inj */
757 const int size = CONSTR_sizeW(sizeofW(StgPtr),sizeofW(StgInt));
758 int offset = BCO_INSTR_8;
761 SSS; o = (StgClosure*)grabHpNonUpd(size); LLL;
762 SET_HDR(o,Inj_con_info,??);
764 payloadWord(o,sizeofW(StgPtr)) = xTaggedStackInt(offset);
765 payloadPtr(o,0) = xPopPtr();
768 fprintf(stderr,"\tBuilt ");
770 printObj(stgCast(StgClosure*,o));
773 xPushPtr(stgCast(StgPtr,o));
776 Case(i_PACK_INJ_big):
778 const int size = CONSTR_sizeW(sizeofW(StgPtr),sizeofW(StgInt));
779 int offset = BCO_INSTR_16;
782 SSS; o = (StgClosure*)grabHpNonUpd(size); LLL;
783 SET_HDR(o,Inj_con_info,??);
785 payloadWord(o,sizeofW(StgPtr)) = xTaggedStackInt(offset);
786 payloadPtr(o,0) = xPopPtr();
789 fprintf(stderr,"\tBuilt ");
791 printObj(stgCast(StgClosure*,o));
794 xPushPtr(stgCast(StgPtr,o));
797 Case(i_PACK_INJ_CONST):
799 const int size = CONSTR_sizeW(sizeofW(StgPtr),sizeofW(StgInt));
800 int index = BCO_INSTR_8;
803 SSS; o = (StgClosure*)grabHpNonUpd(size); LLL;
804 SET_HDR(o,Inj_con_info,??);
806 payloadWord(o,sizeofW(StgPtr)) = index;
807 payloadPtr(o,0) = xPopPtr();
810 fprintf(stderr,"\tBuilt ");
812 printObj(stgCast(StgClosure*,o));
815 xPushPtr(stgCast(StgPtr,o));
819 #endif /* XMLAMBDA */
824 ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
825 /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
827 xSetStackWord(x+y,xStackWord(x));
837 ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
838 /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
840 xSetStackWord(x+y,xStackWord(x));
852 xPushPtr(bcoConstPtr(bco,BCO_INSTR_8));
853 xPushPtr(stgCast(StgPtr,&ret_bco_info));
858 int tag = BCO_INSTR_8;
859 StgWord offset = BCO_INSTR_16;
860 if (constrTag( (StgClosure*)xStackPtr(0) ) != tag) {
866 /* Test Inj indices. */
869 int offset = BCO_INSTR_8;
870 StgWord jump = BCO_INSTR_16;
872 int index = payloadWord( (StgClosure*)xStackPtr(0), sizeofW(StgPtr) );
873 if (index != xTaggedStackInt(offset) )
879 Case(i_TEST_INJ_big):
881 int offset = BCO_INSTR_16;
882 StgWord jump = BCO_INSTR_16;
884 int index = payloadWord( (StgClosure*)xStackPtr(0), sizeofW(StgPtr) );
885 if (index != xTaggedStackInt(offset) )
891 Case(i_TEST_INJ_CONST):
893 int value = BCO_INSTR_8;
894 StgWord jump = BCO_INSTR_16;
896 int index = payloadWord( (StgClosure*)xStackPtr(0), sizeofW(StgPtr) );
903 #endif /* XMLAMBDA */
906 StgClosure* o = stgCast(StgClosure*,xStackPtr(0));
907 const StgInfoTable* itbl = get_itbl(o);
908 int i = itbl->layout.payload.ptrs;
909 ASSERT( itbl->type == CONSTR
910 || itbl->type == CONSTR_STATIC
911 || itbl->type == CONSTR_NOCAF_STATIC
912 || itbl->type == CONSTR_1_0
913 || itbl->type == CONSTR_0_1
914 || itbl->type == CONSTR_2_0
915 || itbl->type == CONSTR_1_1
916 || itbl->type == CONSTR_0_2
919 xPushCPtr(o->payload[i]);
924 /* extract all fields of a row */
927 StgMutArrPtrs* p = stgCast(StgMutArrPtrs*,xStackPtr(0));
931 xPushCPtr(p->payload[i]);
935 /* extract the value of an INJ */
938 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
940 ASSERT(get_itbl(con) == Inj_con_info);
942 xPushPtr(payloadPtr(con,0));
948 int n = BCO_INSTR_16;
949 StgPtr p = xStackPtr(n);
955 StgPtr p = xStackPtr(BCO_INSTR_8);
961 xPushPtr(stgCast(StgPtr,bcoConstPtr(bco,BCO_INSTR_8)));
966 int n = BCO_INSTR_16;
967 xPushPtr(stgCast(StgPtr,bcoConstPtr(bco,n)));
972 SSS; PushTaggedRealWorld(); LLL;
977 StgInt i = xTaggedStackInt(BCO_INSTR_8);
983 xPushTaggedInt(bcoConstInt(bco,BCO_INSTR_8));
986 Case(i_CONST_INT_big):
988 int n = BCO_INSTR_16;
989 xPushTaggedInt(bcoConstInt(bco,n));
995 SSS; o = (StgClosure*)grabHpNonUpd(Izh_sizeW); LLL;
996 SET_HDR(o,Izh_con_info,??);
997 payloadWord(o,0) = xPopTaggedInt();
999 fprintf(stderr,"\tBuilt ");
1001 printObj(stgCast(StgClosure*,o));
1004 xPushPtr(stgCast(StgPtr,o));
1009 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1010 /* ASSERT(isIntLike(con)); */
1011 xPushTaggedInt(payloadWord(con,0));
1016 StgWord offset = BCO_INSTR_16;
1017 StgInt x = xPopTaggedInt();
1018 StgInt y = xPopTaggedInt();
1024 Case(i_CONST_INTEGER):
1028 char* s = bcoConstAddr(bco,BCO_INSTR_8);
1030 n = size_fromStr(s);
1031 p = CreateByteArrayToHoldInteger(n);
1032 do_fromStr ( s, n, IntegerInsideByteArray(p));
1033 SloppifyIntegerEnd(p);
1040 StgWord w = xTaggedStackWord(BCO_INSTR_8);
1046 xPushTaggedWord(bcoConstWord(bco,BCO_INSTR_8));
1052 SSS; o = (StgClosure*)grabHpNonUpd(Wzh_sizeW); LLL;
1053 SET_HDR(o,Wzh_con_info,??);
1054 payloadWord(o,0) = xPopTaggedWord();
1056 fprintf(stderr,"\tBuilt ");
1058 printObj(stgCast(StgClosure*,o));
1061 xPushPtr(stgCast(StgPtr,o));
1064 Case(i_UNPACK_WORD):
1066 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1067 /* ASSERT(isWordLike(con)); */
1068 xPushTaggedWord(payloadWord(con,0));
1073 StgAddr a = xTaggedStackAddr(BCO_INSTR_8);
1079 xPushTaggedAddr(bcoConstAddr(bco,BCO_INSTR_8));
1082 Case(i_CONST_ADDR_big):
1084 int n = BCO_INSTR_16;
1085 xPushTaggedAddr(bcoConstAddr(bco,n));
1091 SSS; o = (StgClosure*)grabHpNonUpd(Azh_sizeW); LLL;
1092 SET_HDR(o,Azh_con_info,??);
1093 payloadPtr(o,0) = xPopTaggedAddr();
1095 fprintf(stderr,"\tBuilt ");
1097 printObj(stgCast(StgClosure*,o));
1100 xPushPtr(stgCast(StgPtr,o));
1103 Case(i_UNPACK_ADDR):
1105 StgClosure* con = (StgClosure*)xStackPtr(0);
1106 /* ASSERT(isAddrLike(con)); */
1107 xPushTaggedAddr(payloadPtr(con,0));
1112 StgChar c = xTaggedStackChar(BCO_INSTR_8);
1118 xPushTaggedChar(bcoConstChar(bco,BCO_INSTR_8));
1124 SSS; o = (StgClosure*)grabHpNonUpd(Czh_sizeW); LLL;
1125 SET_HDR(o,Czh_con_info,??);
1126 payloadWord(o,0) = xPopTaggedChar();
1127 xPushPtr(stgCast(StgPtr,o));
1129 fprintf(stderr,"\tBuilt ");
1131 printObj(stgCast(StgClosure*,o));
1136 Case(i_UNPACK_CHAR):
1138 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1139 /* ASSERT(isCharLike(con)); */
1140 xPushTaggedChar(payloadWord(con,0));
1145 StgFloat f = xTaggedStackFloat(BCO_INSTR_8);
1146 xPushTaggedFloat(f);
1149 Case(i_CONST_FLOAT):
1151 xPushTaggedFloat(bcoConstFloat(bco,BCO_INSTR_8));
1157 SSS; o = (StgClosure*)grabHpNonUpd(Fzh_sizeW); LLL;
1158 SET_HDR(o,Fzh_con_info,??);
1159 ASSIGN_FLT(&payloadWord(o,0),xPopTaggedFloat());
1161 fprintf(stderr,"\tBuilt ");
1163 printObj(stgCast(StgClosure*,o));
1166 xPushPtr(stgCast(StgPtr,o));
1169 Case(i_UNPACK_FLOAT):
1171 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1172 /* ASSERT(isFloatLike(con)); */
1173 xPushTaggedFloat(PK_FLT(&payloadWord(con,0)));
1178 StgDouble d = xTaggedStackDouble(BCO_INSTR_8);
1179 xPushTaggedDouble(d);
1182 Case(i_CONST_DOUBLE):
1184 xPushTaggedDouble(bcoConstDouble(bco,BCO_INSTR_8));
1187 Case(i_CONST_DOUBLE_big):
1189 int n = BCO_INSTR_16;
1190 xPushTaggedDouble(bcoConstDouble(bco,n));
1193 Case(i_PACK_DOUBLE):
1196 SSS; o = (StgClosure*)grabHpNonUpd(Dzh_sizeW); LLL;
1197 SET_HDR(o,Dzh_con_info,??);
1198 ASSIGN_DBL(&payloadWord(o,0),xPopTaggedDouble());
1200 fprintf(stderr,"\tBuilt ");
1201 printObj(stgCast(StgClosure*,o));
1203 xPushPtr(stgCast(StgPtr,o));
1206 Case(i_UNPACK_DOUBLE):
1208 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1209 /* ASSERT(isDoubleLike(con)); */
1210 xPushTaggedDouble(PK_DBL(&payloadWord(con,0)));
1215 StgStablePtr s = xTaggedStackStable(BCO_INSTR_8);
1216 xPushTaggedStable(s);
1219 Case(i_PACK_STABLE):
1222 SSS; o = (StgClosure*)grabHpNonUpd(Stablezh_sizeW); LLL;
1223 SET_HDR(o,StablePtr_con_info,??);
1224 payloadWord(o,0) = (W_)xPopTaggedStable();
1226 fprintf(stderr,"\tBuilt ");
1228 printObj(stgCast(StgClosure*,o));
1231 xPushPtr(stgCast(StgPtr,o));
1234 Case(i_UNPACK_STABLE):
1236 StgClosure* con = (StgClosure*)xStackPtr(0);
1237 /* ASSERT(isStableLike(con)); */
1238 xPushTaggedStable(payloadWord(con,0));
1246 SSS; p = enterBCO_primop1 ( i ); LLL;
1247 if (p) { obj = p; goto enterLoop; };
1252 int i, trc, pc_saved;
1255 trc = 12345678; /* Assume != any StgThreadReturnCode */
1260 p = enterBCO_primop2 ( i, &trc, &bco_tmp, cap,
1264 bciPtr = &(bcoInstr(bco,pc_saved));
1266 if (trc == 12345678) {
1267 /* we want to enter p */
1268 obj = p; goto enterLoop;
1270 /* trc is the the StgThreadReturnCode for
1272 RETURN((StgThreadReturnCode)trc);
1278 /* combined insns, created by peephole opt */
1281 int x = BCO_INSTR_8;
1282 int y = BCO_INSTR_8;
1283 ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
1284 /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
1291 xSetStackWord(x+y,xStackWord(x));
1301 p = xStackPtr(BCO_INSTR_8);
1303 p = xStackPtr(BCO_INSTR_8);
1310 xPushPtr(bcoConstPtr(bco,BCO_INSTR_8));
1311 xPushPtr(stgCast(StgPtr,&ret_bco_info));
1312 p = xStackPtr(BCO_INSTR_8);
1318 StgPtr retaddr = bcoConstPtr(bco,BCO_INSTR_8);
1319 StgPtr ptr = xStackPtr(BCO_INSTR_8);
1321 /* A shortcut. We're going to push the address of a
1322 return continuation, and then enter a variable, so
1323 that when the var is evaluated, we return to the
1324 continuation. The shortcut is: if the var is a
1325 constructor, don't bother to enter it. Instead,
1326 push the variable on the stack (since this is what
1327 the continuation expects) and jump directly to the
1330 if (get_itbl((StgClosure*)ptr)->type == CONSTR) {
1332 obj = (StgClosure*)retaddr;
1334 fprintf(stderr, "object to enter is a constructor -- "
1335 "jumping directly to return continuation\n" );
1340 /* This is the normal, non-short-cut route */
1342 xPushPtr(stgCast(StgPtr,&ret_bco_info));
1343 obj = (StgClosure*)ptr;
1348 Case(i_VAR_DOUBLE_big):
1349 Case(i_CONST_FLOAT_big):
1350 Case(i_VAR_FLOAT_big):
1351 Case(i_CONST_CHAR_big):
1352 Case(i_VAR_CHAR_big):
1353 Case(i_VAR_ADDR_big):
1354 Case(i_VAR_STABLE_big):
1355 Case(i_CONST_INTEGER_big):
1356 Case(i_VAR_INT_big):
1357 Case(i_VAR_WORD_big):
1358 Case(i_RETADDR_big):
1363 Case(i_TEST_INJ_CONST):
1364 Case(i_TEST_INJ_big):
1366 Case(i_PACK_INJ_CONST):
1367 Case(i_PACK_INJ_big):
1369 Case(i_PACK_ROW_big):
1371 Case(i_ALLOC_ROW_big):
1376 disInstr ( bco, PC );
1377 barf("\nUnrecognised instruction");
1381 barf("enterBCO: ran off end of loop");
1385 # undef LoopTopLabel
1391 /* ---------------------------------------------------- */
1392 /* End of the bytecode evaluator */
1393 /* ---------------------------------------------------- */
1397 StgBlockingQueue* bh;
1398 StgCAF* caf = (StgCAF*)obj;
1399 if (xSp - sizeofW(StgUpdateFrame) < xSpLim) {
1400 xPushCPtr(obj); /* code to restart with */
1401 RETURN(StackOverflow);
1403 SSS; bh = (StgBlockingQueue*)grabHpUpd(BLACKHOLE_sizeW()); LLL;
1404 SET_INFO(bh,&CAF_BLACKHOLE_info);
1405 bh->blocking_queue = EndTSOQueue;
1407 fprintf(stderr,"Created CAF_BLACKHOLE %p for CAF %p"
1408 " in evaluator\n",bh,caf));
1409 SET_INFO(caf,&CAF_ENTERED_info);
1410 caf->value = (StgClosure*)bh;
1412 SSS; newCAF_made_by_Hugs(caf); LLL;
1414 xPushUpdateFrame(bh,0);
1415 xSp -= sizeofW(StgUpdateFrame);
1421 StgCAF* caf = (StgCAF*)obj;
1422 obj = caf->value; /* it's just a fancy indirection */
1428 case SE_CAF_BLACKHOLE:
1430 /* Let the scheduler figure out what to do :-) */
1431 cap->rCurrentTSO->what_next = ThreadEnterGHC;
1433 RETURN(ThreadYielding);
1437 StgAP_UPD* ap = stgCast(StgAP_UPD*,obj);
1439 if (xSp - (i + sizeofW(StgUpdateFrame)) < xSpLim) {
1440 xPushCPtr(obj); /* code to restart with */
1441 RETURN(StackOverflow);
1443 /* ToDo: look for xSp==xSu && stackInt(0) == UPD_FRAME
1444 and insert an indirection immediately */
1445 xPushUpdateFrame(ap,0);
1446 xSp -= sizeofW(StgUpdateFrame);
1448 xPushWord(payloadWord(ap,i));
1451 #ifdef EAGER_BLACKHOLING
1452 #warn LAZY_BLACKHOLING is default for StgHugs
1453 #error Dont know if EAGER_BLACKHOLING works in StgHugs
1455 /* superfluous - but makes debugging easier */
1456 StgBlackHole* bh = stgCast(StgBlackHole*,ap);
1457 SET_INFO(bh,&BLACKHOLE_info);
1458 bh->blocking_queue = EndTSOQueue;
1460 fprintf(stderr,"Eagerly blackholed AP_UPD %p in evaluator\n",bh));
1463 #endif /* EAGER_BLACKHOLING */
1468 StgPAP* pap = stgCast(StgPAP*,obj);
1469 int i = pap->n_args; /* ToDo: stack check */
1470 /* ToDo: if PAP is in whnf, we can update any update frames
1474 xPushWord(payloadWord(pap,i));
1481 obj = stgCast(StgInd*,obj)->indirectee;
1486 obj = stgCast(StgIndOldGen*,obj)->indirectee;
1495 case CONSTR_INTLIKE:
1496 case CONSTR_CHARLIKE:
1498 case CONSTR_NOCAF_STATIC:
1500 /* rows are mutarrays and should be treated as constructors. */
1501 case MUT_ARR_PTRS_FROZEN:
1505 switch (get_itbl(stgCast(StgClosure*,xSp))->type) {
1507 SSS; PopCatchFrame(); LLL;
1510 xPopUpdateFrame(obj);
1513 SSS; PopSeqFrame(); LLL;
1517 ASSERT(xSp==(P_)xSu);
1520 fprintf(stderr, "hit a STOP_FRAME\n");
1522 fprintf(stderr,"xSp = %p\txSu = %p\n", xSp, xSu);
1523 printStack(xSp,cap->rCurrentTSO->stack
1524 + cap->rCurrentTSO->stack_size,xSu);
1527 cap->rCurrentTSO->what_next = ThreadComplete;
1528 SSS; PopStopFrame(obj); LLL;
1530 RETURN(ThreadFinished);
1540 /* was: goto enterLoop;
1541 But we know that obj must be a bco now, so jump directly.
1544 case RET_SMALL: /* return to GHC */
1548 cap->rCurrentTSO->what_next = ThreadEnterGHC;
1550 RETURN(ThreadYielding);
1552 belch("entered CONSTR with invalid continuation on stack");
1555 printObj(stgCast(StgClosure*,xSp));
1558 barf("bailing out");
1565 //fprintf(stderr, "enterCountI = %d\n", enterCountI);
1566 //fprintf(stderr, "entering unknown closure -- yielding to sched\n");
1569 cap->rCurrentTSO->what_next = ThreadEnterGHC;
1570 xPushCPtr(obj); /* code to restart with */
1571 RETURN(ThreadYielding);
1574 barf("Ran off the end of enter - yoiks");
1591 #undef xSetStackWord
1594 #undef xPushTaggedInt
1595 #undef xPopTaggedInt
1596 #undef xTaggedStackInt
1597 #undef xPushTaggedWord
1598 #undef xPopTaggedWord
1599 #undef xTaggedStackWord
1600 #undef xPushTaggedAddr
1601 #undef xTaggedStackAddr
1602 #undef xPopTaggedAddr
1603 #undef xPushTaggedStable
1604 #undef xTaggedStackStable
1605 #undef xPopTaggedStable
1606 #undef xPushTaggedChar
1607 #undef xTaggedStackChar
1608 #undef xPopTaggedChar
1609 #undef xPushTaggedFloat
1610 #undef xTaggedStackFloat
1611 #undef xPopTaggedFloat
1612 #undef xPushTaggedDouble
1613 #undef xTaggedStackDouble
1614 #undef xPopTaggedDouble
1615 #undef xPopUpdateFrame
1616 #undef xPushUpdateFrame
1619 /* --------------------------------------------------------------------------
1620 * Supporting routines for primops
1621 * ------------------------------------------------------------------------*/
1623 static inline void PushTag ( StackTag t )
1625 inline void PushPtr ( StgPtr x )
1626 { *(--stgCast(StgPtr*,gSp)) = x; }
1627 static inline void PushCPtr ( StgClosure* x )
1628 { *(--stgCast(StgClosure**,gSp)) = x; }
1629 static inline void PushInt ( StgInt x )
1630 { *(--stgCast(StgInt*,gSp)) = x; }
1631 static inline void PushWord ( StgWord x )
1632 { *(--stgCast(StgWord*,gSp)) = x; }
1635 static inline void checkTag ( StackTag t1, StackTag t2 )
1636 { ASSERT(t1 == t2);}
1637 static inline void PopTag ( StackTag t )
1638 { checkTag(t,*(gSp++)); }
1639 inline StgPtr PopPtr ( void )
1640 { return *stgCast(StgPtr*,gSp)++; }
1641 static inline StgClosure* PopCPtr ( void )
1642 { return *stgCast(StgClosure**,gSp)++; }
1643 static inline StgInt PopInt ( void )
1644 { return *stgCast(StgInt*,gSp)++; }
1645 static inline StgWord PopWord ( void )
1646 { return *stgCast(StgWord*,gSp)++; }
1648 static inline StgPtr stackPtr ( StgStackOffset i )
1649 { return *stgCast(StgPtr*, gSp+i); }
1650 static inline StgInt stackInt ( StgStackOffset i )
1651 { return *stgCast(StgInt*, gSp+i); }
1652 static inline StgWord stackWord ( StgStackOffset i )
1653 { return *stgCast(StgWord*,gSp+i); }
1655 static inline void setStackWord ( StgStackOffset i, StgWord w )
1659 static inline void setStackPtr ( StgStackOffset i, StgPtr p )
1660 { *(stgCast(StgPtr*, gSp+i)) = p; }
1663 static inline void PushTaggedRealWorld( void )
1664 { PushTag(REALWORLD_TAG); }
1665 inline void PushTaggedInt ( StgInt x )
1666 { gSp -= sizeofW(StgInt); *gSp = x; PushTag(INT_TAG); }
1667 inline void PushTaggedWord ( StgWord x )
1668 { gSp -= sizeofW(StgWord); *gSp = x; PushTag(WORD_TAG); }
1669 inline void PushTaggedAddr ( StgAddr x )
1670 { gSp -= sizeofW(StgAddr); *gSp = (W_)x; PushTag(ADDR_TAG); }
1671 inline void PushTaggedChar ( StgChar x )
1672 { gSp -= sizeofW(StgChar); *gSp = stgCast(StgWord,x); PushTag(CHAR_TAG); }
1673 inline void PushTaggedFloat ( StgFloat x )
1674 { gSp -= sizeofW(StgFloat); ASSIGN_FLT(gSp,x); PushTag(FLOAT_TAG); }
1675 inline void PushTaggedDouble ( StgDouble x )
1676 { gSp -= sizeofW(StgDouble); ASSIGN_DBL(gSp,x); PushTag(DOUBLE_TAG); }
1677 inline void PushTaggedStablePtr ( StgStablePtr x )
1678 { gSp -= sizeofW(StgStablePtr); *gSp = (W_)x; PushTag(STABLE_TAG); }
1679 static inline void PushTaggedBool ( int x )
1680 { PushTaggedInt(x); }
1684 static inline void PopTaggedRealWorld ( void )
1685 { PopTag(REALWORLD_TAG); }
1686 inline StgInt PopTaggedInt ( void )
1687 { StgInt r; PopTag(INT_TAG); r = *stgCast(StgInt*, gSp);
1688 gSp += sizeofW(StgInt); return r;}
1689 inline StgWord PopTaggedWord ( void )
1690 { StgWord r; PopTag(WORD_TAG); r = *stgCast(StgWord*, gSp);
1691 gSp += sizeofW(StgWord); return r;}
1692 inline StgAddr PopTaggedAddr ( void )
1693 { StgAddr r; PopTag(ADDR_TAG); r = *stgCast(StgAddr*, gSp);
1694 gSp += sizeofW(StgAddr); return r;}
1695 inline StgChar PopTaggedChar ( void )
1696 { StgChar r; PopTag(CHAR_TAG); r = stgCast(StgChar, *gSp);
1697 gSp += sizeofW(StgChar); return r;}
1698 inline StgFloat PopTaggedFloat ( void )
1699 { StgFloat r; PopTag(FLOAT_TAG); r = PK_FLT(gSp);
1700 gSp += sizeofW(StgFloat); return r;}
1701 inline StgDouble PopTaggedDouble ( void )
1702 { StgDouble r; PopTag(DOUBLE_TAG); r = PK_DBL(gSp);
1703 gSp += sizeofW(StgDouble); return r;}
1704 inline StgStablePtr PopTaggedStablePtr ( void )
1705 { StgStablePtr r; PopTag(STABLE_TAG); r = *stgCast(StgStablePtr*, gSp);
1706 gSp += sizeofW(StgStablePtr); return r;}
1710 static inline StgInt taggedStackInt ( StgStackOffset i )
1711 { checkTag(INT_TAG,gSp[i]); return *stgCast(StgInt*, gSp+1+i); }
1712 static inline StgWord taggedStackWord ( StgStackOffset i )
1713 { checkTag(WORD_TAG,gSp[i]); return *stgCast(StgWord*, gSp+1+i); }
1714 static inline StgAddr taggedStackAddr ( StgStackOffset i )
1715 { checkTag(ADDR_TAG,gSp[i]); return *stgCast(StgAddr*, gSp+1+i); }
1716 static inline StgChar taggedStackChar ( StgStackOffset i )
1717 { checkTag(CHAR_TAG,gSp[i]); return stgCast(StgChar, *(gSp+1+i)) ; }
1718 static inline StgFloat taggedStackFloat ( StgStackOffset i )
1719 { checkTag(FLOAT_TAG,gSp[i]); return PK_FLT(gSp+1+i); }
1720 static inline StgDouble taggedStackDouble ( StgStackOffset i )
1721 { checkTag(DOUBLE_TAG,gSp[i]); return PK_DBL(gSp+1+i); }
1722 static inline StgStablePtr taggedStackStable ( StgStackOffset i )
1723 { checkTag(STABLE_TAG,gSp[i]); return *stgCast(StgStablePtr*, gSp+1+i); }
1726 /* --------------------------------------------------------------------------
1729 * Should we allocate from a nursery or use the
1730 * doYouWantToGC/allocate interface? We'd already implemented a
1731 * nursery-style scheme when the doYouWantToGC/allocate interface
1733 * One reason to prefer the doYouWantToGC/allocate interface is to
1734 * support operations which allocate an unknown amount in the heap
1735 * (array ops, gmp ops, etc)
1736 * ------------------------------------------------------------------------*/
1738 static inline StgPtr grabHpUpd( nat size )
1740 ASSERT( size >= MIN_UPD_SIZE + sizeofW(StgHeader) );
1741 return allocate(size);
1744 static inline StgPtr grabHpNonUpd( nat size )
1746 ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
1747 return allocate(size);
1750 /* --------------------------------------------------------------------------
1751 * Manipulate "update frame" list:
1752 * o Update frames (based on stg_do_update and friends in Updates.hc)
1753 * o Error handling/catching (based on catchzh_fast and friends in Prims.hc)
1754 * o Seq frames (based on seq_frame_entry in Prims.hc)
1756 * ------------------------------------------------------------------------*/
1758 static inline void PopUpdateFrame ( StgClosure* obj )
1760 /* NB: doesn't assume that gSp == gSu */
1762 fprintf(stderr, "Updating ");
1763 printPtr(stgCast(StgPtr,gSu->updatee));
1764 fprintf(stderr, " with ");
1766 fprintf(stderr,"gSp = %p\tgSu = %p\n\n", gSp, gSu);
1768 #ifdef EAGER_BLACKHOLING
1769 #warn LAZY_BLACKHOLING is default for StgHugs
1770 #error Dont know if EAGER_BLACKHOLING works in StgHugs
1771 ASSERT(get_itbl(gSu->updatee)->type == BLACKHOLE
1772 || get_itbl(gSu->updatee)->type == SE_BLACKHOLE
1773 || get_itbl(gSu->updatee)->type == CAF_BLACKHOLE
1774 || get_itbl(gSu->updatee)->type == SE_CAF_BLACKHOLE
1776 #endif /* EAGER_BLACKHOLING */
1777 UPD_IND(gSu->updatee,obj);
1778 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgUpdateFrame);
1782 static inline void PopStopFrame ( StgClosure* obj )
1784 /* Move gSu just off the end of the stack, we're about to gSpam the
1785 * STOP_FRAME with the return value.
1787 gSu = stgCast(StgUpdateFrame*,gSp+1);
1788 *stgCast(StgClosure**,gSp) = obj;
1791 static inline void PushCatchFrame ( StgClosure* handler )
1794 /* ToDo: stack check! */
1795 gSp -= sizeofW(StgCatchFrame);
1796 fp = stgCast(StgCatchFrame*,gSp);
1797 SET_HDR(fp,(StgInfoTable*)&catch_frame_info,CCCS);
1798 fp->handler = handler;
1800 gSu = stgCast(StgUpdateFrame*,fp);
1803 static inline void PopCatchFrame ( void )
1805 /* NB: doesn't assume that gSp == gSu */
1806 /* fprintf(stderr,"Popping catch frame\n"); */
1807 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgCatchFrame);
1808 gSu = stgCast(StgCatchFrame*,gSu)->link;
1811 static inline void PushSeqFrame ( void )
1814 /* ToDo: stack check! */
1815 gSp -= sizeofW(StgSeqFrame);
1816 fp = stgCast(StgSeqFrame*,gSp);
1817 SET_HDR(fp,(StgInfoTable*)&seq_frame_info,CCCS);
1819 gSu = stgCast(StgUpdateFrame*,fp);
1822 static inline void PopSeqFrame ( void )
1824 /* NB: doesn't assume that gSp == gSu */
1825 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgSeqFrame);
1826 gSu = stgCast(StgSeqFrame*,gSu)->link;
1829 static inline StgClosure* raiseAnError ( StgClosure* exception )
1831 /* This closure represents the expression 'primRaise E' where E
1832 * is the exception raised (:: Exception).
1833 * It is used to overwrite all the
1834 * thunks which are currently under evaluation.
1836 HaskellObj primRaiseClosure
1837 = getHugs_BCO_cptr_for("primRaise");
1838 HaskellObj reraiseClosure
1839 = rts_apply ( primRaiseClosure, exception );
1842 switch (get_itbl(gSu)->type) {
1844 UPD_IND(gSu->updatee,reraiseClosure);
1845 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgUpdateFrame);
1851 case CATCH_FRAME: /* found it! */
1853 StgCatchFrame* fp = stgCast(StgCatchFrame*,gSu);
1854 StgClosure *handler = fp->handler;
1856 gSp += sizeofW(StgCatchFrame); /* Pop */
1857 PushCPtr(exception);
1861 barf("raiseError: uncaught exception: STOP_FRAME");
1863 barf("raiseError: weird activation record");
1869 static StgClosure* makeErrorCall ( const char* msg )
1871 /* Note! the msg string should be allocated in a
1872 place which will not get freed -- preferably
1873 read-only data of the program. That's because
1874 the thunk we build here may linger indefinitely.
1875 (thinks: probably not so, but anyway ...)
1878 = getHugs_BCO_cptr_for("error");
1880 = getHugs_BCO_cptr_for("hugsprimUnpackString");
1882 = rts_apply ( unpack, rts_mkAddr ( (void*)msg ) );
1884 = rts_apply ( error, thunk );
1886 (StgClosure*) thunk;
1889 #define raiseIndex(where) makeErrorCall("Array index out of range in " where)
1890 #define raiseDiv0(where) makeErrorCall("Division by zero in " where)
1892 /* --------------------------------------------------------------------------
1894 * ------------------------------------------------------------------------*/
1896 #define OP_CC_B(e) \
1898 unsigned char x = PopTaggedChar(); \
1899 unsigned char y = PopTaggedChar(); \
1900 PushTaggedBool(e); \
1905 unsigned char x = PopTaggedChar(); \
1914 #define OP_IW_I(e) \
1916 StgInt x = PopTaggedInt(); \
1917 StgWord y = PopTaggedWord(); \
1921 #define OP_II_I(e) \
1923 StgInt x = PopTaggedInt(); \
1924 StgInt y = PopTaggedInt(); \
1928 #define OP_II_B(e) \
1930 StgInt x = PopTaggedInt(); \
1931 StgInt y = PopTaggedInt(); \
1932 PushTaggedBool(e); \
1937 PushTaggedAddr(e); \
1942 StgInt x = PopTaggedInt(); \
1943 PushTaggedAddr(e); \
1948 StgInt x = PopTaggedInt(); \
1954 PushTaggedChar(e); \
1959 StgInt x = PopTaggedInt(); \
1960 PushTaggedChar(e); \
1965 PushTaggedWord(e); \
1970 StgInt x = PopTaggedInt(); \
1971 PushTaggedWord(e); \
1976 StgInt x = PopTaggedInt(); \
1977 PushTaggedStablePtr(e); \
1982 PushTaggedFloat(e); \
1987 StgInt x = PopTaggedInt(); \
1988 PushTaggedFloat(e); \
1993 PushTaggedDouble(e); \
1998 StgInt x = PopTaggedInt(); \
1999 PushTaggedDouble(e); \
2002 #define OP_WW_B(e) \
2004 StgWord x = PopTaggedWord(); \
2005 StgWord y = PopTaggedWord(); \
2006 PushTaggedBool(e); \
2009 #define OP_WW_W(e) \
2011 StgWord x = PopTaggedWord(); \
2012 StgWord y = PopTaggedWord(); \
2013 PushTaggedWord(e); \
2018 StgWord x = PopTaggedWord(); \
2024 StgStablePtr x = PopTaggedStablePtr(); \
2030 StgWord x = PopTaggedWord(); \
2031 PushTaggedWord(e); \
2034 #define OP_AA_B(e) \
2036 StgAddr x = PopTaggedAddr(); \
2037 StgAddr y = PopTaggedAddr(); \
2038 PushTaggedBool(e); \
2042 StgAddr x = PopTaggedAddr(); \
2045 #define OP_AI_C(s) \
2047 StgAddr x = PopTaggedAddr(); \
2048 int y = PopTaggedInt(); \
2051 PushTaggedChar(r); \
2053 #define OP_AI_I(s) \
2055 StgAddr x = PopTaggedAddr(); \
2056 int y = PopTaggedInt(); \
2061 #define OP_AI_A(s) \
2063 StgAddr x = PopTaggedAddr(); \
2064 int y = PopTaggedInt(); \
2067 PushTaggedAddr(s); \
2069 #define OP_AI_F(s) \
2071 StgAddr x = PopTaggedAddr(); \
2072 int y = PopTaggedInt(); \
2075 PushTaggedFloat(r); \
2077 #define OP_AI_D(s) \
2079 StgAddr x = PopTaggedAddr(); \
2080 int y = PopTaggedInt(); \
2083 PushTaggedDouble(r); \
2085 #define OP_AI_s(s) \
2087 StgAddr x = PopTaggedAddr(); \
2088 int y = PopTaggedInt(); \
2091 PushTaggedStablePtr(r); \
2093 #define OP_AIC_(s) \
2095 StgAddr x = PopTaggedAddr(); \
2096 int y = PopTaggedInt(); \
2097 StgChar z = PopTaggedChar(); \
2100 #define OP_AII_(s) \
2102 StgAddr x = PopTaggedAddr(); \
2103 int y = PopTaggedInt(); \
2104 StgInt z = PopTaggedInt(); \
2107 #define OP_AIA_(s) \
2109 StgAddr x = PopTaggedAddr(); \
2110 int y = PopTaggedInt(); \
2111 StgAddr z = PopTaggedAddr(); \
2114 #define OP_AIF_(s) \
2116 StgAddr x = PopTaggedAddr(); \
2117 int y = PopTaggedInt(); \
2118 StgFloat z = PopTaggedFloat(); \
2121 #define OP_AID_(s) \
2123 StgAddr x = PopTaggedAddr(); \
2124 int y = PopTaggedInt(); \
2125 StgDouble z = PopTaggedDouble(); \
2128 #define OP_AIs_(s) \
2130 StgAddr x = PopTaggedAddr(); \
2131 int y = PopTaggedInt(); \
2132 StgStablePtr z = PopTaggedStablePtr(); \
2137 #define OP_FF_B(e) \
2139 StgFloat x = PopTaggedFloat(); \
2140 StgFloat y = PopTaggedFloat(); \
2141 PushTaggedBool(e); \
2144 #define OP_FF_F(e) \
2146 StgFloat x = PopTaggedFloat(); \
2147 StgFloat y = PopTaggedFloat(); \
2148 PushTaggedFloat(e); \
2153 StgFloat x = PopTaggedFloat(); \
2154 PushTaggedFloat(e); \
2159 StgFloat x = PopTaggedFloat(); \
2160 PushTaggedBool(e); \
2165 StgFloat x = PopTaggedFloat(); \
2171 StgFloat x = PopTaggedFloat(); \
2172 PushTaggedDouble(e); \
2175 #define OP_DD_B(e) \
2177 StgDouble x = PopTaggedDouble(); \
2178 StgDouble y = PopTaggedDouble(); \
2179 PushTaggedBool(e); \
2182 #define OP_DD_D(e) \
2184 StgDouble x = PopTaggedDouble(); \
2185 StgDouble y = PopTaggedDouble(); \
2186 PushTaggedDouble(e); \
2191 StgDouble x = PopTaggedDouble(); \
2192 PushTaggedBool(e); \
2197 StgDouble x = PopTaggedDouble(); \
2198 PushTaggedDouble(e); \
2203 StgDouble x = PopTaggedDouble(); \
2209 StgDouble x = PopTaggedDouble(); \
2210 PushTaggedFloat(e); \
2214 StgPtr CreateByteArrayToHoldInteger ( int nbytes )
2216 StgWord words = (nbytes+sizeof(W_)-1)/sizeof(W_);
2217 StgWord size = sizeofW(StgArrWords) + words;
2218 StgArrWords* arr = (StgArrWords*)allocate(size);
2219 SET_HDR(arr,&ARR_WORDS_info,CCCS);
2221 ASSERT((W_)nbytes <= arr->words * sizeof(W_));
2224 for (i = 0; i < words; ++i) {
2225 arr->payload[i] = 0xdeadbeef;
2227 { B* b = (B*) &(arr->payload[0]);
2228 b->used = b->sign = 0;
2234 B* IntegerInsideByteArray ( StgPtr arr0 )
2237 StgArrWords* arr = (StgArrWords*)arr0;
2238 ASSERT(GET_INFO(arr) == &ARR_WORDS_info);
2239 b = (B*) &(arr->payload[0]);
2243 void SloppifyIntegerEnd ( StgPtr arr0 )
2245 StgArrWords* arr = (StgArrWords*)arr0;
2246 B* b = (B*) & (arr->payload[0]);
2247 I_ nwunused = arr->words - sizeofW(B) - (b->used+sizeof(W_)-1)/sizeof(W_);
2248 if (nwunused >= ((I_)sizeofW(StgArrWords))) {
2250 b->size -= nwunused * sizeof(W_);
2251 if (b->size < b->used) b->size = b->used;
2254 arr->words -= nwunused;
2255 slop = (StgArrWords*)&(arr->payload[arr->words]);
2256 SET_HDR(slop,&ARR_WORDS_info,CCCS);
2257 slop->words = nwunused - sizeofW(StgArrWords);
2258 ASSERT( &(slop->payload[slop->words]) ==
2259 &(arr->payload[arr->words + nwunused]) );
2263 #define OP_Z_Z(op) \
2265 B* x = IntegerInsideByteArray(PopPtr()); \
2266 int n = mycat2(size_,op)(x); \
2267 StgPtr p = CreateByteArrayToHoldInteger(n); \
2268 mycat2(do_,op)(x,n,IntegerInsideByteArray(p)); \
2269 SloppifyIntegerEnd(p); \
2272 #define OP_ZZ_Z(op) \
2274 B* x = IntegerInsideByteArray(PopPtr()); \
2275 B* y = IntegerInsideByteArray(PopPtr()); \
2276 int n = mycat2(size_,op)(x,y); \
2277 StgPtr p = CreateByteArrayToHoldInteger(n); \
2278 mycat2(do_,op)(x,y,n,IntegerInsideByteArray(p)); \
2279 SloppifyIntegerEnd(p); \
2286 #define HEADER_mI(ty,where) \
2287 StgArrWords* x = stgCast(StgArrWords*,PopPtr()); \
2288 nat i = PopTaggedInt(); \
2289 if (i * sizeof(ty) + (sizeof(ty)) > sizeof(StgWord) * x->words) { \
2290 return (raiseIndex(where)); \
2292 #define OP_mI_ty(ty,where,s) \
2294 HEADER_mI(mycat2(Stg,ty),where) \
2295 { mycat2(Stg,ty) r; \
2297 mycat2(PushTagged,ty)(r); \
2300 #define OP_mIty_(ty,where,s) \
2302 HEADER_mI(mycat2(Stg,ty),where) \
2304 mycat2(Stg,ty) z = mycat2(PopTagged,ty)(); \
2310 __attribute__ ((unused))
2311 static void myStackCheck ( Capability* cap )
2313 /* fprintf(stderr, "myStackCheck\n"); */
2314 if (!(gSpLim <= gSp && gSp <= stgCast(StgPtr,gSu))) {
2315 fprintf(stderr, "myStackCheck: invalid initial gSp/gSu \n" );
2320 if (!( (P_)gSu >= (P_)cap->rCurrentTSO->stack
2322 (P_)gSu <= (P_)(cap->rCurrentTSO->stack
2323 + cap->rCurrentTSO->stack_size))) {
2324 fprintf ( stderr, "myStackCheck: gSu out of stack\n" );
2328 switch (get_itbl(stgCast(StgClosure*,gSu))->type) {
2330 gSu = (StgUpdateFrame*) ((StgCatchFrame*)(gSu))->link;
2333 gSu = (StgUpdateFrame*) ((StgUpdateFrame*)(gSu))->link;
2336 gSu = (StgUpdateFrame*) ((StgSeqFrame*)(gSu))->link;
2341 fprintf(stderr, "myStackCheck: invalid activation record\n");
2350 /* --------------------------------------------------------------------------
2351 * Primop stuff for bytecode interpreter
2352 * ------------------------------------------------------------------------*/
2354 /* Returns & of the next thing to enter (if throwing an exception),
2355 or NULL in the normal case.
2357 static void* enterBCO_primop1 ( int primop1code )
2360 barf("enterBCO_primop1 in combined mode");
2362 switch (primop1code) {
2363 case i_pushseqframe:
2365 StgClosure* c = PopCPtr();
2370 case i_pushcatchframe:
2372 StgClosure* e = PopCPtr();
2373 StgClosure* h = PopCPtr();
2379 case i_gtChar: OP_CC_B(x>y); break;
2380 case i_geChar: OP_CC_B(x>=y); break;
2381 case i_eqChar: OP_CC_B(x==y); break;
2382 case i_neChar: OP_CC_B(x!=y); break;
2383 case i_ltChar: OP_CC_B(x<y); break;
2384 case i_leChar: OP_CC_B(x<=y); break;
2385 case i_charToInt: OP_C_I(x); break;
2386 case i_intToChar: OP_I_C(x); break;
2388 case i_gtInt: OP_II_B(x>y); break;
2389 case i_geInt: OP_II_B(x>=y); break;
2390 case i_eqInt: OP_II_B(x==y); break;
2391 case i_neInt: OP_II_B(x!=y); break;
2392 case i_ltInt: OP_II_B(x<y); break;
2393 case i_leInt: OP_II_B(x<=y); break;
2394 case i_minInt: OP__I(INT_MIN); break;
2395 case i_maxInt: OP__I(INT_MAX); break;
2396 case i_plusInt: OP_II_I(x+y); break;
2397 case i_minusInt: OP_II_I(x-y); break;
2398 case i_timesInt: OP_II_I(x*y); break;
2401 int x = PopTaggedInt();
2402 int y = PopTaggedInt();
2404 return (raiseDiv0("quotInt"));
2406 /* ToDo: protect against minInt / -1 errors
2407 * (repeat for all other division primops) */
2413 int x = PopTaggedInt();
2414 int y = PopTaggedInt();
2416 return (raiseDiv0("remInt"));
2423 StgInt x = PopTaggedInt();
2424 StgInt y = PopTaggedInt();
2426 return (raiseDiv0("quotRemInt"));
2428 PushTaggedInt(x%y); /* last result */
2429 PushTaggedInt(x/y); /* first result */
2432 case i_negateInt: OP_I_I(-x); break;
2434 case i_andInt: OP_II_I(x&y); break;
2435 case i_orInt: OP_II_I(x|y); break;
2436 case i_xorInt: OP_II_I(x^y); break;
2437 case i_notInt: OP_I_I(~x); break;
2438 case i_shiftLInt: OP_II_I(x<<y); break;
2439 case i_shiftRAInt: OP_II_I(x>>y); break; /* ToDo */
2440 case i_shiftRLInt: OP_II_I(x>>y); break; /* ToDo */
2442 case i_gtWord: OP_WW_B(x>y); break;
2443 case i_geWord: OP_WW_B(x>=y); break;
2444 case i_eqWord: OP_WW_B(x==y); break;
2445 case i_neWord: OP_WW_B(x!=y); break;
2446 case i_ltWord: OP_WW_B(x<y); break;
2447 case i_leWord: OP_WW_B(x<=y); break;
2448 case i_minWord: OP__W(0); break;
2449 case i_maxWord: OP__W(UINT_MAX); break;
2450 case i_plusWord: OP_WW_W(x+y); break;
2451 case i_minusWord: OP_WW_W(x-y); break;
2452 case i_timesWord: OP_WW_W(x*y); break;
2455 StgWord x = PopTaggedWord();
2456 StgWord y = PopTaggedWord();
2458 return (raiseDiv0("quotWord"));
2460 PushTaggedWord(x/y);
2465 StgWord x = PopTaggedWord();
2466 StgWord y = PopTaggedWord();
2468 return (raiseDiv0("remWord"));
2470 PushTaggedWord(x%y);
2475 StgWord x = PopTaggedWord();
2476 StgWord y = PopTaggedWord();
2478 return (raiseDiv0("quotRemWord"));
2480 PushTaggedWord(x%y); /* last result */
2481 PushTaggedWord(x/y); /* first result */
2484 case i_negateWord: OP_W_W(-x); break;
2485 case i_andWord: OP_WW_W(x&y); break;
2486 case i_orWord: OP_WW_W(x|y); break;
2487 case i_xorWord: OP_WW_W(x^y); break;
2488 case i_notWord: OP_W_W(~x); break;
2489 case i_shiftLWord: OP_WW_W(x<<y); break;
2490 case i_shiftRAWord: OP_WW_W(x>>y); break; /* ToDo */
2491 case i_shiftRLWord: OP_WW_W(x>>y); break; /* ToDo */
2492 case i_intToWord: OP_I_W(x); break;
2493 case i_wordToInt: OP_W_I(x); break;
2495 case i_gtAddr: OP_AA_B(x>y); break;
2496 case i_geAddr: OP_AA_B(x>=y); break;
2497 case i_eqAddr: OP_AA_B(x==y); break;
2498 case i_neAddr: OP_AA_B(x!=y); break;
2499 case i_ltAddr: OP_AA_B(x<y); break;
2500 case i_leAddr: OP_AA_B(x<=y); break;
2501 case i_intToAddr: OP_I_A((StgAddr)x); break; /* ToDo */
2502 case i_addrToInt: OP_A_I((StgInt)x); break; /* ToDo */
2504 case i_intToStable: OP_I_s((StgStablePtr)x); break;
2505 case i_stableToInt: OP_s_I((W_)x); break;
2507 case i_indexCharOffAddr: OP_AI_C(indexCharOffAddrzh(r,x,y)); break;
2508 case i_readCharOffAddr: OP_AI_C(indexCharOffAddrzh(r,x,y)); break;
2509 case i_writeCharOffAddr: OP_AIC_(writeCharOffAddrzh(x,y,z)); break;
2511 case i_indexIntOffAddr: OP_AI_I(indexIntOffAddrzh(r,x,y)); break;
2512 case i_readIntOffAddr: OP_AI_I(indexIntOffAddrzh(r,x,y)); break;
2513 case i_writeIntOffAddr: OP_AII_(writeIntOffAddrzh(x,y,z)); break;
2515 case i_indexAddrOffAddr: OP_AI_A(indexAddrOffAddrzh(r,x,y)); break;
2516 case i_readAddrOffAddr: OP_AI_A(indexAddrOffAddrzh(r,x,y)); break;
2517 case i_writeAddrOffAddr: OP_AIA_(writeAddrOffAddrzh(x,y,z)); break;
2519 case i_indexFloatOffAddr: OP_AI_F(indexFloatOffAddrzh(r,x,y)); break;
2520 case i_readFloatOffAddr: OP_AI_F(indexFloatOffAddrzh(r,x,y)); break;
2521 case i_writeFloatOffAddr: OP_AIF_(writeFloatOffAddrzh(x,y,z)); break;
2523 case i_indexDoubleOffAddr: OP_AI_D(indexDoubleOffAddrzh(r,x,y)); break;
2524 case i_readDoubleOffAddr: OP_AI_D(indexDoubleOffAddrzh(r,x,y)); break;
2525 case i_writeDoubleOffAddr: OP_AID_(writeDoubleOffAddrzh(x,y,z)); break;
2527 case i_indexStableOffAddr: OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break;
2528 case i_readStableOffAddr: OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break;
2529 case i_writeStableOffAddr: OP_AIs_(writeStablePtrOffAddrzh(x,y,z)); break;
2531 case i_compareInteger:
2533 B* x = IntegerInsideByteArray(PopPtr());
2534 B* y = IntegerInsideByteArray(PopPtr());
2535 StgInt r = do_cmp(x,y);
2536 PushTaggedInt(r<0 ? -1 : (r>0 ? 1 : 0));
2539 case i_negateInteger: OP_Z_Z(neg); break;
2540 case i_plusInteger: OP_ZZ_Z(add); break;
2541 case i_minusInteger: OP_ZZ_Z(sub); break;
2542 case i_timesInteger: OP_ZZ_Z(mul); break;
2543 case i_quotRemInteger:
2545 B* x = IntegerInsideByteArray(PopPtr());
2546 B* y = IntegerInsideByteArray(PopPtr());
2547 int n = size_qrm(x,y);
2548 StgPtr q = CreateByteArrayToHoldInteger(n);
2549 StgPtr r = CreateByteArrayToHoldInteger(n);
2550 if (do_getsign(y)==0)
2551 return (raiseDiv0("quotRemInteger"));
2552 do_qrm(x,y,n,IntegerInsideByteArray(q),
2553 IntegerInsideByteArray(r));
2554 SloppifyIntegerEnd(q);
2555 SloppifyIntegerEnd(r);
2560 case i_intToInteger:
2562 int n = size_fromInt();
2563 StgPtr p = CreateByteArrayToHoldInteger(n);
2564 do_fromInt( PopTaggedInt(), n, IntegerInsideByteArray(p));
2568 case i_wordToInteger:
2570 int n = size_fromWord();
2571 StgPtr p = CreateByteArrayToHoldInteger(n);
2572 do_fromWord( PopTaggedWord(), n, IntegerInsideByteArray(p));
2576 case i_integerToInt: PushTaggedInt(do_toInt(
2577 IntegerInsideByteArray(PopPtr())
2581 case i_integerToWord: PushTaggedWord(do_toWord(
2582 IntegerInsideByteArray(PopPtr())
2586 case i_integerToFloat: PushTaggedFloat(do_toFloat(
2587 IntegerInsideByteArray(PopPtr())
2591 case i_integerToDouble: PushTaggedDouble(do_toDouble(
2592 IntegerInsideByteArray(PopPtr())
2596 case i_gtFloat: OP_FF_B(x>y); break;
2597 case i_geFloat: OP_FF_B(x>=y); break;
2598 case i_eqFloat: OP_FF_B(x==y); break;
2599 case i_neFloat: OP_FF_B(x!=y); break;
2600 case i_ltFloat: OP_FF_B(x<y); break;
2601 case i_leFloat: OP_FF_B(x<=y); break;
2602 case i_minFloat: OP__F(FLT_MIN); break;
2603 case i_maxFloat: OP__F(FLT_MAX); break;
2604 case i_radixFloat: OP__I(FLT_RADIX); break;
2605 case i_digitsFloat: OP__I(FLT_MANT_DIG); break;
2606 case i_minExpFloat: OP__I(FLT_MIN_EXP); break;
2607 case i_maxExpFloat: OP__I(FLT_MAX_EXP); break;
2608 case i_plusFloat: OP_FF_F(x+y); break;
2609 case i_minusFloat: OP_FF_F(x-y); break;
2610 case i_timesFloat: OP_FF_F(x*y); break;
2613 StgFloat x = PopTaggedFloat();
2614 StgFloat y = PopTaggedFloat();
2615 PushTaggedFloat(x/y);
2618 case i_negateFloat: OP_F_F(-x); break;
2619 case i_floatToInt: OP_F_I(x); break;
2620 case i_intToFloat: OP_I_F(x); break;
2621 case i_expFloat: OP_F_F(exp(x)); break;
2622 case i_logFloat: OP_F_F(log(x)); break;
2623 case i_sqrtFloat: OP_F_F(sqrt(x)); break;
2624 case i_sinFloat: OP_F_F(sin(x)); break;
2625 case i_cosFloat: OP_F_F(cos(x)); break;
2626 case i_tanFloat: OP_F_F(tan(x)); break;
2627 case i_asinFloat: OP_F_F(asin(x)); break;
2628 case i_acosFloat: OP_F_F(acos(x)); break;
2629 case i_atanFloat: OP_F_F(atan(x)); break;
2630 case i_sinhFloat: OP_F_F(sinh(x)); break;
2631 case i_coshFloat: OP_F_F(cosh(x)); break;
2632 case i_tanhFloat: OP_F_F(tanh(x)); break;
2633 case i_powerFloat: OP_FF_F(pow(x,y)); break;
2635 case i_encodeFloatZ:
2637 StgPtr sig = PopPtr();
2638 StgInt exp = PopTaggedInt();
2640 B__encodeFloat(IntegerInsideByteArray(sig), exp)
2644 case i_decodeFloatZ:
2646 StgFloat f = PopTaggedFloat();
2647 StgPtr sig = CreateByteArrayToHoldInteger(size_fltmantissa());
2649 B__decodeFloat(IntegerInsideByteArray(sig), &exp, f);
2655 case i_isNaNFloat: OP_F_B(isFloatNaN(x)); break;
2656 case i_isInfiniteFloat: OP_F_B(isFloatInfinite(x)); break;
2657 case i_isNegativeZeroFloat: OP_F_B(isFloatNegativeZero(x)); break;
2658 case i_isDenormalizedFloat: OP_F_B(isFloatDenormalized(x)); break;
2659 case i_gtDouble: OP_DD_B(x>y); break;
2660 case i_geDouble: OP_DD_B(x>=y); break;
2661 case i_eqDouble: OP_DD_B(x==y); break;
2662 case i_neDouble: OP_DD_B(x!=y); break;
2663 case i_ltDouble: OP_DD_B(x<y); break;
2664 case i_leDouble: OP_DD_B(x<=y) break;
2665 case i_minDouble: OP__D(DBL_MIN); break;
2666 case i_maxDouble: OP__D(DBL_MAX); break;
2667 case i_radixDouble: OP__I(FLT_RADIX); break;
2668 case i_digitsDouble: OP__I(DBL_MANT_DIG); break;
2669 case i_minExpDouble: OP__I(DBL_MIN_EXP); break;
2670 case i_maxExpDouble: OP__I(DBL_MAX_EXP); break;
2671 case i_plusDouble: OP_DD_D(x+y); break;
2672 case i_minusDouble: OP_DD_D(x-y); break;
2673 case i_timesDouble: OP_DD_D(x*y); break;
2674 case i_divideDouble:
2676 StgDouble x = PopTaggedDouble();
2677 StgDouble y = PopTaggedDouble();
2678 PushTaggedDouble(x/y);
2681 case i_negateDouble: OP_D_D(-x); break;
2682 case i_doubleToInt: OP_D_I(x); break;
2683 case i_intToDouble: OP_I_D(x); break;
2684 case i_doubleToFloat: OP_D_F(x); break;
2685 case i_floatToDouble: OP_F_F(x); break;
2686 case i_expDouble: OP_D_D(exp(x)); break;
2687 case i_logDouble: OP_D_D(log(x)); break;
2688 case i_sqrtDouble: OP_D_D(sqrt(x)); break;
2689 case i_sinDouble: OP_D_D(sin(x)); break;
2690 case i_cosDouble: OP_D_D(cos(x)); break;
2691 case i_tanDouble: OP_D_D(tan(x)); break;
2692 case i_asinDouble: OP_D_D(asin(x)); break;
2693 case i_acosDouble: OP_D_D(acos(x)); break;
2694 case i_atanDouble: OP_D_D(atan(x)); break;
2695 case i_sinhDouble: OP_D_D(sinh(x)); break;
2696 case i_coshDouble: OP_D_D(cosh(x)); break;
2697 case i_tanhDouble: OP_D_D(tanh(x)); break;
2698 case i_powerDouble: OP_DD_D(pow(x,y)); break;
2700 case i_encodeDoubleZ:
2702 StgPtr sig = PopPtr();
2703 StgInt exp = PopTaggedInt();
2705 B__encodeDouble(IntegerInsideByteArray(sig), exp)
2709 case i_decodeDoubleZ:
2711 StgDouble d = PopTaggedDouble();
2712 StgPtr sig = CreateByteArrayToHoldInteger(size_dblmantissa());
2714 B__decodeDouble(IntegerInsideByteArray(sig), &exp, d);
2720 case i_isNaNDouble: OP_D_B(isDoubleNaN(x)); break;
2721 case i_isInfiniteDouble: OP_D_B(isDoubleInfinite(x)); break;
2722 case i_isNegativeZeroDouble: OP_D_B(isDoubleNegativeZero(x)); break;
2723 case i_isDenormalizedDouble: OP_D_B(isDoubleDenormalized(x)); break;
2724 case i_isIEEEDouble:
2726 PushTaggedBool(rtsTrue);
2730 barf("Unrecognised primop1");
2737 /* For normal cases, return NULL and leave *return2 unchanged.
2738 To return the address of the next thing to enter,
2739 return the address of it and leave *return2 unchanged.
2740 To return a StgThreadReturnCode to the scheduler,
2741 set *return2 to it and return a non-NULL value.
2742 To cause a context switch, set context_switch (its a global),
2743 and optionally set hugsBlock to your rational.
2745 static void* enterBCO_primop2 ( int primop2code,
2746 int* /*StgThreadReturnCode* */ return2,
2749 HugsBlock *hugsBlock )
2752 /* A small concession: we need to allow ccalls,
2753 even in combined mode.
2755 if (primop2code != i_ccall_ccall_IO &&
2756 primop2code != i_ccall_stdcall_IO)
2757 barf("enterBCO_primop2 in combined mode");
2760 switch (primop2code) {
2761 case i_raise: /* raise#{err} */
2763 StgClosure* err = PopCPtr();
2764 return (raiseAnError(err));
2767 /*------------------------------------------------------------------------
2768 Insert and Remove primitives on Rows
2769 ------------------------------------------------------------------------*/
2773 /* get: row, index and value */
2774 StgMutArrPtrs* row = stgCast(StgMutArrPtrs*,PopPtr());
2775 nat i = PopTaggedInt();
2776 StgClosure* x = PopCPtr();
2778 /* allocate new row */
2779 StgWord n = row->ptrs;
2780 StgMutArrPtrs* newRow
2781 = stgCast(StgMutArrPtrs*,allocate(sizeofW(StgMutArrPtrs) + n + 1));
2782 SET_HDR(newRow,&MUT_ARR_PTRS_FROZEN_info,CCCS);
2787 /* copy the fields, inserting the new value */
2788 for (j = 0; j < i; j++) {
2789 newRow->payload[j] = row->payload[j];
2791 newRow->payload[i] = x;
2792 for (j = i+1; j <= n; j++)
2794 newRow->payload[j] = row->payload[j-1];
2797 PushPtr(stgCast(StgPtr,newRow));
2804 /* get row and index */
2805 StgMutArrPtrs* row = stgCast(StgMutArrPtrs*,PopPtr());
2806 nat i = PopTaggedInt(); /* or Word?? */
2808 /* allocate new row */
2809 StgWord n = row->ptrs;
2810 StgMutArrPtrs* newRow
2811 = stgCast(StgMutArrPtrs*,allocate(sizeofW(StgMutArrPtrs) + n - 1));
2812 SET_HDR(newRow,&MUT_ARR_PTRS_FROZEN_info,CCCS);
2817 /* copy the fields, except for the removed value. */
2818 for (j = 0; j < i; j++) {
2819 newRow->payload[j] = row->payload[j];
2821 for (j = i+1; j < n; j++)
2823 newRow->payload[j-1] = row->payload[j];
2826 PushCPtr(row->payload[i]);
2827 PushPtr(stgCast(StgPtr,newRow));
2830 #endif /* XMLAMBDA */
2834 StgClosure* init = PopCPtr();
2836 = stgCast(StgMutVar*,allocate(sizeofW(StgMutVar)));
2837 SET_HDR(mv,&MUT_VAR_info,CCCS);
2839 PushPtr(stgCast(StgPtr,mv));
2844 StgMutVar* mv = stgCast(StgMutVar*,PopPtr());
2850 StgMutVar* mv = stgCast(StgMutVar*,PopPtr());
2851 StgClosure* value = PopCPtr();
2857 nat n = PopTaggedInt(); /* or Word?? */
2858 StgClosure* init = PopCPtr();
2859 StgWord size = sizeofW(StgMutArrPtrs) + n;
2862 = stgCast(StgMutArrPtrs*,allocate(size));
2863 SET_HDR(arr,&MUT_ARR_PTRS_info,CCCS);
2865 for (i = 0; i < n; ++i) {
2866 arr->payload[i] = init;
2868 PushPtr(stgCast(StgPtr,arr));
2874 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2875 nat i = PopTaggedInt(); /* or Word?? */
2876 StgWord n = arr->ptrs;
2878 return (raiseIndex("{index,read}Array"));
2880 PushCPtr(arr->payload[i]);
2885 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2886 nat i = PopTaggedInt(); /* or Word? */
2887 StgClosure* v = PopCPtr();
2888 StgWord n = arr->ptrs;
2890 return (raiseIndex("{index,read}Array"));
2892 arr->payload[i] = v;
2896 case i_sizeMutableArray:
2898 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2899 PushTaggedInt(arr->ptrs);
2902 case i_unsafeFreezeArray:
2904 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2905 SET_INFO(arr,&MUT_ARR_PTRS_FROZEN_info);
2906 PushPtr(stgCast(StgPtr,arr));
2909 case i_unsafeFreezeByteArray:
2911 /* Delightfully simple :-) */
2915 case i_sameMutableArray:
2916 case i_sameMutableByteArray:
2918 StgPtr x = PopPtr();
2919 StgPtr y = PopPtr();
2920 PushTaggedBool(x==y);
2924 case i_newByteArray:
2926 nat n = PopTaggedInt(); /* or Word?? */
2927 StgInt words = (n+sizeof(W_)-1)/sizeof(W_);
2928 StgWord size = sizeofW(StgArrWords) + words;
2929 StgArrWords* arr = stgCast(StgArrWords*,allocate(size));
2930 SET_HDR(arr,&ARR_WORDS_info,CCCS);
2934 for (i = 0; i < n; ++i) {
2935 arr->payload[i] = 0xdeadbeef;
2938 PushPtr(stgCast(StgPtr,arr));
2942 /* Most of these generate alignment warnings on Sparcs and similar architectures.
2943 * These are harmless and are caused by the cast to C* in BYTE_ARR_CTS.
2945 case i_indexCharArray:
2946 OP_mI_ty(Char,"indexCharArray", indexCharArrayzh(r,x,i)); break;
2947 case i_readCharArray:
2948 OP_mI_ty(Char,"readCharArray", readCharArrayzh(r,x,i)); break;
2949 case i_writeCharArray:
2950 OP_mIty_(Char,"writeCharArray", writeCharArrayzh(x,i,z)); break;
2952 case i_indexIntArray:
2953 OP_mI_ty(Int,"indexIntArray", indexIntArrayzh(r,x,i)); break;
2954 case i_readIntArray:
2955 OP_mI_ty(Int,"readIntArray", readIntArrayzh(r,x,i)); break;
2956 case i_writeIntArray:
2957 OP_mIty_(Int,"writeIntArray", writeIntArrayzh(x,i,z)); break;
2959 case i_indexAddrArray:
2960 OP_mI_ty(Addr,"indexAddrArray", indexAddrArrayzh(r,x,i)); break;
2961 case i_readAddrArray:
2962 OP_mI_ty(Addr,"readAddrArray", readAddrArrayzh(r,x,i)); break;
2963 case i_writeAddrArray:
2964 OP_mIty_(Addr,"writeAddrArray", writeAddrArrayzh(x,i,z)); break;
2966 case i_indexFloatArray:
2967 OP_mI_ty(Float,"indexFloatArray", indexFloatArrayzh(r,x,i)); break;
2968 case i_readFloatArray:
2969 OP_mI_ty(Float,"readFloatArray", readFloatArrayzh(r,x,i)); break;
2970 case i_writeFloatArray:
2971 OP_mIty_(Float,"writeFloatArray", writeFloatArrayzh(x,i,z)); break;
2973 case i_indexDoubleArray:
2974 OP_mI_ty(Double,"indexDoubleArray", indexDoubleArrayzh(r,x,i)); break;
2975 case i_readDoubleArray:
2976 OP_mI_ty(Double,"readDoubleArray", readDoubleArrayzh(r,x,i)); break;
2977 case i_writeDoubleArray:
2978 OP_mIty_(Double,"writeDoubleArray", writeDoubleArrayzh(x,i,z)); break;
2981 #ifdef PROVIDE_STABLE
2982 case i_indexStableArray:
2983 OP_mI_ty(StablePtr,"indexStableArray", indexStablePtrArrayzh(r,x,i)); break;
2984 case i_readStableArray:
2985 OP_mI_ty(StablePtr,"readStableArray", readStablePtrArrayzh(r,x,i)); break;
2986 case i_writeStableArray:
2987 OP_mIty_(StablePtr,"writeStableArray", writeStablePtrArrayzh(x,i,z)); break;
2993 #ifdef PROVIDE_COERCE
2994 case i_unsafeCoerce:
2996 /* Another nullop */
3000 #ifdef PROVIDE_PTREQUALITY
3001 case i_reallyUnsafePtrEquality:
3002 { /* identical to i_sameRef */
3003 StgPtr x = PopPtr();
3004 StgPtr y = PopPtr();
3005 PushTaggedBool(x==y);
3009 #ifdef PROVIDE_FOREIGN
3010 /* ForeignObj# operations */
3011 case i_mkForeignObj:
3013 StgForeignObj *result
3014 = stgCast(StgForeignObj*,allocate(sizeofW(StgForeignObj)));
3015 SET_HDR(result,&FOREIGN_info,CCCS);
3016 result -> data = PopTaggedAddr();
3017 PushPtr(stgCast(StgPtr,result));
3020 #endif /* PROVIDE_FOREIGN */
3025 = stgCast(StgWeak*,allocate(sizeofW(StgWeak)));
3026 SET_HDR(w, &WEAK_info, CCCS);
3028 w->value = PopCPtr();
3029 w->finaliser = PopCPtr();
3030 w->link = weak_ptr_list;
3032 IF_DEBUG(weak, fprintf(stderr,"New weak pointer at %p\n",w));
3033 PushPtr(stgCast(StgPtr,w));
3038 StgWeak *w = stgCast(StgWeak*,PopPtr());
3039 if (w->header.info == &WEAK_info) {
3040 PushCPtr(w->value); /* last result */
3041 PushTaggedInt(1); /* first result */
3043 PushPtr(stgCast(StgPtr,w));
3044 /* ToDo: error thunk would be better */
3049 #endif /* PROVIDE_WEAK */
3051 case i_makeStablePtr:
3053 StgPtr p = PopPtr();
3054 StgStablePtr sp = getStablePtr ( p );
3055 PushTaggedStablePtr(sp);
3058 case i_deRefStablePtr:
3061 StgStablePtr sp = PopTaggedStablePtr();
3062 p = deRefStablePtr(sp);
3066 case i_freeStablePtr:
3068 StgStablePtr sp = PopTaggedStablePtr();
3073 case i_createAdjThunkARCH:
3075 StgStablePtr stableptr = PopTaggedStablePtr();
3076 StgAddr typestr = PopTaggedAddr();
3077 StgChar callconv = PopTaggedChar();
3078 StgAddr adj_thunk = createAdjThunk(stableptr,typestr,callconv);
3079 PushTaggedAddr(adj_thunk);
3085 StgInt n = prog_argc;
3091 StgInt n = PopTaggedInt();
3092 StgAddr a = (StgAddr)prog_argv[n];
3099 StgMVar *mvar = stgCast(StgMVar*,allocate(sizeofW(StgMVar)));
3100 SET_INFO(mvar,&EMPTY_MVAR_info);
3101 mvar->head = mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
3102 mvar->value = stgCast(StgClosure*,&END_TSO_QUEUE_closure);
3103 PushPtr(stgCast(StgPtr,mvar));
3108 StgMVar *mvar = (StgMVar*)PopCPtr();
3109 if (GET_INFO(mvar) == &EMPTY_MVAR_info) {
3111 /* The MVar is empty. Attach ourselves to the TSO's
3114 if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
3115 mvar->head = cap->rCurrentTSO;
3117 mvar->tail->link = cap->rCurrentTSO;
3119 cap->rCurrentTSO->link = (StgTSO *)&END_TSO_QUEUE_closure;
3120 cap->rCurrentTSO->why_blocked = BlockedOnMVar;
3121 cap->rCurrentTSO->block_info.closure = (StgClosure *)mvar;
3122 mvar->tail = cap->rCurrentTSO;
3124 /* At this point, the top-of-stack holds the MVar,
3125 and underneath is the world token (). So the
3126 stack is in the same state as when primTakeMVar
3127 was entered (primTakeMVar is handwritten bytecode).
3128 Push obj, which is this BCO, and return to the
3129 scheduler. When the MVar is filled, the scheduler
3130 will re-enter primTakeMVar, with the args still on
3131 the top of the stack.
3133 PushCPtr((StgClosure*)(*bco));
3134 *return2 = ThreadBlocked;
3135 return (void*)(1+(char*)(NULL));
3138 PushCPtr(mvar->value);
3139 mvar->value = (StgClosure *)&END_TSO_QUEUE_closure;
3140 SET_INFO(mvar,&EMPTY_MVAR_info);
3146 StgMVar* mvar = stgCast(StgMVar*,PopPtr());
3147 StgClosure* value = PopCPtr();
3148 if (GET_INFO(mvar) == &FULL_MVAR_info) {
3149 return (makeErrorCall("putMVar {full MVar}"));
3151 /* wake up the first thread on the
3152 * queue, it will continue with the
3153 * takeMVar operation and mark the
3156 mvar->value = value;
3158 if (mvar->head != (StgTSO *)&END_TSO_QUEUE_closure) {
3159 ASSERT(mvar->head->why_blocked == BlockedOnMVar);
3160 mvar->head = unblockOne(mvar->head);
3161 if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
3162 mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
3166 /* unlocks the MVar in the SMP case */
3167 SET_INFO(mvar,&FULL_MVAR_info);
3169 /* yield for better communication performance */
3175 { /* identical to i_sameRef */
3176 StgMVar* x = (StgMVar*)PopPtr();
3177 StgMVar* y = (StgMVar*)PopPtr();
3178 PushTaggedBool(x==y);
3181 #ifdef PROVIDE_CONCURRENT
3184 StgClosure* closure;
3187 closure = PopCPtr();
3188 tso = createGenThread (RtsFlags.GcFlags.initialStkSize,closure);
3190 scheduleThread(tso);
3192 /* Later: Change to use tso as the ThreadId */
3193 PushTaggedWord(tid);
3199 StgWord n = PopTaggedWord();
3203 // Map from ThreadId to Thread Structure */
3204 for (t = all_threads; t != END_TSO_QUEUE; t = t->global_link) {
3213 while (tso->what_next == ThreadRelocated) {
3218 if (tso == cap->rCurrentTSO) { /* suicide */
3219 *return2 = ThreadFinished;
3220 return (void*)(1+(char*)(NULL));
3224 case i_raiseInThread:
3225 barf("raiseInThread");
3226 ASSERT(0); /* not (yet) supported */
3229 StgInt n = PopTaggedInt();
3231 hugsBlock->reason = BlockedOnDelay;
3232 hugsBlock->delay = n;
3237 StgInt n = PopTaggedInt();
3239 hugsBlock->reason = BlockedOnRead;
3240 hugsBlock->delay = n;
3245 StgInt n = PopTaggedInt();
3247 hugsBlock->reason = BlockedOnWrite;
3248 hugsBlock->delay = n;
3253 /* The definition of yield include an enter right after
3254 * the primYield, at which time context_switch is tested.
3261 StgWord tid = cap->rCurrentTSO->id;
3262 PushTaggedWord(tid);
3265 case i_cmpThreadIds:
3267 StgWord tid1 = PopTaggedWord();
3268 StgWord tid2 = PopTaggedWord();
3269 if (tid1 < tid2) PushTaggedInt(-1);
3270 else if (tid1 > tid2) PushTaggedInt(1);
3271 else PushTaggedInt(0);
3274 #endif /* PROVIDE_CONCURRENT */
3276 case i_ccall_ccall_Id:
3277 case i_ccall_ccall_IO:
3278 case i_ccall_stdcall_Id:
3279 case i_ccall_stdcall_IO:
3282 CFunDescriptor* descriptor;
3283 void (*funPtr)(void);
3285 descriptor = PopTaggedAddr();
3286 funPtr = PopTaggedAddr();
3287 cc = (primop2code == i_ccall_stdcall_Id ||
3288 primop2code == i_ccall_stdcall_IO)
3290 r = ccall(descriptor,funPtr,bco,cc,cap);
3293 return makeErrorCall(
3294 "unhandled type or too many args/results in ccall");
3296 barf("ccall not configured correctly for this platform");
3297 barf("unknown return code from ccall");
3300 barf("Unrecognised primop2");
3306 /* -----------------------------------------------------------------------------
3307 * ccall support code:
3308 * marshall moves args from C stack to Haskell stack
3309 * unmarshall moves args from Haskell stack to C stack
3310 * argSize calculates how much gSpace you need on the C stack
3311 * ---------------------------------------------------------------------------*/
3313 /* Pop arguments off the C stack and Push them onto the Hugs stack.
3314 * Used when preparing for C calling Haskell or in regSponse to
3315 * Haskell calling C.
3317 nat marshall(char arg_ty, void* arg)
3321 PushTaggedInt(*((int*)arg));
3322 return ARG_SIZE(INT_TAG);
3325 PushTaggedInteger(*((mpz_ptr*)arg));
3326 return ARG_SIZE(INTEGER_TAG);
3329 PushTaggedWord(*((unsigned int*)arg));
3330 return ARG_SIZE(WORD_TAG);
3332 PushTaggedChar(*((char*)arg));
3333 return ARG_SIZE(CHAR_TAG);
3335 PushTaggedFloat(*((float*)arg));
3336 return ARG_SIZE(FLOAT_TAG);
3338 PushTaggedDouble(*((double*)arg));
3339 return ARG_SIZE(DOUBLE_TAG);
3341 PushTaggedAddr(*((void**)arg));
3342 return ARG_SIZE(ADDR_TAG);
3344 PushTaggedStablePtr(*((StgStablePtr*)arg));
3345 return ARG_SIZE(STABLE_TAG);
3346 #ifdef PROVIDE_FOREIGN
3348 /* Not allowed in this direction - you have to
3349 * call makeForeignPtr explicitly
3351 barf("marshall: ForeignPtr#\n");
3356 /* Not allowed in this direction */
3357 barf("marshall: [Mutable]ByteArray#\n");
3360 barf("marshall: unrecognised arg type %d\n",arg_ty);
3365 /* Pop arguments off the Hugs stack and Push them onto the C stack.
3366 * Used when preparing for Haskell calling C or in regSponse to
3367 * C calling Haskell.
3369 nat unmarshall(char res_ty, void* res)
3373 *((int*)res) = PopTaggedInt();
3374 return ARG_SIZE(INT_TAG);
3377 *((mpz_ptr*)res) = PopTaggedInteger();
3378 return ARG_SIZE(INTEGER_TAG);
3381 *((unsigned int*)res) = PopTaggedWord();
3382 return ARG_SIZE(WORD_TAG);
3384 *((int*)res) = PopTaggedChar();
3385 return ARG_SIZE(CHAR_TAG);
3387 *((float*)res) = PopTaggedFloat();
3388 return ARG_SIZE(FLOAT_TAG);
3390 *((double*)res) = PopTaggedDouble();
3391 return ARG_SIZE(DOUBLE_TAG);
3393 *((void**)res) = PopTaggedAddr();
3394 return ARG_SIZE(ADDR_TAG);
3396 *((StgStablePtr*)res) = PopTaggedStablePtr();
3397 return ARG_SIZE(STABLE_TAG);
3398 #ifdef PROVIDE_FOREIGN
3401 StgForeignObj *result = stgCast(StgForeignObj*,PopPtr());
3402 *((void**)res) = result->data;
3403 return sizeofW(StgPtr);
3409 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
3410 *((void**)res) = stgCast(void*,&(arr->payload));
3411 return sizeofW(StgPtr);
3414 barf("unmarshall: unrecognised result type %d\n",res_ty);
3418 nat argSize( const char* ks )
3421 for( ; *ks != '\0'; ++ks) {
3424 sz += sizeof(StgWord) * ARG_SIZE(INT_TAG);
3428 sz += sizeof(StgWord) * ARG_SIZE(INTEGER_TAG);
3432 sz += sizeof(StgWord) * ARG_SIZE(WORD_TAG);
3435 sz += sizeof(StgWord) * ARG_SIZE(CHAR_TAG);
3438 sz += sizeof(StgWord) * ARG_SIZE(FLOAT_TAG);
3441 sz += sizeof(StgWord) * ARG_SIZE(DOUBLE_TAG);
3444 sz += sizeof(StgWord) * ARG_SIZE(ADDR_TAG);
3447 sz += sizeof(StgWord) * ARG_SIZE(STABLE_TAG);
3449 #ifdef PROVIDE_FOREIGN
3454 sz += sizeof(StgPtr);
3457 barf("argSize: unrecognised result type %d\n",*ks);
3465 /* -----------------------------------------------------------------------------
3466 * encode/decode Float/Double code for standalone Hugs
3467 * Code based on the HBC code (lib/fltcode.c) and more recently GHC
3468 * (ghc/rts/StgPrimFloat.c)
3469 * ---------------------------------------------------------------------------*/
3471 #if IEEE_FLOATING_POINT
3472 #define MY_DMINEXP ((DBL_MIN_EXP) - (DBL_MANT_DIG) - 1)
3473 /* DMINEXP is defined in values.h on Linux (for example) */
3474 #define DHIGHBIT 0x00100000
3475 #define DMSBIT 0x80000000
3477 #define MY_FMINEXP ((FLT_MIN_EXP) - (FLT_MANT_DIG) - 1)
3478 #define FHIGHBIT 0x00800000
3479 #define FMSBIT 0x80000000
3481 #error The following code doesnt work in a non-IEEE FP environment
3484 #ifdef WORDS_BIGENDIAN
3493 StgDouble B__encodeDouble (B* s, I_ e) /* result = s * 2^e */
3498 /* Convert a B to a double; knows a lot about internal rep! */
3499 for(r = 0.0, i = s->used-1; i >= 0; i--)
3500 r = (r * B_BASE_FLT) + s->stuff[i];
3502 /* Now raise to the exponent */
3503 if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
3506 /* handle the sign */
3507 if (s->sign < 0) r = -r;
3514 #if ! FLOATS_AS_DOUBLES
3515 StgFloat B__encodeFloat (B* s, I_ e) /* result = s * 2^e */
3520 /* Convert a B to a float; knows a lot about internal rep! */
3521 for(r = 0.0, i = s->used-1; i >= 0; i--)
3522 r = (r * B_BASE_FLT) + s->stuff[i];
3524 /* Now raise to the exponent */
3525 if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
3528 /* handle the sign */
3529 if (s->sign < 0) r = -r;
3533 #endif /* FLOATS_AS_DOUBLES */
3537 /* This only supports IEEE floating point */
3538 void B__decodeDouble (B* man, I_* exp, StgDouble dbl)
3540 /* Do some bit fiddling on IEEE */
3541 nat low, high; /* assuming 32 bit ints */
3543 union { double d; int i[2]; } u; /* assuming 32 bit ints, 64 bit double */
3545 u.d = dbl; /* grab chunks of the double */
3549 ASSERT(B_BASE == 256);
3551 /* Assume that the supplied B is the right size */
3554 if (low == 0 && (high & ~DMSBIT) == 0) {
3555 man->sign = man->used = 0;
3560 iexp = ((high >> 20) & 0x7ff) + MY_DMINEXP;
3564 if (iexp != MY_DMINEXP) /* don't add hidden bit to denorms */
3568 /* A denorm, normalize the mantissa */
3569 while (! (high & DHIGHBIT)) {
3579 man->stuff[7] = (((W_)high) >> 24) & 0xff;
3580 man->stuff[6] = (((W_)high) >> 16) & 0xff;
3581 man->stuff[5] = (((W_)high) >> 8) & 0xff;
3582 man->stuff[4] = (((W_)high) ) & 0xff;
3584 man->stuff[3] = (((W_)low) >> 24) & 0xff;
3585 man->stuff[2] = (((W_)low) >> 16) & 0xff;
3586 man->stuff[1] = (((W_)low) >> 8) & 0xff;
3587 man->stuff[0] = (((W_)low) ) & 0xff;
3589 if (sign < 0) man->sign = -1;
3591 do_renormalise(man);
3595 #if ! FLOATS_AS_DOUBLES
3596 void B__decodeFloat (B* man, I_* exp, StgFloat flt)
3598 /* Do some bit fiddling on IEEE */
3599 int high, sign; /* assuming 32 bit ints */
3600 union { float f; int i; } u; /* assuming 32 bit float and int */
3602 u.f = flt; /* grab the float */
3605 ASSERT(B_BASE == 256);
3607 /* Assume that the supplied B is the right size */
3610 if ((high & ~FMSBIT) == 0) {
3611 man->sign = man->used = 0;
3616 *exp = ((high >> 23) & 0xff) + MY_FMINEXP;
3620 if (*exp != MY_FMINEXP) /* don't add hidden bit to denorms */
3624 /* A denorm, normalize the mantissa */
3625 while (! (high & FHIGHBIT)) {
3630 man->stuff[3] = (((W_)high) >> 24) & 0xff;
3631 man->stuff[2] = (((W_)high) >> 16) & 0xff;
3632 man->stuff[1] = (((W_)high) >> 8) & 0xff;
3633 man->stuff[0] = (((W_)high) ) & 0xff;
3635 if (sign < 0) man->sign = -1;
3637 do_renormalise(man);
3640 #endif /* FLOATS_AS_DOUBLES */
3641 #endif /* INTERPRETER */