2 /* -----------------------------------------------------------------------------
5 * Copyright (c) 1994-1998.
7 * $RCSfile: Evaluator.c,v $
9 * $Date: 2000/10/09 10:28:33 $
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; \
188 /* Macros to operate directly on the pulled-out machine state.
189 These mirror some of the small procedures used in the primop code
190 below, except you have to be careful about side effects,
191 ie xPushPtr(xStackPtr(n)) won't work! It certainly isn't the
192 same as PushPtr(StackPtr(n)). Also note that (1) some of
193 the macros, in particular xPopTagged*, do not make the tag
194 sanity checks that their non-x cousins do, and (2) some of
195 the macros depend critically on the semantics of C comma
196 expressions to work properly.
198 #define xPushPtr(ppp) { xSp--; *xSp=(StgWord)(ppp); }
199 #define xPopPtr() ((StgPtr)(*xSp++))
201 #define xPushCPtr(ppp) { xSp--; *xSp=(StgWord)(ppp); }
202 #define xPopCPtr() ((StgClosure*)(*xSp++))
204 #define xPushWord(ppp) { xSp--; *xSp=(StgWord)(ppp); }
205 #define xPopWord() ((StgWord)(*xSp++))
207 #define xStackPtr(nnn) ((StgPtr)(*(xSp+(nnn))))
208 #define xStackWord(nnn) ((StgWord)(*(xSp+(nnn))))
209 #define xSetStackWord(iii,www) xSp[iii]=(StgWord)(www)
211 #define xPushTag(ttt) { xSp--; *xSp=(StgWord)(ttt); }
212 #define xPopTag(ttt) { StackTag t = (StackTag)(*xSp++); \
215 #define xPushTaggedInt(xxx) { xSp -= sizeofW(StgInt); \
216 *xSp = (xxx); xPushTag(INT_TAG); }
217 #define xTaggedStackInt(iii) ((StgInt)(*(xSp+1+(iii))))
218 #define xPopTaggedInt() ((xSp++,xSp+=sizeofW(StgInt), \
219 (StgInt)(*(xSp-sizeofW(StgInt)))))
221 #define xPushTaggedWord(xxx) { xSp -= sizeofW(StgWord); \
222 *xSp = (xxx); xPushTag(WORD_TAG); }
223 #define xTaggedStackWord(iii) ((StgWord)(*(xSp+1+(iii))))
224 #define xPopTaggedWord() ((xSp++,xSp+=sizeofW(StgWord), \
225 (StgWord)(*(xSp-sizeofW(StgWord)))))
227 #define xPushTaggedAddr(xxx) { xSp -= sizeofW(StgAddr); \
228 *xSp = (StgWord)(xxx); xPushTag(ADDR_TAG); }
229 #define xTaggedStackAddr(iii) ((StgAddr)(*(xSp+1+(iii))))
230 #define xPopTaggedAddr() ((xSp++,xSp+=sizeofW(StgAddr), \
231 (StgAddr)(*(xSp-sizeofW(StgAddr)))))
233 #define xPushTaggedStable(xxx) { xSp -= sizeofW(StgStablePtr); \
234 *xSp = (StgWord)(xxx); xPushTag(STABLE_TAG); }
235 #define xTaggedStackStable(iii) ((StgStablePtr)(*(xSp+1+(iii))))
236 #define xPopTaggedStable() ((xSp++,xSp+=sizeofW(StgStablePtr), \
237 (StgStablePtr)(*(xSp-sizeofW(StgStablePtr)))))
239 #define xPushTaggedChar(xxx) { xSp -= sizeofW(StgChar); \
240 *xSp = (StgWord)(xxx); xPushTag(CHAR_TAG); }
241 #define xTaggedStackChar(iii) ((StgChar)(*(xSp+1+(iii))))
242 #define xPopTaggedChar() ((xSp++,xSp+=sizeofW(StgChar), \
243 (StgChar)(*(xSp-sizeofW(StgChar)))))
245 #define xPushTaggedFloat(xxx) { xSp -= sizeofW(StgFloat); \
246 ASSIGN_FLT(xSp,xxx); xPushTag(FLOAT_TAG); }
247 #define xTaggedStackFloat(iii) PK_FLT(xSp+1+(iii))
248 #define xPopTaggedFloat() ((xSp++,xSp+=sizeofW(StgFloat), \
249 PK_FLT(xSp-sizeofW(StgFloat))))
251 #define xPushTaggedDouble(xxx) { xSp -= sizeofW(StgDouble); \
252 ASSIGN_DBL(xSp,xxx); xPushTag(DOUBLE_TAG); }
253 #define xTaggedStackDouble(iii) PK_DBL(xSp+1+(iii))
254 #define xPopTaggedDouble() ((xSp++,xSp+=sizeofW(StgDouble), \
255 PK_DBL(xSp-sizeofW(StgDouble))))
258 #define xPushUpdateFrame(target, xSp_offset) \
260 StgUpdateFrame *__frame; \
261 __frame = (StgUpdateFrame *)(xSp + (xSp_offset)) - 1; \
262 SET_INFO(__frame, (StgInfoTable *)&upd_frame_info); \
263 __frame->link = xSu; \
264 __frame->updatee = (StgClosure *)(target); \
268 #define xPopUpdateFrame(ooo) \
270 /* NB: doesn't assume that Sp == Su */ \
271 IF_DEBUG(evaluator, \
272 fprintf(stderr, "Updating "); \
273 printPtr(stgCast(StgPtr,xSu->updatee)); \
274 fprintf(stderr, " with "); \
276 fprintf(stderr,"xSp = %p\txSu = %p\n\n", xSp, xSu); \
278 UPD_IND(xSu->updatee,ooo); \
279 xSp = stgCast(StgStackPtr,xSu) + sizeofW(StgUpdateFrame); \
285 /* Instruction stream macros */
286 #define BCO_INSTR_8 *bciPtr++
287 #define BCO_INSTR_16 ((bciPtr += 2, (*(bciPtr-2) << 8) + *(bciPtr-1)))
288 #define PC (bciPtr - &(bcoInstr(bco,0)))
291 /* State on entry to enter():
292 * - current thread is in cap->rCurrentTSO;
293 * - allocation area is in cap->rCurrentNursery & cap->rNursery
296 StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 )
298 /* use of register here is primarily to make it clear to compilers
299 that these entities are non-aliasable.
301 register StgPtr xSp; /* local state -- stack pointer */
302 register StgUpdateFrame* xSu; /* local state -- frame pointer */
303 register StgPtr xSpLim; /* local state -- stack lim pointer */
304 register StgClosure* obj; /* object currently under evaluation */
305 char eCount; /* enter counter, for context switching */
308 HugsBlock hugsBlock = { NotBlocked, 0 };
312 StgPtr tSp; StgUpdateFrame* tSu; StgPtr tSpLim;
315 gSp = cap->rCurrentTSO->sp;
316 gSu = cap->rCurrentTSO->su;
317 gSpLim = cap->rCurrentTSO->stack + RESERVED_STACK_WORDS;
320 /* use the t values to check that Su/Sp/SpLim do not change unexpectedly */
321 tSp = gSp; tSu = gSu; tSpLim = gSpLim;
327 /* Load the local state from global state, and Party On, Dudes! */
328 /* From here onwards, we operate with the local state and
329 save/reload it as necessary.
340 ASSERT(gSpLim == tSpLim);
344 ASSERT(xSpLim <= xSp && xSp <= stgCast(StgPtr,xSu));
346 "\n---------------------------------------------------------------\n");
347 fprintf(stderr,"(%d) Entering: ",enterCountI); printObj(obj);
348 fprintf(stderr,"xSp = %p\txSu = %p\n", xSp, xSu);
349 fprintf(stderr, "\n" );
350 printStack(xSp,cap->rCurrentTSO->stack+cap->rCurrentTSO->stack_size,xSu);
351 fprintf(stderr, "\n\n");
358 ((++eCount) & 0x0F) == 0
363 if (context_switch) {
364 switch(hugsBlock.reason) {
366 xPushCPtr(obj); /* code to restart with */
367 RETURN(ThreadYielding);
369 case BlockedOnDelay: /* fall through */
370 case BlockedOnRead: /* fall through */
371 case BlockedOnWrite: {
372 ASSERT(cap->rCurrentTSO->why_blocked == NotBlocked);
373 cap->rCurrentTSO->why_blocked = BlockedOnDelay;
374 ACQUIRE_LOCK(&sched_mutex);
376 #if defined(HAVE_SETITIMER) /* || defined(mingw32_TARGET_OS) */
377 cap->rCurrentTSO->block_info.delay
378 = hugsBlock.delay + ticks_since_select;
380 cap->rCurrentTSO->block_info.target
381 = hugsBlock.delay + getourtimeofday();
383 APPEND_TO_BLOCKED_QUEUE(cap->rCurrentTSO);
385 RELEASE_LOCK(&sched_mutex);
387 xPushCPtr(obj); /* code to restart with */
388 RETURN(ThreadBlocked);
391 barf("Unknown context switch reasoning");
396 switch ( get_itbl(obj)->type ) {
398 barf("Invalid object %p",obj);
402 /* ---------------------------------------------------- */
403 /* Start of the bytecode evaluator */
404 /* ---------------------------------------------------- */
407 # define Ins(x) &&l##x
408 static void *labs[] = { INSTRLIST };
410 # define LoopTopLabel
411 # define Case(x) l##x
412 # define Continue goto *labs[BCO_INSTR_8]
413 # define Dispatch Continue;
416 # define LoopTopLabel insnloop:
417 # define Case(x) case x
418 # define Continue goto insnloop
419 # define Dispatch switch (BCO_INSTR_8) {
420 # define EndDispatch }
423 register StgWord8* bciPtr; /* instruction pointer */
424 register StgBCO* bco = (StgBCO*)obj;
427 /* Don't need to SSS ... LLL around doYouWantToGC */
428 wantToGC = doYouWantToGC();
430 xPushCPtr((StgClosure*)bco); /* code to restart with */
431 RETURN(HeapOverflow);
434 bciPtr = &(bcoInstr(bco,0));
438 ASSERT((StgWord)(PC) < bco->n_instrs);
440 fprintf(stderr,"Sp = %p\tSu = %p\tpc = %d\t", xSp, xSu, PC);
444 fprintf(stderr,"\n");
445 for (i = 8; i >= 0; i--)
446 fprintf(stderr, "%d %p\n", i, (StgPtr)(*(gSp+i)));
448 fprintf(stderr,"\n");
454 Case(i_INTERNAL_ERROR):
455 barf("INTERNAL_ERROR at %p:%d",bco,PC-1);
457 barf("PANIC at %p:%d",bco,PC-1);
461 if (xSp - n < xSpLim) {
462 xPushCPtr((StgClosure*)bco); /* code to restart with */
463 RETURN(StackOverflow);
467 Case(i_STK_CHECK_big):
469 int n = BCO_INSTR_16;
470 if (xSp - n < xSpLim) {
471 xPushCPtr((StgClosure*)bco); /* code to restart with */
472 RETURN(StackOverflow);
479 if ((StgPtr*)(xSp + n) > (StgPtr*)xSu) {
480 StgWord words = (P_)xSu - xSp;
482 /* first build a PAP */
483 ASSERT((P_)xSu >= xSp); /* was (words >= 0) but that's always true */
484 if (words == 0) { /* optimisation */
485 /* Skip building the PAP and update with an indirection. */
488 /* In the evaluator, we avoid the need to do
489 * a heap check here by including the size of
490 * the PAP in the heap check we performed
491 * when we entered the BCO.
495 SSS; pap = (StgPAP*)grabHpNonUpd(PAP_sizeW(words)); LLL;
496 SET_HDR(pap,&PAP_info,CC_pap);
499 for (i = 0; i < (I_)words; ++i) {
500 payloadWord(pap,i) = xSp[i];
503 obj = stgCast(StgClosure*,pap);
506 /* now deal with "update frame" */
507 /* as an optimisation, we process all on top of stack */
508 /* instead of just the top one */
509 ASSERT(xSp==(P_)xSu);
511 switch (get_itbl(xSu)->type) {
513 /* Hit a catch frame during an arg satisfaction check,
514 * so the thing returning (1) has not thrown an
515 * exception, and (2) is of functional type. Just
516 * zap the catch frame and carry on down the stack
517 * (looking for more arguments, basically).
519 SSS; PopCatchFrame(); LLL;
522 xPopUpdateFrame(obj);
525 barf("STOP frame during pap update");
527 cap->rCurrentTSO->what_next = ThreadComplete;
528 SSS; PopStopFrame(obj); LLL;
529 RETURN(ThreadFinished);
532 SSS; PopSeqFrame(); LLL;
533 ASSERT(xSp != (P_)xSu);
534 /* Hit a SEQ frame during an arg satisfaction check.
535 * So now return to bco_info which is under the
536 * SEQ frame. The following code is copied from a
537 * case RET_BCO further down. (The reason why we're
538 * here is that something of functional type has
539 * been seq-d on, and we're now returning to the
540 * algebraic-case-continuation which forced the
541 * evaluation in the first place.)
553 barf("Invalid update frame during argcheck");
555 } while (xSp==(P_)xSu);
563 int words = BCO_INSTR_8;
564 SSS; p = grabHpUpd(AP_sizeW(words)); LLL;
568 Case(i_ALLOC_CONSTR):
571 StgInfoTable* info = bcoConstAddr(bco,BCO_INSTR_8);
572 SSS; p = grabHpNonUpd(sizeW_fromITBL(info)); LLL;
573 SET_HDR((StgClosure*)p,info,??);
577 Case(i_ALLOC_CONSTR_big):
580 int x = BCO_INSTR_16;
581 StgInfoTable* info = bcoConstAddr(bco,x);
582 SSS; p = grabHpNonUpd(sizeW_fromITBL(info)); LLL;
583 SET_HDR((StgClosure*)p,info,??);
588 /* allocate rows, implemented on top of Arrays */
593 SSS; p = stgCast(StgMutArrPtrs*,grabHpNonUpd(sizeofW(StgMutArrPtrs) + n)); LLL;
594 SET_HDR(p,&MUT_ARR_PTRS_FROZEN_info,CCCS);
599 Case(i_ALLOC_ROW_big):
602 int n = BCO_INSTR_16;
603 SSS; p = stgCast(StgMutArrPtrs*,grabHpNonUpd(sizeofW(StgMutArrPtrs) + n)); LLL;
604 SET_HDR(p,&MUT_ARR_PTRS_FROZEN_info,CCCS);
612 int x = BCO_INSTR_8; /* ToDo: Word not Int! */
614 StgAP_UPD* o = stgCast(StgAP_UPD*,xStackPtr(x));
615 SET_HDR(o,&AP_UPD_info,??);
617 o->fun = stgCast(StgClosure*,xPopPtr());
618 for(x=0; x < y; ++x) {
619 payloadWord(o,x) = xPopWord();
622 fprintf(stderr,"\tBuilt ");
624 printObj(stgCast(StgClosure*,o));
635 o = stgCast(StgAP_UPD*,xStackPtr(x));
636 SET_HDR(o,&AP_UPD_info,??);
638 o->fun = stgCast(StgClosure*,xPopPtr());
639 for(x=0; x < y; ++x) {
640 payloadWord(o,x) = xPopWord();
643 fprintf(stderr,"\tBuilt ");
645 printObj(stgCast(StgClosure*,o));
654 StgPAP* o = stgCast(StgPAP*,xStackPtr(x));
655 SET_HDR(o,&PAP_info,??);
657 o->fun = stgCast(StgClosure*,xPopPtr());
658 for(x=0; x < y; ++x) {
659 payloadWord(o,x) = xPopWord();
662 fprintf(stderr,"\tBuilt ");
664 printObj(stgCast(StgClosure*,o));
671 int offset = BCO_INSTR_8;
672 StgClosure* o = stgCast(StgClosure*,xStackPtr(offset));
673 const StgInfoTable* info = get_itbl(o);
674 nat p = info->layout.payload.ptrs;
675 nat np = info->layout.payload.nptrs;
677 for(i=0; i < p; ++i) {
678 o->payload[i] = xPopCPtr();
680 for(i=0; i < np; ++i) {
681 payloadWord(o,p+i) = 0xdeadbeef;
684 fprintf(stderr,"\tBuilt ");
686 printObj(stgCast(StgClosure*,o));
693 int offset = BCO_INSTR_16;
694 StgClosure* o = stgCast(StgClosure*,xStackPtr(offset));
695 const StgInfoTable* info = get_itbl(o);
696 nat p = info->layout.payload.ptrs;
697 nat np = info->layout.payload.nptrs;
699 for(i=0; i < p; ++i) {
700 o->payload[i] = xPopCPtr();
702 for(i=0; i < np; ++i) {
703 payloadWord(o,p+i) = 0xdeadbeef;
706 fprintf(stderr,"\tBuilt ");
708 printObj(stgCast(StgClosure*,o));
714 /* pack values into a row. */
717 int offset = BCO_INSTR_8;
718 StgMutArrPtrs* p = stgCast(StgMutArrPtrs*,xStackPtr(offset));
724 p->payload[i] = xPopCPtr();
727 fprintf(stderr,"\tBuilt ");
729 printObj(stgCast(StgClosure*,p));
734 Case(i_PACK_ROW_big):
736 int offset = BCO_INSTR_16;
737 StgMutArrPtrs* p = stgCast(StgMutArrPtrs*,xStackPtr(offset));
743 p->payload[i] = xPopCPtr();
746 fprintf(stderr,"\tBuilt ");
748 printObj(stgCast(StgClosure*,p));
753 /* pack values into an Inj */
756 const int size = CONSTR_sizeW(sizeofW(StgPtr),sizeofW(StgInt));
757 int offset = BCO_INSTR_8;
760 SSS; o = (StgClosure*)grabHpNonUpd(size); LLL;
761 SET_HDR(o,Inj_con_info,??);
763 payloadWord(o,sizeofW(StgPtr)) = xTaggedStackInt(offset);
764 payloadPtr(o,0) = xPopPtr();
767 fprintf(stderr,"\tBuilt ");
769 printObj(stgCast(StgClosure*,o));
772 xPushPtr(stgCast(StgPtr,o));
775 Case(i_PACK_INJ_big):
777 const int size = CONSTR_sizeW(sizeofW(StgPtr),sizeofW(StgInt));
778 int offset = BCO_INSTR_16;
781 SSS; o = (StgClosure*)grabHpNonUpd(size); LLL;
782 SET_HDR(o,Inj_con_info,??);
784 payloadWord(o,sizeofW(StgPtr)) = xTaggedStackInt(offset);
785 payloadPtr(o,0) = xPopPtr();
788 fprintf(stderr,"\tBuilt ");
790 printObj(stgCast(StgClosure*,o));
793 xPushPtr(stgCast(StgPtr,o));
796 Case(i_PACK_INJ_CONST):
798 const int size = CONSTR_sizeW(sizeofW(StgPtr),sizeofW(StgInt));
799 int index = BCO_INSTR_8;
802 SSS; o = (StgClosure*)grabHpNonUpd(size); LLL;
803 SET_HDR(o,Inj_con_info,??);
805 payloadWord(o,sizeofW(StgPtr)) = index;
806 payloadPtr(o,0) = xPopPtr();
809 fprintf(stderr,"\tBuilt ");
811 printObj(stgCast(StgClosure*,o));
814 xPushPtr(stgCast(StgPtr,o));
818 #endif /* XMLAMBDA */
823 ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
824 /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
826 xSetStackWord(x+y,xStackWord(x));
836 ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
837 /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
839 xSetStackWord(x+y,xStackWord(x));
851 xPushPtr(bcoConstPtr(bco,BCO_INSTR_8));
852 xPushPtr(stgCast(StgPtr,&ret_bco_info));
857 int tag = BCO_INSTR_8;
858 StgWord offset = BCO_INSTR_16;
859 if (constrTag( (StgClosure*)xStackPtr(0) ) != tag) {
865 /* Test Inj indices. */
868 int offset = BCO_INSTR_8;
869 StgWord jump = BCO_INSTR_16;
871 int index = payloadWord( (StgClosure*)xStackPtr(0), sizeofW(StgPtr) );
872 if (index != xTaggedStackInt(offset) )
878 Case(i_TEST_INJ_big):
880 int offset = BCO_INSTR_16;
881 StgWord jump = BCO_INSTR_16;
883 int index = payloadWord( (StgClosure*)xStackPtr(0), sizeofW(StgPtr) );
884 if (index != xTaggedStackInt(offset) )
890 Case(i_TEST_INJ_CONST):
892 int value = BCO_INSTR_8;
893 StgWord jump = BCO_INSTR_16;
895 int index = payloadWord( (StgClosure*)xStackPtr(0), sizeofW(StgPtr) );
902 #endif /* XMLAMBDA */
905 StgClosure* o = stgCast(StgClosure*,xStackPtr(0));
906 const StgInfoTable* itbl = get_itbl(o);
907 int i = itbl->layout.payload.ptrs;
908 ASSERT( itbl->type == CONSTR
909 || itbl->type == CONSTR_STATIC
910 || itbl->type == CONSTR_NOCAF_STATIC
911 || itbl->type == CONSTR_1_0
912 || itbl->type == CONSTR_0_1
913 || itbl->type == CONSTR_2_0
914 || itbl->type == CONSTR_1_1
915 || itbl->type == CONSTR_0_2
918 xPushCPtr(o->payload[i]);
923 /* extract all fields of a row */
926 StgMutArrPtrs* p = stgCast(StgMutArrPtrs*,xStackPtr(0));
930 xPushCPtr(p->payload[i]);
934 /* extract the value of an INJ */
937 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
939 ASSERT(get_itbl(con) == Inj_con_info);
941 xPushPtr(payloadPtr(con,0));
947 int n = BCO_INSTR_16;
948 StgPtr p = xStackPtr(n);
954 StgPtr p = xStackPtr(BCO_INSTR_8);
960 xPushPtr(stgCast(StgPtr,bcoConstPtr(bco,BCO_INSTR_8)));
965 int n = BCO_INSTR_16;
966 xPushPtr(stgCast(StgPtr,bcoConstPtr(bco,n)));
971 SSS; PushTaggedRealWorld(); LLL;
976 StgInt i = xTaggedStackInt(BCO_INSTR_8);
982 xPushTaggedInt(bcoConstInt(bco,BCO_INSTR_8));
985 Case(i_CONST_INT_big):
987 int n = BCO_INSTR_16;
988 xPushTaggedInt(bcoConstInt(bco,n));
994 SSS; o = (StgClosure*)grabHpNonUpd(Izh_sizeW); LLL;
995 SET_HDR(o,Izh_con_info,??);
996 payloadWord(o,0) = xPopTaggedInt();
998 fprintf(stderr,"\tBuilt ");
1000 printObj(stgCast(StgClosure*,o));
1003 xPushPtr(stgCast(StgPtr,o));
1008 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1009 /* ASSERT(isIntLike(con)); */
1010 xPushTaggedInt(payloadWord(con,0));
1015 StgWord offset = BCO_INSTR_16;
1016 StgInt x = xPopTaggedInt();
1017 StgInt y = xPopTaggedInt();
1023 Case(i_CONST_INTEGER):
1027 char* s = bcoConstAddr(bco,BCO_INSTR_8);
1029 n = size_fromStr(s);
1030 p = CreateByteArrayToHoldInteger(n);
1031 do_fromStr ( s, n, IntegerInsideByteArray(p));
1032 SloppifyIntegerEnd(p);
1039 StgWord w = xTaggedStackWord(BCO_INSTR_8);
1045 xPushTaggedWord(bcoConstWord(bco,BCO_INSTR_8));
1051 SSS; o = (StgClosure*)grabHpNonUpd(Wzh_sizeW); LLL;
1052 SET_HDR(o,Wzh_con_info,??);
1053 payloadWord(o,0) = xPopTaggedWord();
1055 fprintf(stderr,"\tBuilt ");
1057 printObj(stgCast(StgClosure*,o));
1060 xPushPtr(stgCast(StgPtr,o));
1063 Case(i_UNPACK_WORD):
1065 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1066 /* ASSERT(isWordLike(con)); */
1067 xPushTaggedWord(payloadWord(con,0));
1072 StgAddr a = xTaggedStackAddr(BCO_INSTR_8);
1078 xPushTaggedAddr(bcoConstAddr(bco,BCO_INSTR_8));
1081 Case(i_CONST_ADDR_big):
1083 int n = BCO_INSTR_16;
1084 xPushTaggedAddr(bcoConstAddr(bco,n));
1090 SSS; o = (StgClosure*)grabHpNonUpd(Azh_sizeW); LLL;
1091 SET_HDR(o,Azh_con_info,??);
1092 payloadPtr(o,0) = xPopTaggedAddr();
1094 fprintf(stderr,"\tBuilt ");
1096 printObj(stgCast(StgClosure*,o));
1099 xPushPtr(stgCast(StgPtr,o));
1102 Case(i_UNPACK_ADDR):
1104 StgClosure* con = (StgClosure*)xStackPtr(0);
1105 /* ASSERT(isAddrLike(con)); */
1106 xPushTaggedAddr(payloadPtr(con,0));
1111 StgChar c = xTaggedStackChar(BCO_INSTR_8);
1117 xPushTaggedChar(bcoConstChar(bco,BCO_INSTR_8));
1123 SSS; o = (StgClosure*)grabHpNonUpd(Czh_sizeW); LLL;
1124 SET_HDR(o,Czh_con_info,??);
1125 payloadWord(o,0) = xPopTaggedChar();
1126 xPushPtr(stgCast(StgPtr,o));
1128 fprintf(stderr,"\tBuilt ");
1130 printObj(stgCast(StgClosure*,o));
1135 Case(i_UNPACK_CHAR):
1137 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1138 /* ASSERT(isCharLike(con)); */
1139 xPushTaggedChar(payloadWord(con,0));
1144 StgFloat f = xTaggedStackFloat(BCO_INSTR_8);
1145 xPushTaggedFloat(f);
1148 Case(i_CONST_FLOAT):
1150 xPushTaggedFloat(bcoConstFloat(bco,BCO_INSTR_8));
1156 SSS; o = (StgClosure*)grabHpNonUpd(Fzh_sizeW); LLL;
1157 SET_HDR(o,Fzh_con_info,??);
1158 ASSIGN_FLT(&payloadWord(o,0),xPopTaggedFloat());
1160 fprintf(stderr,"\tBuilt ");
1162 printObj(stgCast(StgClosure*,o));
1165 xPushPtr(stgCast(StgPtr,o));
1168 Case(i_UNPACK_FLOAT):
1170 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1171 /* ASSERT(isFloatLike(con)); */
1172 xPushTaggedFloat(PK_FLT(&payloadWord(con,0)));
1177 StgDouble d = xTaggedStackDouble(BCO_INSTR_8);
1178 xPushTaggedDouble(d);
1181 Case(i_CONST_DOUBLE):
1183 xPushTaggedDouble(bcoConstDouble(bco,BCO_INSTR_8));
1186 Case(i_CONST_DOUBLE_big):
1188 int n = BCO_INSTR_16;
1189 xPushTaggedDouble(bcoConstDouble(bco,n));
1192 Case(i_PACK_DOUBLE):
1195 SSS; o = (StgClosure*)grabHpNonUpd(Dzh_sizeW); LLL;
1196 SET_HDR(o,Dzh_con_info,??);
1197 ASSIGN_DBL(&payloadWord(o,0),xPopTaggedDouble());
1199 fprintf(stderr,"\tBuilt ");
1200 printObj(stgCast(StgClosure*,o));
1202 xPushPtr(stgCast(StgPtr,o));
1205 Case(i_UNPACK_DOUBLE):
1207 StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1208 /* ASSERT(isDoubleLike(con)); */
1209 xPushTaggedDouble(PK_DBL(&payloadWord(con,0)));
1214 StgStablePtr s = xTaggedStackStable(BCO_INSTR_8);
1215 xPushTaggedStable(s);
1218 Case(i_PACK_STABLE):
1221 SSS; o = (StgClosure*)grabHpNonUpd(Stablezh_sizeW); LLL;
1222 SET_HDR(o,StablePtr_con_info,??);
1223 payloadWord(o,0) = (W_)xPopTaggedStable();
1225 fprintf(stderr,"\tBuilt ");
1227 printObj(stgCast(StgClosure*,o));
1230 xPushPtr(stgCast(StgPtr,o));
1233 Case(i_UNPACK_STABLE):
1235 StgClosure* con = (StgClosure*)xStackPtr(0);
1236 /* ASSERT(isStableLike(con)); */
1237 xPushTaggedStable(payloadWord(con,0));
1245 SSS; p = enterBCO_primop1 ( i ); LLL;
1246 if (p) { obj = p; goto enterLoop; };
1251 int i, trc, pc_saved;
1254 trc = 12345678; /* Assume != any StgThreadReturnCode */
1259 p = enterBCO_primop2 ( i, &trc, &bco_tmp, cap,
1263 bciPtr = &(bcoInstr(bco,pc_saved));
1265 if (trc == 12345678) {
1266 /* we want to enter p */
1267 obj = p; goto enterLoop;
1269 /* trc is the the StgThreadReturnCode for
1271 RETURN((StgThreadReturnCode)trc);
1277 /* combined insns, created by peephole opt */
1280 int x = BCO_INSTR_8;
1281 int y = BCO_INSTR_8;
1282 ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
1283 /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
1290 xSetStackWord(x+y,xStackWord(x));
1300 p = xStackPtr(BCO_INSTR_8);
1302 p = xStackPtr(BCO_INSTR_8);
1309 xPushPtr(bcoConstPtr(bco,BCO_INSTR_8));
1310 xPushPtr(stgCast(StgPtr,&ret_bco_info));
1311 p = xStackPtr(BCO_INSTR_8);
1317 StgPtr retaddr = bcoConstPtr(bco,BCO_INSTR_8);
1318 StgPtr ptr = xStackPtr(BCO_INSTR_8);
1320 /* A shortcut. We're going to push the address of a
1321 return continuation, and then enter a variable, so
1322 that when the var is evaluated, we return to the
1323 continuation. The shortcut is: if the var is a
1324 constructor, don't bother to enter it. Instead,
1325 push the variable on the stack (since this is what
1326 the continuation expects) and jump directly to the
1329 if (get_itbl((StgClosure*)ptr)->type == CONSTR) {
1331 obj = (StgClosure*)retaddr;
1333 fprintf(stderr, "object to enter is a constructor -- "
1334 "jumping directly to return continuation\n" );
1339 /* This is the normal, non-short-cut route */
1341 xPushPtr(stgCast(StgPtr,&ret_bco_info));
1342 obj = (StgClosure*)ptr;
1347 Case(i_VAR_DOUBLE_big):
1348 Case(i_CONST_FLOAT_big):
1349 Case(i_VAR_FLOAT_big):
1350 Case(i_CONST_CHAR_big):
1351 Case(i_VAR_CHAR_big):
1352 Case(i_VAR_ADDR_big):
1353 Case(i_VAR_STABLE_big):
1354 Case(i_CONST_INTEGER_big):
1355 Case(i_VAR_INT_big):
1356 Case(i_VAR_WORD_big):
1357 Case(i_RETADDR_big):
1362 Case(i_TEST_INJ_CONST):
1363 Case(i_TEST_INJ_big):
1365 Case(i_PACK_INJ_CONST):
1366 Case(i_PACK_INJ_big):
1368 Case(i_PACK_ROW_big):
1370 Case(i_ALLOC_ROW_big):
1375 disInstr ( bco, PC );
1376 barf("\nUnrecognised instruction");
1380 barf("enterBCO: ran off end of loop");
1384 # undef LoopTopLabel
1390 /* ---------------------------------------------------- */
1391 /* End of the bytecode evaluator */
1392 /* ---------------------------------------------------- */
1396 StgBlockingQueue* bh;
1397 StgCAF* caf = (StgCAF*)obj;
1398 if (xSp - sizeofW(StgUpdateFrame) < xSpLim) {
1399 xPushCPtr(obj); /* code to restart with */
1400 RETURN(StackOverflow);
1402 SSS; bh = (StgBlockingQueue*)grabHpUpd(BLACKHOLE_sizeW()); LLL;
1403 SET_INFO(bh,&CAF_BLACKHOLE_info);
1404 bh->blocking_queue = EndTSOQueue;
1406 fprintf(stderr,"Created CAF_BLACKHOLE %p for CAF %p"
1407 " in evaluator\n",bh,caf));
1408 SET_INFO(caf,&CAF_ENTERED_info);
1409 caf->value = (StgClosure*)bh;
1411 SSS; newCAF_made_by_Hugs(caf); LLL;
1413 xPushUpdateFrame(bh,0);
1414 xSp -= sizeofW(StgUpdateFrame);
1420 StgCAF* caf = (StgCAF*)obj;
1421 obj = caf->value; /* it's just a fancy indirection */
1427 case SE_CAF_BLACKHOLE:
1429 /* Let the scheduler figure out what to do :-) */
1430 cap->rCurrentTSO->what_next = ThreadEnterGHC;
1432 RETURN(ThreadYielding);
1436 StgAP_UPD* ap = stgCast(StgAP_UPD*,obj);
1438 if (xSp - (i + sizeofW(StgUpdateFrame)) < xSpLim) {
1439 xPushCPtr(obj); /* code to restart with */
1440 RETURN(StackOverflow);
1442 /* ToDo: look for xSp==xSu && stackInt(0) == UPD_FRAME
1443 and insert an indirection immediately */
1444 xPushUpdateFrame(ap,0);
1445 xSp -= sizeofW(StgUpdateFrame);
1447 xPushWord(payloadWord(ap,i));
1450 #ifdef EAGER_BLACKHOLING
1451 #warn LAZY_BLACKHOLING is default for StgHugs
1452 #error Dont know if EAGER_BLACKHOLING works in StgHugs
1454 /* superfluous - but makes debugging easier */
1455 StgBlackHole* bh = stgCast(StgBlackHole*,ap);
1456 SET_INFO(bh,&BLACKHOLE_info);
1457 bh->blocking_queue = EndTSOQueue;
1459 fprintf(stderr,"Eagerly blackholed AP_UPD %p in evaluator\n",bh));
1462 #endif /* EAGER_BLACKHOLING */
1467 StgPAP* pap = stgCast(StgPAP*,obj);
1468 int i = pap->n_args; /* ToDo: stack check */
1469 /* ToDo: if PAP is in whnf, we can update any update frames
1473 xPushWord(payloadWord(pap,i));
1480 obj = stgCast(StgInd*,obj)->indirectee;
1485 obj = stgCast(StgIndOldGen*,obj)->indirectee;
1494 case CONSTR_INTLIKE:
1495 case CONSTR_CHARLIKE:
1497 case CONSTR_NOCAF_STATIC:
1499 /* rows are mutarrays and should be treated as constructors. */
1500 case MUT_ARR_PTRS_FROZEN:
1504 switch (get_itbl(stgCast(StgClosure*,xSp))->type) {
1506 SSS; PopCatchFrame(); LLL;
1509 xPopUpdateFrame(obj);
1512 SSS; PopSeqFrame(); LLL;
1516 ASSERT(xSp==(P_)xSu);
1519 fprintf(stderr, "hit a STOP_FRAME\n");
1521 fprintf(stderr,"xSp = %p\txSu = %p\n", xSp, xSu);
1522 printStack(xSp,cap->rCurrentTSO->stack
1523 + cap->rCurrentTSO->stack_size,xSu);
1526 cap->rCurrentTSO->what_next = ThreadComplete;
1527 SSS; PopStopFrame(obj); LLL;
1529 RETURN(ThreadFinished);
1539 /* was: goto enterLoop;
1540 But we know that obj must be a bco now, so jump directly.
1543 case RET_SMALL: /* return to GHC */
1547 cap->rCurrentTSO->what_next = ThreadEnterGHC;
1549 RETURN(ThreadYielding);
1551 belch("entered CONSTR with invalid continuation on stack");
1554 printObj(stgCast(StgClosure*,xSp));
1557 barf("bailing out");
1564 //fprintf(stderr, "enterCountI = %d\n", enterCountI);
1565 //fprintf(stderr, "entering unknown closure -- yielding to sched\n");
1568 cap->rCurrentTSO->what_next = ThreadEnterGHC;
1569 xPushCPtr(obj); /* code to restart with */
1570 RETURN(ThreadYielding);
1573 barf("Ran off the end of enter - yoiks");
1590 #undef xSetStackWord
1593 #undef xPushTaggedInt
1594 #undef xPopTaggedInt
1595 #undef xTaggedStackInt
1596 #undef xPushTaggedWord
1597 #undef xPopTaggedWord
1598 #undef xTaggedStackWord
1599 #undef xPushTaggedAddr
1600 #undef xTaggedStackAddr
1601 #undef xPopTaggedAddr
1602 #undef xPushTaggedStable
1603 #undef xTaggedStackStable
1604 #undef xPopTaggedStable
1605 #undef xPushTaggedChar
1606 #undef xTaggedStackChar
1607 #undef xPopTaggedChar
1608 #undef xPushTaggedFloat
1609 #undef xTaggedStackFloat
1610 #undef xPopTaggedFloat
1611 #undef xPushTaggedDouble
1612 #undef xTaggedStackDouble
1613 #undef xPopTaggedDouble
1614 #undef xPopUpdateFrame
1615 #undef xPushUpdateFrame
1618 /* --------------------------------------------------------------------------
1619 * Supporting routines for primops
1620 * ------------------------------------------------------------------------*/
1622 static inline void PushTag ( StackTag t )
1624 inline void PushPtr ( StgPtr x )
1625 { *(--stgCast(StgPtr*,gSp)) = x; }
1626 static inline void PushCPtr ( StgClosure* x )
1627 { *(--stgCast(StgClosure**,gSp)) = x; }
1628 static inline void PushInt ( StgInt x )
1629 { *(--stgCast(StgInt*,gSp)) = x; }
1630 static inline void PushWord ( StgWord x )
1631 { *(--stgCast(StgWord*,gSp)) = x; }
1634 static inline void checkTag ( StackTag t1, StackTag t2 )
1635 { ASSERT(t1 == t2);}
1636 static inline void PopTag ( StackTag t )
1637 { checkTag(t,*(gSp++)); }
1638 inline StgPtr PopPtr ( void )
1639 { return *stgCast(StgPtr*,gSp)++; }
1640 static inline StgClosure* PopCPtr ( void )
1641 { return *stgCast(StgClosure**,gSp)++; }
1642 static inline StgInt PopInt ( void )
1643 { return *stgCast(StgInt*,gSp)++; }
1644 static inline StgWord PopWord ( void )
1645 { return *stgCast(StgWord*,gSp)++; }
1647 static inline StgPtr stackPtr ( StgStackOffset i )
1648 { return *stgCast(StgPtr*, gSp+i); }
1649 static inline StgInt stackInt ( StgStackOffset i )
1650 { return *stgCast(StgInt*, gSp+i); }
1651 static inline StgWord stackWord ( StgStackOffset i )
1652 { return *stgCast(StgWord*,gSp+i); }
1654 static inline void setStackWord ( StgStackOffset i, StgWord w )
1658 static inline void setStackPtr ( StgStackOffset i, StgPtr p )
1659 { *(stgCast(StgPtr*, gSp+i)) = p; }
1662 static inline void PushTaggedRealWorld( void )
1663 { PushTag(REALWORLD_TAG); }
1664 inline void PushTaggedInt ( StgInt x )
1665 { gSp -= sizeofW(StgInt); *gSp = x; PushTag(INT_TAG); }
1666 inline void PushTaggedWord ( StgWord x )
1667 { gSp -= sizeofW(StgWord); *gSp = x; PushTag(WORD_TAG); }
1668 inline void PushTaggedAddr ( StgAddr x )
1669 { gSp -= sizeofW(StgAddr); *gSp = (W_)x; PushTag(ADDR_TAG); }
1670 inline void PushTaggedChar ( StgChar x )
1671 { gSp -= sizeofW(StgChar); *gSp = stgCast(StgWord,x); PushTag(CHAR_TAG); }
1672 inline void PushTaggedFloat ( StgFloat x )
1673 { gSp -= sizeofW(StgFloat); ASSIGN_FLT(gSp,x); PushTag(FLOAT_TAG); }
1674 inline void PushTaggedDouble ( StgDouble x )
1675 { gSp -= sizeofW(StgDouble); ASSIGN_DBL(gSp,x); PushTag(DOUBLE_TAG); }
1676 inline void PushTaggedStablePtr ( StgStablePtr x )
1677 { gSp -= sizeofW(StgStablePtr); *gSp = (W_)x; PushTag(STABLE_TAG); }
1678 static inline void PushTaggedBool ( int x )
1679 { PushTaggedInt(x); }
1683 static inline void PopTaggedRealWorld ( void )
1684 { PopTag(REALWORLD_TAG); }
1685 inline StgInt PopTaggedInt ( void )
1686 { StgInt r; PopTag(INT_TAG); r = *stgCast(StgInt*, gSp);
1687 gSp += sizeofW(StgInt); return r;}
1688 inline StgWord PopTaggedWord ( void )
1689 { StgWord r; PopTag(WORD_TAG); r = *stgCast(StgWord*, gSp);
1690 gSp += sizeofW(StgWord); return r;}
1691 inline StgAddr PopTaggedAddr ( void )
1692 { StgAddr r; PopTag(ADDR_TAG); r = *stgCast(StgAddr*, gSp);
1693 gSp += sizeofW(StgAddr); return r;}
1694 inline StgChar PopTaggedChar ( void )
1695 { StgChar r; PopTag(CHAR_TAG); r = stgCast(StgChar, *gSp);
1696 gSp += sizeofW(StgChar); return r;}
1697 inline StgFloat PopTaggedFloat ( void )
1698 { StgFloat r; PopTag(FLOAT_TAG); r = PK_FLT(gSp);
1699 gSp += sizeofW(StgFloat); return r;}
1700 inline StgDouble PopTaggedDouble ( void )
1701 { StgDouble r; PopTag(DOUBLE_TAG); r = PK_DBL(gSp);
1702 gSp += sizeofW(StgDouble); return r;}
1703 inline StgStablePtr PopTaggedStablePtr ( void )
1704 { StgStablePtr r; PopTag(STABLE_TAG); r = *stgCast(StgStablePtr*, gSp);
1705 gSp += sizeofW(StgStablePtr); return r;}
1709 static inline StgInt taggedStackInt ( StgStackOffset i )
1710 { checkTag(INT_TAG,gSp[i]); return *stgCast(StgInt*, gSp+1+i); }
1711 static inline StgWord taggedStackWord ( StgStackOffset i )
1712 { checkTag(WORD_TAG,gSp[i]); return *stgCast(StgWord*, gSp+1+i); }
1713 static inline StgAddr taggedStackAddr ( StgStackOffset i )
1714 { checkTag(ADDR_TAG,gSp[i]); return *stgCast(StgAddr*, gSp+1+i); }
1715 static inline StgChar taggedStackChar ( StgStackOffset i )
1716 { checkTag(CHAR_TAG,gSp[i]); return stgCast(StgChar, *(gSp+1+i)) ; }
1717 static inline StgFloat taggedStackFloat ( StgStackOffset i )
1718 { checkTag(FLOAT_TAG,gSp[i]); return PK_FLT(gSp+1+i); }
1719 static inline StgDouble taggedStackDouble ( StgStackOffset i )
1720 { checkTag(DOUBLE_TAG,gSp[i]); return PK_DBL(gSp+1+i); }
1721 static inline StgStablePtr taggedStackStable ( StgStackOffset i )
1722 { checkTag(STABLE_TAG,gSp[i]); return *stgCast(StgStablePtr*, gSp+1+i); }
1725 /* --------------------------------------------------------------------------
1728 * Should we allocate from a nursery or use the
1729 * doYouWantToGC/allocate interface? We'd already implemented a
1730 * nursery-style scheme when the doYouWantToGC/allocate interface
1732 * One reason to prefer the doYouWantToGC/allocate interface is to
1733 * support operations which allocate an unknown amount in the heap
1734 * (array ops, gmp ops, etc)
1735 * ------------------------------------------------------------------------*/
1737 static inline StgPtr grabHpUpd( nat size )
1739 ASSERT( size >= MIN_UPD_SIZE + sizeofW(StgHeader) );
1740 return allocate(size);
1743 static inline StgPtr grabHpNonUpd( nat size )
1745 ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
1746 return allocate(size);
1749 /* --------------------------------------------------------------------------
1750 * Manipulate "update frame" list:
1751 * o Update frames (based on stg_do_update and friends in Updates.hc)
1752 * o Error handling/catching (based on catchzh_fast and friends in Prims.hc)
1753 * o Seq frames (based on seq_frame_entry in Prims.hc)
1755 * ------------------------------------------------------------------------*/
1757 static inline void PopUpdateFrame ( StgClosure* obj )
1759 /* NB: doesn't assume that gSp == gSu */
1761 fprintf(stderr, "Updating ");
1762 printPtr(stgCast(StgPtr,gSu->updatee));
1763 fprintf(stderr, " with ");
1765 fprintf(stderr,"gSp = %p\tgSu = %p\n\n", gSp, gSu);
1767 #ifdef EAGER_BLACKHOLING
1768 #warn LAZY_BLACKHOLING is default for StgHugs
1769 #error Dont know if EAGER_BLACKHOLING works in StgHugs
1770 ASSERT(get_itbl(gSu->updatee)->type == BLACKHOLE
1771 || get_itbl(gSu->updatee)->type == SE_BLACKHOLE
1772 || get_itbl(gSu->updatee)->type == CAF_BLACKHOLE
1773 || get_itbl(gSu->updatee)->type == SE_CAF_BLACKHOLE
1775 #endif /* EAGER_BLACKHOLING */
1776 UPD_IND(gSu->updatee,obj);
1777 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgUpdateFrame);
1781 static inline void PopStopFrame ( StgClosure* obj )
1783 /* Move gSu just off the end of the stack, we're about to gSpam the
1784 * STOP_FRAME with the return value.
1786 gSu = stgCast(StgUpdateFrame*,gSp+1);
1787 *stgCast(StgClosure**,gSp) = obj;
1790 static inline void PushCatchFrame ( StgClosure* handler )
1793 /* ToDo: stack check! */
1794 gSp -= sizeofW(StgCatchFrame);
1795 fp = stgCast(StgCatchFrame*,gSp);
1796 SET_HDR(fp,(StgInfoTable*)&catch_frame_info,CCCS);
1797 fp->handler = handler;
1799 gSu = stgCast(StgUpdateFrame*,fp);
1802 static inline void PopCatchFrame ( void )
1804 /* NB: doesn't assume that gSp == gSu */
1805 /* fprintf(stderr,"Popping catch frame\n"); */
1806 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgCatchFrame);
1807 gSu = stgCast(StgCatchFrame*,gSu)->link;
1810 static inline void PushSeqFrame ( void )
1813 /* ToDo: stack check! */
1814 gSp -= sizeofW(StgSeqFrame);
1815 fp = stgCast(StgSeqFrame*,gSp);
1816 SET_HDR(fp,(StgInfoTable*)&seq_frame_info,CCCS);
1818 gSu = stgCast(StgUpdateFrame*,fp);
1821 static inline void PopSeqFrame ( void )
1823 /* NB: doesn't assume that gSp == gSu */
1824 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgSeqFrame);
1825 gSu = stgCast(StgSeqFrame*,gSu)->link;
1828 static inline StgClosure* raiseAnError ( StgClosure* exception )
1830 /* This closure represents the expression 'primRaise E' where E
1831 * is the exception raised (:: Exception).
1832 * It is used to overwrite all the
1833 * thunks which are currently under evaluation.
1835 HaskellObj primRaiseClosure
1836 = getHugs_BCO_cptr_for("primRaise");
1837 HaskellObj reraiseClosure
1838 = rts_apply ( primRaiseClosure, exception );
1841 switch (get_itbl(gSu)->type) {
1843 UPD_IND(gSu->updatee,reraiseClosure);
1844 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgUpdateFrame);
1850 case CATCH_FRAME: /* found it! */
1852 StgCatchFrame* fp = stgCast(StgCatchFrame*,gSu);
1853 StgClosure *handler = fp->handler;
1855 gSp += sizeofW(StgCatchFrame); /* Pop */
1856 PushCPtr(exception);
1860 barf("raiseError: uncaught exception: STOP_FRAME");
1862 barf("raiseError: weird activation record");
1868 static StgClosure* makeErrorCall ( const char* msg )
1870 /* Note! the msg string should be allocated in a
1871 place which will not get freed -- preferably
1872 read-only data of the program. That's because
1873 the thunk we build here may linger indefinitely.
1874 (thinks: probably not so, but anyway ...)
1877 = getHugs_BCO_cptr_for("error");
1879 = getHugs_BCO_cptr_for("hugsprimUnpackString");
1881 = rts_apply ( unpack, rts_mkAddr ( (void*)msg ) );
1883 = rts_apply ( error, thunk );
1885 (StgClosure*) thunk;
1888 #define raiseIndex(where) makeErrorCall("Array index out of range in " where)
1889 #define raiseDiv0(where) makeErrorCall("Division by zero in " where)
1891 /* --------------------------------------------------------------------------
1893 * ------------------------------------------------------------------------*/
1895 #define OP_CC_B(e) \
1897 unsigned char x = PopTaggedChar(); \
1898 unsigned char y = PopTaggedChar(); \
1899 PushTaggedBool(e); \
1904 unsigned char x = PopTaggedChar(); \
1913 #define OP_IW_I(e) \
1915 StgInt x = PopTaggedInt(); \
1916 StgWord y = PopTaggedWord(); \
1920 #define OP_II_I(e) \
1922 StgInt x = PopTaggedInt(); \
1923 StgInt y = PopTaggedInt(); \
1927 #define OP_II_B(e) \
1929 StgInt x = PopTaggedInt(); \
1930 StgInt y = PopTaggedInt(); \
1931 PushTaggedBool(e); \
1936 PushTaggedAddr(e); \
1941 StgInt x = PopTaggedInt(); \
1942 PushTaggedAddr(e); \
1947 StgInt x = PopTaggedInt(); \
1953 PushTaggedChar(e); \
1958 StgInt x = PopTaggedInt(); \
1959 PushTaggedChar(e); \
1964 PushTaggedWord(e); \
1969 StgInt x = PopTaggedInt(); \
1970 PushTaggedWord(e); \
1975 StgInt x = PopTaggedInt(); \
1976 PushTaggedStablePtr(e); \
1981 PushTaggedFloat(e); \
1986 StgInt x = PopTaggedInt(); \
1987 PushTaggedFloat(e); \
1992 PushTaggedDouble(e); \
1997 StgInt x = PopTaggedInt(); \
1998 PushTaggedDouble(e); \
2001 #define OP_WW_B(e) \
2003 StgWord x = PopTaggedWord(); \
2004 StgWord y = PopTaggedWord(); \
2005 PushTaggedBool(e); \
2008 #define OP_WW_W(e) \
2010 StgWord x = PopTaggedWord(); \
2011 StgWord y = PopTaggedWord(); \
2012 PushTaggedWord(e); \
2017 StgWord x = PopTaggedWord(); \
2023 StgStablePtr x = PopTaggedStablePtr(); \
2029 StgWord x = PopTaggedWord(); \
2030 PushTaggedWord(e); \
2033 #define OP_AA_B(e) \
2035 StgAddr x = PopTaggedAddr(); \
2036 StgAddr y = PopTaggedAddr(); \
2037 PushTaggedBool(e); \
2041 StgAddr x = PopTaggedAddr(); \
2044 #define OP_AI_C(s) \
2046 StgAddr x = PopTaggedAddr(); \
2047 int y = PopTaggedInt(); \
2050 PushTaggedChar(r); \
2052 #define OP_AI_I(s) \
2054 StgAddr x = PopTaggedAddr(); \
2055 int y = PopTaggedInt(); \
2060 #define OP_AI_A(s) \
2062 StgAddr x = PopTaggedAddr(); \
2063 int y = PopTaggedInt(); \
2066 PushTaggedAddr(s); \
2068 #define OP_AI_F(s) \
2070 StgAddr x = PopTaggedAddr(); \
2071 int y = PopTaggedInt(); \
2074 PushTaggedFloat(r); \
2076 #define OP_AI_D(s) \
2078 StgAddr x = PopTaggedAddr(); \
2079 int y = PopTaggedInt(); \
2082 PushTaggedDouble(r); \
2084 #define OP_AI_s(s) \
2086 StgAddr x = PopTaggedAddr(); \
2087 int y = PopTaggedInt(); \
2090 PushTaggedStablePtr(r); \
2092 #define OP_AIC_(s) \
2094 StgAddr x = PopTaggedAddr(); \
2095 int y = PopTaggedInt(); \
2096 StgChar z = PopTaggedChar(); \
2099 #define OP_AII_(s) \
2101 StgAddr x = PopTaggedAddr(); \
2102 int y = PopTaggedInt(); \
2103 StgInt z = PopTaggedInt(); \
2106 #define OP_AIA_(s) \
2108 StgAddr x = PopTaggedAddr(); \
2109 int y = PopTaggedInt(); \
2110 StgAddr z = PopTaggedAddr(); \
2113 #define OP_AIF_(s) \
2115 StgAddr x = PopTaggedAddr(); \
2116 int y = PopTaggedInt(); \
2117 StgFloat z = PopTaggedFloat(); \
2120 #define OP_AID_(s) \
2122 StgAddr x = PopTaggedAddr(); \
2123 int y = PopTaggedInt(); \
2124 StgDouble z = PopTaggedDouble(); \
2127 #define OP_AIs_(s) \
2129 StgAddr x = PopTaggedAddr(); \
2130 int y = PopTaggedInt(); \
2131 StgStablePtr z = PopTaggedStablePtr(); \
2136 #define OP_FF_B(e) \
2138 StgFloat x = PopTaggedFloat(); \
2139 StgFloat y = PopTaggedFloat(); \
2140 PushTaggedBool(e); \
2143 #define OP_FF_F(e) \
2145 StgFloat x = PopTaggedFloat(); \
2146 StgFloat y = PopTaggedFloat(); \
2147 PushTaggedFloat(e); \
2152 StgFloat x = PopTaggedFloat(); \
2153 PushTaggedFloat(e); \
2158 StgFloat x = PopTaggedFloat(); \
2159 PushTaggedBool(e); \
2164 StgFloat x = PopTaggedFloat(); \
2170 StgFloat x = PopTaggedFloat(); \
2171 PushTaggedDouble(e); \
2174 #define OP_DD_B(e) \
2176 StgDouble x = PopTaggedDouble(); \
2177 StgDouble y = PopTaggedDouble(); \
2178 PushTaggedBool(e); \
2181 #define OP_DD_D(e) \
2183 StgDouble x = PopTaggedDouble(); \
2184 StgDouble y = PopTaggedDouble(); \
2185 PushTaggedDouble(e); \
2190 StgDouble x = PopTaggedDouble(); \
2191 PushTaggedBool(e); \
2196 StgDouble x = PopTaggedDouble(); \
2197 PushTaggedDouble(e); \
2202 StgDouble x = PopTaggedDouble(); \
2208 StgDouble x = PopTaggedDouble(); \
2209 PushTaggedFloat(e); \
2213 StgPtr CreateByteArrayToHoldInteger ( int nbytes )
2215 StgWord words = (nbytes+sizeof(W_)-1)/sizeof(W_);
2216 StgWord size = sizeofW(StgArrWords) + words;
2217 StgArrWords* arr = (StgArrWords*)allocate(size);
2218 SET_HDR(arr,&ARR_WORDS_info,CCCS);
2220 ASSERT((W_)nbytes <= arr->words * sizeof(W_));
2223 for (i = 0; i < words; ++i) {
2224 arr->payload[i] = 0xdeadbeef;
2226 { B* b = (B*) &(arr->payload[0]);
2227 b->used = b->sign = 0;
2233 B* IntegerInsideByteArray ( StgPtr arr0 )
2236 StgArrWords* arr = (StgArrWords*)arr0;
2237 ASSERT(GET_INFO(arr) == &ARR_WORDS_info);
2238 b = (B*) &(arr->payload[0]);
2242 void SloppifyIntegerEnd ( StgPtr arr0 )
2244 StgArrWords* arr = (StgArrWords*)arr0;
2245 B* b = (B*) & (arr->payload[0]);
2246 I_ nwunused = arr->words - sizeofW(B) - (b->used+sizeof(W_)-1)/sizeof(W_);
2247 if (nwunused >= ((I_)sizeofW(StgArrWords))) {
2249 b->size -= nwunused * sizeof(W_);
2250 if (b->size < b->used) b->size = b->used;
2253 arr->words -= nwunused;
2254 slop = (StgArrWords*)&(arr->payload[arr->words]);
2255 SET_HDR(slop,&ARR_WORDS_info,CCCS);
2256 slop->words = nwunused - sizeofW(StgArrWords);
2257 ASSERT( &(slop->payload[slop->words]) ==
2258 &(arr->payload[arr->words + nwunused]) );
2262 #define OP_Z_Z(op) \
2264 B* x = IntegerInsideByteArray(PopPtr()); \
2265 int n = mycat2(size_,op)(x); \
2266 StgPtr p = CreateByteArrayToHoldInteger(n); \
2267 mycat2(do_,op)(x,n,IntegerInsideByteArray(p)); \
2268 SloppifyIntegerEnd(p); \
2271 #define OP_ZZ_Z(op) \
2273 B* x = IntegerInsideByteArray(PopPtr()); \
2274 B* y = IntegerInsideByteArray(PopPtr()); \
2275 int n = mycat2(size_,op)(x,y); \
2276 StgPtr p = CreateByteArrayToHoldInteger(n); \
2277 mycat2(do_,op)(x,y,n,IntegerInsideByteArray(p)); \
2278 SloppifyIntegerEnd(p); \
2285 #define HEADER_mI(ty,where) \
2286 StgArrWords* x = stgCast(StgArrWords*,PopPtr()); \
2287 nat i = PopTaggedInt(); \
2288 if (i * sizeof(ty) + (sizeof(ty)) > sizeof(StgWord) * x->words) { \
2289 return (raiseIndex(where)); \
2291 #define OP_mI_ty(ty,where,s) \
2293 HEADER_mI(mycat2(Stg,ty),where) \
2294 { mycat2(Stg,ty) r; \
2296 mycat2(PushTagged,ty)(r); \
2299 #define OP_mIty_(ty,where,s) \
2301 HEADER_mI(mycat2(Stg,ty),where) \
2303 mycat2(Stg,ty) z = mycat2(PopTagged,ty)(); \
2309 __attribute__ ((unused))
2310 static void myStackCheck ( Capability* cap )
2312 /* fprintf(stderr, "myStackCheck\n"); */
2313 if (!(gSpLim <= gSp && gSp <= stgCast(StgPtr,gSu))) {
2314 fprintf(stderr, "myStackCheck: invalid initial gSp/gSu \n" );
2319 if (!( (P_)gSu >= (P_)cap->rCurrentTSO->stack
2321 (P_)gSu <= (P_)(cap->rCurrentTSO->stack
2322 + cap->rCurrentTSO->stack_size))) {
2323 fprintf ( stderr, "myStackCheck: gSu out of stack\n" );
2327 switch (get_itbl(stgCast(StgClosure*,gSu))->type) {
2329 gSu = (StgUpdateFrame*) ((StgCatchFrame*)(gSu))->link;
2332 gSu = (StgUpdateFrame*) ((StgUpdateFrame*)(gSu))->link;
2335 gSu = (StgUpdateFrame*) ((StgSeqFrame*)(gSu))->link;
2340 fprintf(stderr, "myStackCheck: invalid activation record\n");
2349 /* --------------------------------------------------------------------------
2350 * Primop stuff for bytecode interpreter
2351 * ------------------------------------------------------------------------*/
2353 /* Returns & of the next thing to enter (if throwing an exception),
2354 or NULL in the normal case.
2356 static void* enterBCO_primop1 ( int primop1code )
2359 barf("enterBCO_primop1 in combined mode");
2361 switch (primop1code) {
2362 case i_pushseqframe:
2364 StgClosure* c = PopCPtr();
2369 case i_pushcatchframe:
2371 StgClosure* e = PopCPtr();
2372 StgClosure* h = PopCPtr();
2378 case i_gtChar: OP_CC_B(x>y); break;
2379 case i_geChar: OP_CC_B(x>=y); break;
2380 case i_eqChar: OP_CC_B(x==y); break;
2381 case i_neChar: OP_CC_B(x!=y); break;
2382 case i_ltChar: OP_CC_B(x<y); break;
2383 case i_leChar: OP_CC_B(x<=y); break;
2384 case i_charToInt: OP_C_I(x); break;
2385 case i_intToChar: OP_I_C(x); break;
2387 case i_gtInt: OP_II_B(x>y); break;
2388 case i_geInt: OP_II_B(x>=y); break;
2389 case i_eqInt: OP_II_B(x==y); break;
2390 case i_neInt: OP_II_B(x!=y); break;
2391 case i_ltInt: OP_II_B(x<y); break;
2392 case i_leInt: OP_II_B(x<=y); break;
2393 case i_minInt: OP__I(INT_MIN); break;
2394 case i_maxInt: OP__I(INT_MAX); break;
2395 case i_plusInt: OP_II_I(x+y); break;
2396 case i_minusInt: OP_II_I(x-y); break;
2397 case i_timesInt: OP_II_I(x*y); break;
2400 int x = PopTaggedInt();
2401 int y = PopTaggedInt();
2403 return (raiseDiv0("quotInt"));
2405 /* ToDo: protect against minInt / -1 errors
2406 * (repeat for all other division primops) */
2412 int x = PopTaggedInt();
2413 int y = PopTaggedInt();
2415 return (raiseDiv0("remInt"));
2422 StgInt x = PopTaggedInt();
2423 StgInt y = PopTaggedInt();
2425 return (raiseDiv0("quotRemInt"));
2427 PushTaggedInt(x%y); /* last result */
2428 PushTaggedInt(x/y); /* first result */
2431 case i_negateInt: OP_I_I(-x); break;
2433 case i_andInt: OP_II_I(x&y); break;
2434 case i_orInt: OP_II_I(x|y); break;
2435 case i_xorInt: OP_II_I(x^y); break;
2436 case i_notInt: OP_I_I(~x); break;
2437 case i_shiftLInt: OP_II_I(x<<y); break;
2438 case i_shiftRAInt: OP_II_I(x>>y); break; /* ToDo */
2439 case i_shiftRLInt: OP_II_I(x>>y); break; /* ToDo */
2441 case i_gtWord: OP_WW_B(x>y); break;
2442 case i_geWord: OP_WW_B(x>=y); break;
2443 case i_eqWord: OP_WW_B(x==y); break;
2444 case i_neWord: OP_WW_B(x!=y); break;
2445 case i_ltWord: OP_WW_B(x<y); break;
2446 case i_leWord: OP_WW_B(x<=y); break;
2447 case i_minWord: OP__W(0); break;
2448 case i_maxWord: OP__W(UINT_MAX); break;
2449 case i_plusWord: OP_WW_W(x+y); break;
2450 case i_minusWord: OP_WW_W(x-y); break;
2451 case i_timesWord: OP_WW_W(x*y); break;
2454 StgWord x = PopTaggedWord();
2455 StgWord y = PopTaggedWord();
2457 return (raiseDiv0("quotWord"));
2459 PushTaggedWord(x/y);
2464 StgWord x = PopTaggedWord();
2465 StgWord y = PopTaggedWord();
2467 return (raiseDiv0("remWord"));
2469 PushTaggedWord(x%y);
2474 StgWord x = PopTaggedWord();
2475 StgWord y = PopTaggedWord();
2477 return (raiseDiv0("quotRemWord"));
2479 PushTaggedWord(x%y); /* last result */
2480 PushTaggedWord(x/y); /* first result */
2483 case i_negateWord: OP_W_W(-x); break;
2484 case i_andWord: OP_WW_W(x&y); break;
2485 case i_orWord: OP_WW_W(x|y); break;
2486 case i_xorWord: OP_WW_W(x^y); break;
2487 case i_notWord: OP_W_W(~x); break;
2488 case i_shiftLWord: OP_WW_W(x<<y); break;
2489 case i_shiftRAWord: OP_WW_W(x>>y); break; /* ToDo */
2490 case i_shiftRLWord: OP_WW_W(x>>y); break; /* ToDo */
2491 case i_intToWord: OP_I_W(x); break;
2492 case i_wordToInt: OP_W_I(x); break;
2494 case i_gtAddr: OP_AA_B(x>y); break;
2495 case i_geAddr: OP_AA_B(x>=y); break;
2496 case i_eqAddr: OP_AA_B(x==y); break;
2497 case i_neAddr: OP_AA_B(x!=y); break;
2498 case i_ltAddr: OP_AA_B(x<y); break;
2499 case i_leAddr: OP_AA_B(x<=y); break;
2500 case i_intToAddr: OP_I_A((StgAddr)x); break; /* ToDo */
2501 case i_addrToInt: OP_A_I((StgInt)x); break; /* ToDo */
2503 case i_intToStable: OP_I_s((StgStablePtr)x); break;
2504 case i_stableToInt: OP_s_I((W_)x); break;
2506 case i_indexCharOffAddr: OP_AI_C(indexCharOffAddrzh(r,x,y)); break;
2507 case i_readCharOffAddr: OP_AI_C(indexCharOffAddrzh(r,x,y)); break;
2508 case i_writeCharOffAddr: OP_AIC_(writeCharOffAddrzh(x,y,z)); break;
2510 case i_indexIntOffAddr: OP_AI_I(indexIntOffAddrzh(r,x,y)); break;
2511 case i_readIntOffAddr: OP_AI_I(indexIntOffAddrzh(r,x,y)); break;
2512 case i_writeIntOffAddr: OP_AII_(writeIntOffAddrzh(x,y,z)); break;
2514 case i_indexAddrOffAddr: OP_AI_A(indexAddrOffAddrzh(r,x,y)); break;
2515 case i_readAddrOffAddr: OP_AI_A(indexAddrOffAddrzh(r,x,y)); break;
2516 case i_writeAddrOffAddr: OP_AIA_(writeAddrOffAddrzh(x,y,z)); break;
2518 case i_indexFloatOffAddr: OP_AI_F(indexFloatOffAddrzh(r,x,y)); break;
2519 case i_readFloatOffAddr: OP_AI_F(indexFloatOffAddrzh(r,x,y)); break;
2520 case i_writeFloatOffAddr: OP_AIF_(writeFloatOffAddrzh(x,y,z)); break;
2522 case i_indexDoubleOffAddr: OP_AI_D(indexDoubleOffAddrzh(r,x,y)); break;
2523 case i_readDoubleOffAddr: OP_AI_D(indexDoubleOffAddrzh(r,x,y)); break;
2524 case i_writeDoubleOffAddr: OP_AID_(writeDoubleOffAddrzh(x,y,z)); break;
2526 case i_indexStableOffAddr: OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break;
2527 case i_readStableOffAddr: OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break;
2528 case i_writeStableOffAddr: OP_AIs_(writeStablePtrOffAddrzh(x,y,z)); break;
2530 case i_compareInteger:
2532 B* x = IntegerInsideByteArray(PopPtr());
2533 B* y = IntegerInsideByteArray(PopPtr());
2534 StgInt r = do_cmp(x,y);
2535 PushTaggedInt(r<0 ? -1 : (r>0 ? 1 : 0));
2538 case i_negateInteger: OP_Z_Z(neg); break;
2539 case i_plusInteger: OP_ZZ_Z(add); break;
2540 case i_minusInteger: OP_ZZ_Z(sub); break;
2541 case i_timesInteger: OP_ZZ_Z(mul); break;
2542 case i_quotRemInteger:
2544 B* x = IntegerInsideByteArray(PopPtr());
2545 B* y = IntegerInsideByteArray(PopPtr());
2546 int n = size_qrm(x,y);
2547 StgPtr q = CreateByteArrayToHoldInteger(n);
2548 StgPtr r = CreateByteArrayToHoldInteger(n);
2549 if (do_getsign(y)==0)
2550 return (raiseDiv0("quotRemInteger"));
2551 do_qrm(x,y,n,IntegerInsideByteArray(q),
2552 IntegerInsideByteArray(r));
2553 SloppifyIntegerEnd(q);
2554 SloppifyIntegerEnd(r);
2559 case i_intToInteger:
2561 int n = size_fromInt();
2562 StgPtr p = CreateByteArrayToHoldInteger(n);
2563 do_fromInt( PopTaggedInt(), n, IntegerInsideByteArray(p));
2567 case i_wordToInteger:
2569 int n = size_fromWord();
2570 StgPtr p = CreateByteArrayToHoldInteger(n);
2571 do_fromWord( PopTaggedWord(), n, IntegerInsideByteArray(p));
2575 case i_integerToInt: PushTaggedInt(do_toInt(
2576 IntegerInsideByteArray(PopPtr())
2580 case i_integerToWord: PushTaggedWord(do_toWord(
2581 IntegerInsideByteArray(PopPtr())
2585 case i_integerToFloat: PushTaggedFloat(do_toFloat(
2586 IntegerInsideByteArray(PopPtr())
2590 case i_integerToDouble: PushTaggedDouble(do_toDouble(
2591 IntegerInsideByteArray(PopPtr())
2595 case i_gtFloat: OP_FF_B(x>y); break;
2596 case i_geFloat: OP_FF_B(x>=y); break;
2597 case i_eqFloat: OP_FF_B(x==y); break;
2598 case i_neFloat: OP_FF_B(x!=y); break;
2599 case i_ltFloat: OP_FF_B(x<y); break;
2600 case i_leFloat: OP_FF_B(x<=y); break;
2601 case i_minFloat: OP__F(FLT_MIN); break;
2602 case i_maxFloat: OP__F(FLT_MAX); break;
2603 case i_radixFloat: OP__I(FLT_RADIX); break;
2604 case i_digitsFloat: OP__I(FLT_MANT_DIG); break;
2605 case i_minExpFloat: OP__I(FLT_MIN_EXP); break;
2606 case i_maxExpFloat: OP__I(FLT_MAX_EXP); break;
2607 case i_plusFloat: OP_FF_F(x+y); break;
2608 case i_minusFloat: OP_FF_F(x-y); break;
2609 case i_timesFloat: OP_FF_F(x*y); break;
2612 StgFloat x = PopTaggedFloat();
2613 StgFloat y = PopTaggedFloat();
2614 PushTaggedFloat(x/y);
2617 case i_negateFloat: OP_F_F(-x); break;
2618 case i_floatToInt: OP_F_I(x); break;
2619 case i_intToFloat: OP_I_F(x); break;
2620 case i_expFloat: OP_F_F(exp(x)); break;
2621 case i_logFloat: OP_F_F(log(x)); break;
2622 case i_sqrtFloat: OP_F_F(sqrt(x)); break;
2623 case i_sinFloat: OP_F_F(sin(x)); break;
2624 case i_cosFloat: OP_F_F(cos(x)); break;
2625 case i_tanFloat: OP_F_F(tan(x)); break;
2626 case i_asinFloat: OP_F_F(asin(x)); break;
2627 case i_acosFloat: OP_F_F(acos(x)); break;
2628 case i_atanFloat: OP_F_F(atan(x)); break;
2629 case i_sinhFloat: OP_F_F(sinh(x)); break;
2630 case i_coshFloat: OP_F_F(cosh(x)); break;
2631 case i_tanhFloat: OP_F_F(tanh(x)); break;
2632 case i_powerFloat: OP_FF_F(pow(x,y)); break;
2634 case i_encodeFloatZ:
2636 StgPtr sig = PopPtr();
2637 StgInt exp = PopTaggedInt();
2639 B__encodeFloat(IntegerInsideByteArray(sig), exp)
2643 case i_decodeFloatZ:
2645 StgFloat f = PopTaggedFloat();
2646 StgPtr sig = CreateByteArrayToHoldInteger(size_fltmantissa());
2648 B__decodeFloat(IntegerInsideByteArray(sig), &exp, f);
2654 case i_isNaNFloat: OP_F_B(isFloatNaN(x)); break;
2655 case i_isInfiniteFloat: OP_F_B(isFloatInfinite(x)); break;
2656 case i_isNegativeZeroFloat: OP_F_B(isFloatNegativeZero(x)); break;
2657 case i_isDenormalizedFloat: OP_F_B(isFloatDenormalized(x)); break;
2658 case i_gtDouble: OP_DD_B(x>y); break;
2659 case i_geDouble: OP_DD_B(x>=y); break;
2660 case i_eqDouble: OP_DD_B(x==y); break;
2661 case i_neDouble: OP_DD_B(x!=y); break;
2662 case i_ltDouble: OP_DD_B(x<y); break;
2663 case i_leDouble: OP_DD_B(x<=y) break;
2664 case i_minDouble: OP__D(DBL_MIN); break;
2665 case i_maxDouble: OP__D(DBL_MAX); break;
2666 case i_radixDouble: OP__I(FLT_RADIX); break;
2667 case i_digitsDouble: OP__I(DBL_MANT_DIG); break;
2668 case i_minExpDouble: OP__I(DBL_MIN_EXP); break;
2669 case i_maxExpDouble: OP__I(DBL_MAX_EXP); break;
2670 case i_plusDouble: OP_DD_D(x+y); break;
2671 case i_minusDouble: OP_DD_D(x-y); break;
2672 case i_timesDouble: OP_DD_D(x*y); break;
2673 case i_divideDouble:
2675 StgDouble x = PopTaggedDouble();
2676 StgDouble y = PopTaggedDouble();
2677 PushTaggedDouble(x/y);
2680 case i_negateDouble: OP_D_D(-x); break;
2681 case i_doubleToInt: OP_D_I(x); break;
2682 case i_intToDouble: OP_I_D(x); break;
2683 case i_doubleToFloat: OP_D_F(x); break;
2684 case i_floatToDouble: OP_F_F(x); break;
2685 case i_expDouble: OP_D_D(exp(x)); break;
2686 case i_logDouble: OP_D_D(log(x)); break;
2687 case i_sqrtDouble: OP_D_D(sqrt(x)); break;
2688 case i_sinDouble: OP_D_D(sin(x)); break;
2689 case i_cosDouble: OP_D_D(cos(x)); break;
2690 case i_tanDouble: OP_D_D(tan(x)); break;
2691 case i_asinDouble: OP_D_D(asin(x)); break;
2692 case i_acosDouble: OP_D_D(acos(x)); break;
2693 case i_atanDouble: OP_D_D(atan(x)); break;
2694 case i_sinhDouble: OP_D_D(sinh(x)); break;
2695 case i_coshDouble: OP_D_D(cosh(x)); break;
2696 case i_tanhDouble: OP_D_D(tanh(x)); break;
2697 case i_powerDouble: OP_DD_D(pow(x,y)); break;
2699 case i_encodeDoubleZ:
2701 StgPtr sig = PopPtr();
2702 StgInt exp = PopTaggedInt();
2704 B__encodeDouble(IntegerInsideByteArray(sig), exp)
2708 case i_decodeDoubleZ:
2710 StgDouble d = PopTaggedDouble();
2711 StgPtr sig = CreateByteArrayToHoldInteger(size_dblmantissa());
2713 B__decodeDouble(IntegerInsideByteArray(sig), &exp, d);
2719 case i_isNaNDouble: OP_D_B(isDoubleNaN(x)); break;
2720 case i_isInfiniteDouble: OP_D_B(isDoubleInfinite(x)); break;
2721 case i_isNegativeZeroDouble: OP_D_B(isDoubleNegativeZero(x)); break;
2722 case i_isDenormalizedDouble: OP_D_B(isDoubleDenormalized(x)); break;
2723 case i_isIEEEDouble:
2725 PushTaggedBool(rtsTrue);
2729 barf("Unrecognised primop1");
2736 /* For normal cases, return NULL and leave *return2 unchanged.
2737 To return the address of the next thing to enter,
2738 return the address of it and leave *return2 unchanged.
2739 To return a StgThreadReturnCode to the scheduler,
2740 set *return2 to it and return a non-NULL value.
2741 To cause a context switch, set context_switch (its a global),
2742 and optionally set hugsBlock to your rational.
2744 static void* enterBCO_primop2 ( int primop2code,
2745 int* /*StgThreadReturnCode* */ return2,
2748 HugsBlock *hugsBlock )
2751 /* A small concession: we need to allow ccalls,
2752 even in combined mode.
2754 if (primop2code != i_ccall_ccall_IO &&
2755 primop2code != i_ccall_stdcall_IO)
2756 barf("enterBCO_primop2 in combined mode");
2759 switch (primop2code) {
2760 case i_raise: /* raise#{err} */
2762 StgClosure* err = PopCPtr();
2763 return (raiseAnError(err));
2766 /*------------------------------------------------------------------------
2767 Insert and Remove primitives on Rows
2768 ------------------------------------------------------------------------*/
2772 /* get: row, index and value */
2773 StgMutArrPtrs* row = stgCast(StgMutArrPtrs*,PopPtr());
2774 nat i = PopTaggedInt();
2775 StgClosure* x = PopCPtr();
2777 /* allocate new row */
2778 StgWord n = row->ptrs;
2779 StgMutArrPtrs* newRow
2780 = stgCast(StgMutArrPtrs*,allocate(sizeofW(StgMutArrPtrs) + n + 1));
2781 SET_HDR(newRow,&MUT_ARR_PTRS_FROZEN_info,CCCS);
2786 /* copy the fields, inserting the new value */
2787 for (j = 0; j < i; j++) {
2788 newRow->payload[j] = row->payload[j];
2790 newRow->payload[i] = x;
2791 for (j = i+1; j <= n; j++)
2793 newRow->payload[j] = row->payload[j-1];
2796 PushPtr(stgCast(StgPtr,newRow));
2803 /* get row and index */
2804 StgMutArrPtrs* row = stgCast(StgMutArrPtrs*,PopPtr());
2805 nat i = PopTaggedInt(); /* or Word?? */
2807 /* allocate new row */
2808 StgWord n = row->ptrs;
2809 StgMutArrPtrs* newRow
2810 = stgCast(StgMutArrPtrs*,allocate(sizeofW(StgMutArrPtrs) + n - 1));
2811 SET_HDR(newRow,&MUT_ARR_PTRS_FROZEN_info,CCCS);
2816 /* copy the fields, except for the removed value. */
2817 for (j = 0; j < i; j++) {
2818 newRow->payload[j] = row->payload[j];
2820 for (j = i+1; j < n; j++)
2822 newRow->payload[j-1] = row->payload[j];
2825 PushCPtr(row->payload[i]);
2826 PushPtr(stgCast(StgPtr,newRow));
2829 #endif /* XMLAMBDA */
2833 StgClosure* init = PopCPtr();
2835 = stgCast(StgMutVar*,allocate(sizeofW(StgMutVar)));
2836 SET_HDR(mv,&MUT_VAR_info,CCCS);
2838 PushPtr(stgCast(StgPtr,mv));
2843 StgMutVar* mv = stgCast(StgMutVar*,PopPtr());
2849 StgMutVar* mv = stgCast(StgMutVar*,PopPtr());
2850 StgClosure* value = PopCPtr();
2856 nat n = PopTaggedInt(); /* or Word?? */
2857 StgClosure* init = PopCPtr();
2858 StgWord size = sizeofW(StgMutArrPtrs) + n;
2861 = stgCast(StgMutArrPtrs*,allocate(size));
2862 SET_HDR(arr,&MUT_ARR_PTRS_info,CCCS);
2864 for (i = 0; i < n; ++i) {
2865 arr->payload[i] = init;
2867 PushPtr(stgCast(StgPtr,arr));
2873 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2874 nat i = PopTaggedInt(); /* or Word?? */
2875 StgWord n = arr->ptrs;
2877 return (raiseIndex("{index,read}Array"));
2879 PushCPtr(arr->payload[i]);
2884 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2885 nat i = PopTaggedInt(); /* or Word? */
2886 StgClosure* v = PopCPtr();
2887 StgWord n = arr->ptrs;
2889 return (raiseIndex("{index,read}Array"));
2891 arr->payload[i] = v;
2895 case i_sizeMutableArray:
2897 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2898 PushTaggedInt(arr->ptrs);
2901 case i_unsafeFreezeArray:
2903 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2904 SET_INFO(arr,&MUT_ARR_PTRS_FROZEN_info);
2905 PushPtr(stgCast(StgPtr,arr));
2908 case i_unsafeFreezeByteArray:
2910 /* Delightfully simple :-) */
2914 case i_sameMutableArray:
2915 case i_sameMutableByteArray:
2917 StgPtr x = PopPtr();
2918 StgPtr y = PopPtr();
2919 PushTaggedBool(x==y);
2923 case i_newByteArray:
2925 nat n = PopTaggedInt(); /* or Word?? */
2926 StgInt words = (n+sizeof(W_)-1)/sizeof(W_);
2927 StgWord size = sizeofW(StgArrWords) + words;
2928 StgArrWords* arr = stgCast(StgArrWords*,allocate(size));
2929 SET_HDR(arr,&ARR_WORDS_info,CCCS);
2933 for (i = 0; i < n; ++i) {
2934 arr->payload[i] = 0xdeadbeef;
2937 PushPtr(stgCast(StgPtr,arr));
2941 /* Most of these generate alignment warnings on Sparcs and similar architectures.
2942 * These are harmless and are caused by the cast to C* in BYTE_ARR_CTS.
2944 case i_indexCharArray:
2945 OP_mI_ty(Char,"indexCharArray", indexCharArrayzh(r,x,i)); break;
2946 case i_readCharArray:
2947 OP_mI_ty(Char,"readCharArray", readCharArrayzh(r,x,i)); break;
2948 case i_writeCharArray:
2949 OP_mIty_(Char,"writeCharArray", writeCharArrayzh(x,i,z)); break;
2951 case i_indexIntArray:
2952 OP_mI_ty(Int,"indexIntArray", indexIntArrayzh(r,x,i)); break;
2953 case i_readIntArray:
2954 OP_mI_ty(Int,"readIntArray", readIntArrayzh(r,x,i)); break;
2955 case i_writeIntArray:
2956 OP_mIty_(Int,"writeIntArray", writeIntArrayzh(x,i,z)); break;
2958 case i_indexAddrArray:
2959 OP_mI_ty(Addr,"indexAddrArray", indexAddrArrayzh(r,x,i)); break;
2960 case i_readAddrArray:
2961 OP_mI_ty(Addr,"readAddrArray", readAddrArrayzh(r,x,i)); break;
2962 case i_writeAddrArray:
2963 OP_mIty_(Addr,"writeAddrArray", writeAddrArrayzh(x,i,z)); break;
2965 case i_indexFloatArray:
2966 OP_mI_ty(Float,"indexFloatArray", indexFloatArrayzh(r,x,i)); break;
2967 case i_readFloatArray:
2968 OP_mI_ty(Float,"readFloatArray", readFloatArrayzh(r,x,i)); break;
2969 case i_writeFloatArray:
2970 OP_mIty_(Float,"writeFloatArray", writeFloatArrayzh(x,i,z)); break;
2972 case i_indexDoubleArray:
2973 OP_mI_ty(Double,"indexDoubleArray", indexDoubleArrayzh(r,x,i)); break;
2974 case i_readDoubleArray:
2975 OP_mI_ty(Double,"readDoubleArray", readDoubleArrayzh(r,x,i)); break;
2976 case i_writeDoubleArray:
2977 OP_mIty_(Double,"writeDoubleArray", writeDoubleArrayzh(x,i,z)); break;
2980 #ifdef PROVIDE_STABLE
2981 case i_indexStableArray:
2982 OP_mI_ty(StablePtr,"indexStableArray", indexStablePtrArrayzh(r,x,i)); break;
2983 case i_readStableArray:
2984 OP_mI_ty(StablePtr,"readStableArray", readStablePtrArrayzh(r,x,i)); break;
2985 case i_writeStableArray:
2986 OP_mIty_(StablePtr,"writeStableArray", writeStablePtrArrayzh(x,i,z)); break;
2992 #ifdef PROVIDE_COERCE
2993 case i_unsafeCoerce:
2995 /* Another nullop */
2999 #ifdef PROVIDE_PTREQUALITY
3000 case i_reallyUnsafePtrEquality:
3001 { /* identical to i_sameRef */
3002 StgPtr x = PopPtr();
3003 StgPtr y = PopPtr();
3004 PushTaggedBool(x==y);
3008 #ifdef PROVIDE_FOREIGN
3009 /* ForeignObj# operations */
3010 case i_mkForeignObj:
3012 StgForeignObj *result
3013 = stgCast(StgForeignObj*,allocate(sizeofW(StgForeignObj)));
3014 SET_HDR(result,&FOREIGN_info,CCCS);
3015 result -> data = PopTaggedAddr();
3016 PushPtr(stgCast(StgPtr,result));
3019 #endif /* PROVIDE_FOREIGN */
3024 = stgCast(StgWeak*,allocate(sizeofW(StgWeak)));
3025 SET_HDR(w, &WEAK_info, CCCS);
3027 w->value = PopCPtr();
3028 w->finaliser = PopCPtr();
3029 w->link = weak_ptr_list;
3031 IF_DEBUG(weak, fprintf(stderr,"New weak pointer at %p\n",w));
3032 PushPtr(stgCast(StgPtr,w));
3037 StgWeak *w = stgCast(StgWeak*,PopPtr());
3038 if (w->header.info == &WEAK_info) {
3039 PushCPtr(w->value); /* last result */
3040 PushTaggedInt(1); /* first result */
3042 PushPtr(stgCast(StgPtr,w));
3043 /* ToDo: error thunk would be better */
3048 #endif /* PROVIDE_WEAK */
3050 case i_makeStablePtr:
3052 StgPtr p = PopPtr();
3053 StgStablePtr sp = getStablePtr ( p );
3054 PushTaggedStablePtr(sp);
3057 case i_deRefStablePtr:
3060 StgStablePtr sp = PopTaggedStablePtr();
3061 p = deRefStablePtr(sp);
3065 case i_freeStablePtr:
3067 StgStablePtr sp = PopTaggedStablePtr();
3072 case i_createAdjThunkARCH:
3074 StgStablePtr stableptr = PopTaggedStablePtr();
3075 StgAddr typestr = PopTaggedAddr();
3076 StgChar callconv = PopTaggedChar();
3077 StgAddr adj_thunk = createAdjThunk(stableptr,typestr,callconv);
3078 PushTaggedAddr(adj_thunk);
3084 StgInt n = prog_argc;
3090 StgInt n = PopTaggedInt();
3091 StgAddr a = (StgAddr)prog_argv[n];
3098 StgMVar *mvar = stgCast(StgMVar*,allocate(sizeofW(StgMVar)));
3099 SET_INFO(mvar,&EMPTY_MVAR_info);
3100 mvar->head = mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
3101 mvar->value = stgCast(StgClosure*,&END_TSO_QUEUE_closure);
3102 PushPtr(stgCast(StgPtr,mvar));
3107 StgMVar *mvar = (StgMVar*)PopCPtr();
3108 if (GET_INFO(mvar) == &EMPTY_MVAR_info) {
3110 /* The MVar is empty. Attach ourselves to the TSO's
3113 if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
3114 mvar->head = cap->rCurrentTSO;
3116 mvar->tail->link = cap->rCurrentTSO;
3118 cap->rCurrentTSO->link = (StgTSO *)&END_TSO_QUEUE_closure;
3119 cap->rCurrentTSO->why_blocked = BlockedOnMVar;
3120 cap->rCurrentTSO->block_info.closure = (StgClosure *)mvar;
3121 mvar->tail = cap->rCurrentTSO;
3123 /* At this point, the top-of-stack holds the MVar,
3124 and underneath is the world token (). So the
3125 stack is in the same state as when primTakeMVar
3126 was entered (primTakeMVar is handwritten bytecode).
3127 Push obj, which is this BCO, and return to the
3128 scheduler. When the MVar is filled, the scheduler
3129 will re-enter primTakeMVar, with the args still on
3130 the top of the stack.
3132 PushCPtr((StgClosure*)(*bco));
3133 *return2 = ThreadBlocked;
3134 return (void*)(1+(char*)(NULL));
3137 PushCPtr(mvar->value);
3138 mvar->value = (StgClosure *)&END_TSO_QUEUE_closure;
3139 SET_INFO(mvar,&EMPTY_MVAR_info);
3145 StgMVar* mvar = stgCast(StgMVar*,PopPtr());
3146 StgClosure* value = PopCPtr();
3147 if (GET_INFO(mvar) == &FULL_MVAR_info) {
3148 return (makeErrorCall("putMVar {full MVar}"));
3150 /* wake up the first thread on the
3151 * queue, it will continue with the
3152 * takeMVar operation and mark the
3155 mvar->value = value;
3157 if (mvar->head != (StgTSO *)&END_TSO_QUEUE_closure) {
3158 ASSERT(mvar->head->why_blocked == BlockedOnMVar);
3159 mvar->head = unblockOne(mvar->head);
3160 if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
3161 mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
3165 /* unlocks the MVar in the SMP case */
3166 SET_INFO(mvar,&FULL_MVAR_info);
3168 /* yield for better communication performance */
3174 { /* identical to i_sameRef */
3175 StgMVar* x = (StgMVar*)PopPtr();
3176 StgMVar* y = (StgMVar*)PopPtr();
3177 PushTaggedBool(x==y);
3180 #ifdef PROVIDE_CONCURRENT
3183 StgClosure* closure;
3186 closure = PopCPtr();
3187 tso = createGenThread (RtsFlags.GcFlags.initialStkSize,closure);
3189 scheduleThread(tso);
3191 /* Later: Change to use tso as the ThreadId */
3192 PushTaggedWord(tid);
3198 StgWord n = PopTaggedWord();
3202 // Map from ThreadId to Thread Structure */
3203 for (t = all_threads; t != END_TSO_QUEUE; t = t->global_link) {
3212 while (tso->what_next == ThreadRelocated) {
3217 if (tso == cap->rCurrentTSO) { /* suicide */
3218 *return2 = ThreadFinished;
3219 return (void*)(1+(char*)(NULL));
3223 case i_raiseInThread:
3224 barf("raiseInThread");
3225 ASSERT(0); /* not (yet) supported */
3228 StgInt n = PopTaggedInt();
3230 hugsBlock->reason = BlockedOnDelay;
3231 hugsBlock->delay = n;
3236 StgInt n = PopTaggedInt();
3238 hugsBlock->reason = BlockedOnRead;
3239 hugsBlock->delay = n;
3244 StgInt n = PopTaggedInt();
3246 hugsBlock->reason = BlockedOnWrite;
3247 hugsBlock->delay = n;
3252 /* The definition of yield include an enter right after
3253 * the primYield, at which time context_switch is tested.
3260 StgWord tid = cap->rCurrentTSO->id;
3261 PushTaggedWord(tid);
3264 case i_cmpThreadIds:
3266 StgWord tid1 = PopTaggedWord();
3267 StgWord tid2 = PopTaggedWord();
3268 if (tid1 < tid2) PushTaggedInt(-1);
3269 else if (tid1 > tid2) PushTaggedInt(1);
3270 else PushTaggedInt(0);
3273 #endif /* PROVIDE_CONCURRENT */
3275 case i_ccall_ccall_Id:
3276 case i_ccall_ccall_IO:
3277 case i_ccall_stdcall_Id:
3278 case i_ccall_stdcall_IO:
3281 CFunDescriptor* descriptor;
3282 void (*funPtr)(void);
3284 descriptor = PopTaggedAddr();
3285 funPtr = PopTaggedAddr();
3286 cc = (primop2code == i_ccall_stdcall_Id ||
3287 primop2code == i_ccall_stdcall_IO)
3289 r = ccall(descriptor,funPtr,bco,cc,cap);
3292 return makeErrorCall(
3293 "unhandled type or too many args/results in ccall");
3295 barf("ccall not configured correctly for this platform");
3296 barf("unknown return code from ccall");
3299 barf("Unrecognised primop2");
3305 /* -----------------------------------------------------------------------------
3306 * ccall support code:
3307 * marshall moves args from C stack to Haskell stack
3308 * unmarshall moves args from Haskell stack to C stack
3309 * argSize calculates how much gSpace you need on the C stack
3310 * ---------------------------------------------------------------------------*/
3312 /* Pop arguments off the C stack and Push them onto the Hugs stack.
3313 * Used when preparing for C calling Haskell or in regSponse to
3314 * Haskell calling C.
3316 nat marshall(char arg_ty, void* arg)
3320 PushTaggedInt(*((int*)arg));
3321 return ARG_SIZE(INT_TAG);
3324 PushTaggedInteger(*((mpz_ptr*)arg));
3325 return ARG_SIZE(INTEGER_TAG);
3328 PushTaggedWord(*((unsigned int*)arg));
3329 return ARG_SIZE(WORD_TAG);
3331 PushTaggedChar(*((char*)arg));
3332 return ARG_SIZE(CHAR_TAG);
3334 PushTaggedFloat(*((float*)arg));
3335 return ARG_SIZE(FLOAT_TAG);
3337 PushTaggedDouble(*((double*)arg));
3338 return ARG_SIZE(DOUBLE_TAG);
3340 PushTaggedAddr(*((void**)arg));
3341 return ARG_SIZE(ADDR_TAG);
3343 PushTaggedStablePtr(*((StgStablePtr*)arg));
3344 return ARG_SIZE(STABLE_TAG);
3345 #ifdef PROVIDE_FOREIGN
3347 /* Not allowed in this direction - you have to
3348 * call makeForeignPtr explicitly
3350 barf("marshall: ForeignPtr#\n");
3355 /* Not allowed in this direction */
3356 barf("marshall: [Mutable]ByteArray#\n");
3359 barf("marshall: unrecognised arg type %d\n",arg_ty);
3364 /* Pop arguments off the Hugs stack and Push them onto the C stack.
3365 * Used when preparing for Haskell calling C or in regSponse to
3366 * C calling Haskell.
3368 nat unmarshall(char res_ty, void* res)
3372 *((int*)res) = PopTaggedInt();
3373 return ARG_SIZE(INT_TAG);
3376 *((mpz_ptr*)res) = PopTaggedInteger();
3377 return ARG_SIZE(INTEGER_TAG);
3380 *((unsigned int*)res) = PopTaggedWord();
3381 return ARG_SIZE(WORD_TAG);
3383 *((int*)res) = PopTaggedChar();
3384 return ARG_SIZE(CHAR_TAG);
3386 *((float*)res) = PopTaggedFloat();
3387 return ARG_SIZE(FLOAT_TAG);
3389 *((double*)res) = PopTaggedDouble();
3390 return ARG_SIZE(DOUBLE_TAG);
3392 *((void**)res) = PopTaggedAddr();
3393 return ARG_SIZE(ADDR_TAG);
3395 *((StgStablePtr*)res) = PopTaggedStablePtr();
3396 return ARG_SIZE(STABLE_TAG);
3397 #ifdef PROVIDE_FOREIGN
3400 StgForeignObj *result = stgCast(StgForeignObj*,PopPtr());
3401 *((void**)res) = result->data;
3402 return sizeofW(StgPtr);
3408 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
3409 *((void**)res) = stgCast(void*,&(arr->payload));
3410 return sizeofW(StgPtr);
3413 barf("unmarshall: unrecognised result type %d\n",res_ty);
3417 nat argSize( const char* ks )
3420 for( ; *ks != '\0'; ++ks) {
3423 sz += sizeof(StgWord) * ARG_SIZE(INT_TAG);
3427 sz += sizeof(StgWord) * ARG_SIZE(INTEGER_TAG);
3431 sz += sizeof(StgWord) * ARG_SIZE(WORD_TAG);
3434 sz += sizeof(StgWord) * ARG_SIZE(CHAR_TAG);
3437 sz += sizeof(StgWord) * ARG_SIZE(FLOAT_TAG);
3440 sz += sizeof(StgWord) * ARG_SIZE(DOUBLE_TAG);
3443 sz += sizeof(StgWord) * ARG_SIZE(ADDR_TAG);
3446 sz += sizeof(StgWord) * ARG_SIZE(STABLE_TAG);
3448 #ifdef PROVIDE_FOREIGN
3453 sz += sizeof(StgPtr);
3456 barf("argSize: unrecognised result type %d\n",*ks);
3464 /* -----------------------------------------------------------------------------
3465 * encode/decode Float/Double code for standalone Hugs
3466 * Code based on the HBC code (lib/fltcode.c) and more recently GHC
3467 * (ghc/rts/StgPrimFloat.c)
3468 * ---------------------------------------------------------------------------*/
3470 #if IEEE_FLOATING_POINT
3471 #define MY_DMINEXP ((DBL_MIN_EXP) - (DBL_MANT_DIG) - 1)
3472 /* DMINEXP is defined in values.h on Linux (for example) */
3473 #define DHIGHBIT 0x00100000
3474 #define DMSBIT 0x80000000
3476 #define MY_FMINEXP ((FLT_MIN_EXP) - (FLT_MANT_DIG) - 1)
3477 #define FHIGHBIT 0x00800000
3478 #define FMSBIT 0x80000000
3480 #error The following code doesnt work in a non-IEEE FP environment
3483 #ifdef WORDS_BIGENDIAN
3492 StgDouble B__encodeDouble (B* s, I_ e) /* result = s * 2^e */
3497 /* Convert a B to a double; knows a lot about internal rep! */
3498 for(r = 0.0, i = s->used-1; i >= 0; i--)
3499 r = (r * B_BASE_FLT) + s->stuff[i];
3501 /* Now raise to the exponent */
3502 if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
3505 /* handle the sign */
3506 if (s->sign < 0) r = -r;
3513 #if ! FLOATS_AS_DOUBLES
3514 StgFloat B__encodeFloat (B* s, I_ e) /* result = s * 2^e */
3519 /* Convert a B to a float; knows a lot about internal rep! */
3520 for(r = 0.0, i = s->used-1; i >= 0; i--)
3521 r = (r * B_BASE_FLT) + s->stuff[i];
3523 /* Now raise to the exponent */
3524 if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
3527 /* handle the sign */
3528 if (s->sign < 0) r = -r;
3532 #endif /* FLOATS_AS_DOUBLES */
3536 /* This only supports IEEE floating point */
3537 void B__decodeDouble (B* man, I_* exp, StgDouble dbl)
3539 /* Do some bit fiddling on IEEE */
3540 nat low, high; /* assuming 32 bit ints */
3542 union { double d; int i[2]; } u; /* assuming 32 bit ints, 64 bit double */
3544 u.d = dbl; /* grab chunks of the double */
3548 ASSERT(B_BASE == 256);
3550 /* Assume that the supplied B is the right size */
3553 if (low == 0 && (high & ~DMSBIT) == 0) {
3554 man->sign = man->used = 0;
3559 iexp = ((high >> 20) & 0x7ff) + MY_DMINEXP;
3563 if (iexp != MY_DMINEXP) /* don't add hidden bit to denorms */
3567 /* A denorm, normalize the mantissa */
3568 while (! (high & DHIGHBIT)) {
3578 man->stuff[7] = (((W_)high) >> 24) & 0xff;
3579 man->stuff[6] = (((W_)high) >> 16) & 0xff;
3580 man->stuff[5] = (((W_)high) >> 8) & 0xff;
3581 man->stuff[4] = (((W_)high) ) & 0xff;
3583 man->stuff[3] = (((W_)low) >> 24) & 0xff;
3584 man->stuff[2] = (((W_)low) >> 16) & 0xff;
3585 man->stuff[1] = (((W_)low) >> 8) & 0xff;
3586 man->stuff[0] = (((W_)low) ) & 0xff;
3588 if (sign < 0) man->sign = -1;
3590 do_renormalise(man);
3594 #if ! FLOATS_AS_DOUBLES
3595 void B__decodeFloat (B* man, I_* exp, StgFloat flt)
3597 /* Do some bit fiddling on IEEE */
3598 int high, sign; /* assuming 32 bit ints */
3599 union { float f; int i; } u; /* assuming 32 bit float and int */
3601 u.f = flt; /* grab the float */
3604 ASSERT(B_BASE == 256);
3606 /* Assume that the supplied B is the right size */
3609 if ((high & ~FMSBIT) == 0) {
3610 man->sign = man->used = 0;
3615 *exp = ((high >> 23) & 0xff) + MY_FMINEXP;
3619 if (*exp != MY_FMINEXP) /* don't add hidden bit to denorms */
3623 /* A denorm, normalize the mantissa */
3624 while (! (high & FHIGHBIT)) {
3629 man->stuff[3] = (((W_)high) >> 24) & 0xff;
3630 man->stuff[2] = (((W_)high) >> 16) & 0xff;
3631 man->stuff[1] = (((W_)high) >> 8) & 0xff;
3632 man->stuff[0] = (((W_)high) ) & 0xff;
3634 if (sign < 0) man->sign = -1;
3636 do_renormalise(man);
3639 #endif /* FLOATS_AS_DOUBLES */
3640 #endif /* INTERPRETER */