1 /* -*- mode: hugs-c; -*- */
2 /* -----------------------------------------------------------------------------
5 * Copyright (c) 1994-1998.
7 * $RCSfile: Evaluator.c,v $
9 * $Date: 1998/12/02 13:28:17 $
10 * ---------------------------------------------------------------------------*/
20 #include "SchedAPI.h" /* for createGenThread */
21 #include "Schedule.h" /* for context_switch */
23 #include "Bytecodes.h"
24 #include "Assembler.h" /* for CFun stuff */
25 #include "ForeignCall.h"
26 #include "StablePtr.h"
27 #include "PrimOps.h" /* for __{encode,decode}{Float,Double} */
28 #include "Evaluator.h"
32 #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 */
44 #ifdef PROVIDE_INTEGER
45 #include "gmp.h" /* These are for primops */
48 /* An incredibly useful abbreviation.
49 * Interestingly, there are some uses of END_TSO_QUEUE_closure that
50 * can't use it because they use the closure at type StgClosure* or
51 * even StgPtr*. I suspect they should be changed. -- ADR
53 #define EndTSOQueue stgCast(StgTSO*,(void*)&END_TSO_QUEUE_closure)
55 /* These macros are rather delicate - read a good ANSI C book carefully
59 #define mycat(x,y) x##y
60 #define mycat2(x,y) mycat(x,y)
61 #define mycat3(x,y,z) mycat2(x,mycat2(y,z))
63 /* --------------------------------------------------------------------------
64 * Hugs Hooks - a bit of a hack
65 * ------------------------------------------------------------------------*/
67 void setRtsFlags( int x );
68 void setRtsFlags( int x )
70 *(int*)(&(RtsFlags.DebugFlags)) = x;
73 /* --------------------------------------------------------------------------
76 * ToDo: figure out why these are being used and crush them!
77 * ------------------------------------------------------------------------*/
79 void OnExitHook (void)
82 void StackOverflowHook (unsigned long stack_size)
84 fprintf(stderr,"Stack Overflow\n");
87 void OutOfHeapHook (unsigned long request_size, unsigned long heap_size)
89 fprintf(stderr,"Out Of Heap\n");
92 void MallocFailHook (unsigned long request_size /* in bytes */, char *msg)
94 fprintf(stderr,"Malloc Fail\n");
97 void defaultsHook (void)
102 /* --------------------------------------------------------------------------
104 * ------------------------------------------------------------------------*/
106 #ifdef PROVIDE_INTEGER
107 static inline mpz_ptr mpz_alloc ( void );
108 static inline void mpz_free ( mpz_ptr );
110 static inline mpz_ptr mpz_alloc ( void )
112 mpz_ptr r = stgCast(mpz_ptr,stgMallocBytes( sizeof(mpz_t),"mpz_alloc"));
117 static inline void mpz_free ( mpz_ptr a )
124 /* --------------------------------------------------------------------------
126 * ------------------------------------------------------------------------*/
128 static inline void PushTag ( StackTag t );
129 static inline void PushPtr ( StgPtr x );
130 static inline void PushCPtr ( StgClosure* x );
131 static inline void PushInt ( StgInt x );
132 static inline void PushWord ( StgWord x );
134 static inline void PushTag ( StackTag t ) { *(--Sp) = t; }
135 static inline void PushPtr ( StgPtr x ) { *(--stgCast(StgPtr*,Sp)) = x; }
136 static inline void PushCPtr ( StgClosure* x ) { *(--stgCast(StgClosure**,Sp)) = x; }
137 static inline void PushInt ( StgInt x ) { *(--stgCast(StgInt*,Sp)) = x; }
138 static inline void PushWord ( StgWord x ) { *(--stgCast(StgWord*,Sp)) = x; }
140 static inline void checkTag ( StackTag t1, StackTag t2 );
141 static inline void PopTag ( StackTag t );
142 static inline StgPtr PopPtr ( void );
143 static inline StgClosure* PopCPtr ( void );
144 static inline StgInt PopInt ( void );
145 static inline StgWord PopWord ( void );
147 static inline void checkTag ( StackTag t1, StackTag t2 ) { ASSERT(t1 == t2);}
148 static inline void PopTag ( StackTag t ) { checkTag(t,*(Sp++)); }
149 static inline StgPtr PopPtr ( void ) { return *stgCast(StgPtr*,Sp)++; }
150 static inline StgClosure* PopCPtr ( void ) { return *stgCast(StgClosure**,Sp)++; }
151 static inline StgInt PopInt ( void ) { return *stgCast(StgInt*,Sp)++; }
152 static inline StgWord PopWord ( void ) { return *stgCast(StgWord*,Sp)++; }
154 static inline StgPtr stackPtr ( StgStackOffset i );
155 static inline StgInt stackInt ( StgStackOffset i );
156 static inline StgWord stackWord ( StgStackOffset i );
158 static inline StgPtr stackPtr ( StgStackOffset i ) { return *stgCast(StgPtr*, Sp+i); }
159 static inline StgInt stackInt ( StgStackOffset i ) { return *stgCast(StgInt*, Sp+i); }
160 static inline StgWord stackWord ( StgStackOffset i ) { return *stgCast(StgWord*,Sp+i); }
162 static inline void setStackWord ( StgStackOffset i, StgWord w );
164 static inline void setStackWord ( StgStackOffset i, StgWord w ) { Sp[i] = w; }
166 static inline void PushTaggedRealWorld( void );
167 static inline void PushTaggedInt ( StgInt x );
169 static inline void PushTaggedInt64 ( StgInt64 x );
171 #ifdef PROVIDE_INTEGER
172 static inline void PushTaggedInteger ( mpz_ptr x );
175 static inline void PushTaggedWord ( StgWord x );
178 static inline void PushTaggedAddr ( StgAddr x );
180 static inline void PushTaggedChar ( StgChar x );
181 static inline void PushTaggedFloat ( StgFloat x );
182 static inline void PushTaggedDouble ( StgDouble x );
183 static inline void PushTaggedStablePtr ( StgStablePtr x );
184 static inline void PushTaggedBool ( int x );
186 static inline void PushTaggedRealWorld( void ) { PushTag(REALWORLD_TAG); }
187 static inline void PushTaggedInt ( StgInt x ) { Sp -= sizeofW(StgInt); *Sp = x; PushTag(INT_TAG); }
189 static inline void PushTaggedInt64 ( StgInt64 x ) { Sp -= sizeofW(StgInt64); ASSIGN_Int64(Sp,x); PushTag(INT64_TAG); }
191 #ifdef PROVIDE_INTEGER
192 static inline void PushTaggedInteger ( mpz_ptr x )
194 StgForeignObj *result;
197 result = stgCast(StgForeignObj*,allocate(sizeofW(StgForeignObj)));
198 SET_HDR(result,&FOREIGN_info,CCCS);
201 #if 0 /* For now we don't deallocate Integer's at all */
202 w = stgCast(StgWeak*,allocate(sizeofW(StgWeak)));
203 SET_HDR(w, &WEAK_info, CCCS);
204 w->key = stgCast(StgClosure*,result);
205 w->value = stgCast(StgClosure*,result); /* or any other closure you have handy */
206 w->finaliser = funPtrToIO(mpz_free);
207 w->link = weak_ptr_list;
209 IF_DEBUG(weak, fprintf(stderr,"New weak pointer watching Foreign MPZ at %p\n",w));
212 PushPtr(stgCast(StgPtr,result));
216 static inline void PushTaggedWord ( StgWord x ) { Sp -= sizeofW(StgWord); *Sp = x; PushTag(WORD_TAG); }
219 static inline void PushTaggedAddr ( StgAddr x ) { Sp -= sizeofW(StgAddr); *Sp = (W_)x; PushTag(ADDR_TAG); }
221 static inline void PushTaggedChar ( StgChar x ) { Sp -= sizeofW(StgChar); *Sp = x; PushTag(CHAR_TAG); }
222 static inline void PushTaggedFloat ( StgFloat x ) { Sp -= sizeofW(StgFloat); ASSIGN_FLT(Sp,x); PushTag(FLOAT_TAG); }
223 static inline void PushTaggedDouble ( StgDouble x ) { Sp -= sizeofW(StgDouble); ASSIGN_DBL(Sp,x); PushTag(DOUBLE_TAG); }
224 static inline void PushTaggedStablePtr ( StgStablePtr x ) { Sp -= sizeofW(StgStablePtr); *Sp = x; PushTag(STABLE_TAG); }
225 static inline void PushTaggedBool ( int x ) { PushTaggedInt(x); }
227 static inline void PopTaggedRealWorld ( void );
228 static inline StgInt PopTaggedInt ( void );
230 static inline StgInt64 PopTaggedInt64 ( void );
232 #ifdef PROVIDE_INTEGER
233 static inline mpz_ptr PopTaggedInteger ( void );
236 static inline StgWord PopTaggedWord ( void );
239 static inline StgAddr PopTaggedAddr ( void );
241 static inline StgChar PopTaggedChar ( void );
242 static inline StgFloat PopTaggedFloat ( void );
243 static inline StgDouble PopTaggedDouble ( void );
244 static inline StgStablePtr PopTaggedStablePtr ( void );
246 static inline void PopTaggedRealWorld ( void ) { PopTag(REALWORLD_TAG); }
247 static inline StgInt PopTaggedInt ( void ) { StgInt r; PopTag(INT_TAG); r = *stgCast(StgInt*, Sp); Sp += sizeofW(StgInt); return r;}
249 static inline StgInt64 PopTaggedInt64 ( void ) { StgInt64 r; PopTag(INT64_TAG); r = PK_Int64(Sp); Sp += sizeofW(StgInt64); return r;}
251 #ifdef PROVIDE_INTEGER
252 static inline mpz_ptr PopTaggedInteger ( void ) { StgForeignObj *r = *stgCast(StgForeignObj**,Sp); Sp += sizeofW(StgPtr); return stgCast(mpz_ptr,r->data);}
255 static inline StgWord PopTaggedWord ( void ) { StgWord r; PopTag(WORD_TAG); r = *stgCast(StgWord*, Sp); Sp += sizeofW(StgWord); return r;}
258 static inline StgAddr PopTaggedAddr ( void ) { StgAddr r; PopTag(ADDR_TAG); r = *stgCast(StgAddr*, Sp); Sp += sizeofW(StgAddr); return r;}
260 static inline StgChar PopTaggedChar ( void ) { StgChar r; PopTag(CHAR_TAG); r = *stgCast(StgChar*, Sp); Sp += sizeofW(StgChar); return r;}
261 static inline StgFloat PopTaggedFloat ( void ) { StgFloat r; PopTag(FLOAT_TAG); r = PK_FLT(Sp); Sp += sizeofW(StgFloat); return r;}
262 static inline StgDouble PopTaggedDouble ( void ) { StgDouble r; PopTag(DOUBLE_TAG); r = PK_DBL(Sp); Sp += sizeofW(StgDouble); return r;}
263 static inline StgStablePtr PopTaggedStablePtr ( void ) { StgInt r; PopTag(STABLE_TAG); r = *stgCast(StgStablePtr*, Sp); Sp += sizeofW(StgStablePtr); return r;}
265 static inline StgInt taggedStackInt ( StgStackOffset i );
267 static inline StgInt64 taggedStackInt64 ( StgStackOffset i );
270 static inline StgWord taggedStackWord ( StgStackOffset i );
273 static inline StgAddr taggedStackAddr ( StgStackOffset i );
275 static inline StgChar taggedStackChar ( StgStackOffset i );
276 static inline StgFloat taggedStackFloat ( StgStackOffset i );
277 static inline StgDouble taggedStackDouble ( StgStackOffset i );
278 static inline StgStablePtr taggedStackStable ( StgStackOffset i );
280 static inline StgInt taggedStackInt ( StgStackOffset i ) { checkTag(INT_TAG,Sp[i]); return *stgCast(StgInt*, Sp+1+i); }
282 static inline StgInt64 taggedStackInt64 ( StgStackOffset i ) { checkTag(INT64_TAG,Sp[i]); return PK_Int64(Sp+1+i); }
285 static inline StgWord taggedStackWord ( StgStackOffset i ) { checkTag(WORD_TAG,Sp[i]); return *stgCast(StgWord*, Sp+1+i); }
288 static inline StgAddr taggedStackAddr ( StgStackOffset i ) { checkTag(ADDR_TAG,Sp[i]); return *stgCast(StgAddr*, Sp+1+i); }
290 static inline StgChar taggedStackChar ( StgStackOffset i ) { checkTag(CHAR_TAG,Sp[i]); return *stgCast(StgChar*, Sp+1+i); }
291 static inline StgFloat taggedStackFloat ( StgStackOffset i ) { checkTag(FLOAT_TAG,Sp[i]); return PK_FLT(Sp+1+i); }
292 static inline StgDouble taggedStackDouble ( StgStackOffset i ) { checkTag(DOUBLE_TAG,Sp[i]); return PK_DBL(Sp+1+i); }
293 static inline StgStablePtr taggedStackStable ( StgStackOffset i ) { checkTag(STABLE_TAG,Sp[i]); return *stgCast(StgStablePtr*, Sp+1+i); }
296 /* --------------------------------------------------------------------------
299 * Should we allocate from a nursery or use the
300 * doYouWantToGC/allocate interface? We'd already implemented a
301 * nursery-style scheme when the doYouWantToGC/allocate interface
303 * One reason to prefer the doYouWantToGC/allocate interface is to
304 * support operations which allocate an unknown amount in the heap
305 * (array ops, gmp ops, etc)
306 * ------------------------------------------------------------------------*/
308 static inline StgPtr grabHpUpd( nat size )
310 ASSERT( size >= MIN_UPD_SIZE + sizeofW(StgHeader) );
311 return allocate(size);
314 static inline StgPtr grabHpNonUpd( nat size )
316 ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
317 return allocate(size);
320 /* --------------------------------------------------------------------------
321 * Manipulate "update frame" list:
322 * o Update frames (based on stg_do_update and friends in Updates.hc)
323 * o Error handling/catching (based on catchZh_fast and friends in Prims.hc)
324 * o Seq frames (based on seq_frame_entry in Prims.hc)
326 * ------------------------------------------------------------------------*/
328 static inline void PopUpdateFrame ( StgClosure* obj );
329 static inline void PushCatchFrame ( StgClosure* catcher );
330 static inline void PopCatchFrame ( void );
331 static inline void PushSeqFrame ( void );
332 static inline void PopSeqFrame ( void );
334 static inline StgClosure* raiseAnError ( StgClosure* errObj );
336 static inline void PopUpdateFrame( StgClosure* obj )
338 /* NB: doesn't assume that Sp == Su */
340 fprintf(stderr, "Updating ");
341 printPtr(stgCast(StgPtr,Su->updatee));
342 fprintf(stderr, " with ");
344 fprintf(stderr,"\nSp = %p\tSu = %p\n", Sp, Su);
346 #ifndef LAZY_BLACKHOLING
347 ASSERT(get_itbl(Su->updatee)->type == BLACKHOLE
348 || get_itbl(Su->updatee)->type == CAF_BLACKHOLE
350 #endif /* LAZY_BLACKHOLING */
351 UPD_IND(Su->updatee,obj);
352 Sp = stgCast(StgStackPtr,Su) + sizeofW(StgUpdateFrame);
356 static inline void PopStopFrame( StgClosure* obj )
358 /* Move Su just off the end of the stack, we're about to spam the
359 * STOP_FRAME with the return value.
361 Su = stgCast(StgUpdateFrame*,Sp+1);
362 *stgCast(StgClosure**,Sp) = obj;
365 static inline void PushCatchFrame( StgClosure* handler )
368 /* ToDo: stack check! */
369 Sp -= sizeofW(StgCatchFrame*); /* ToDo: this can't be right */
370 fp = stgCast(StgCatchFrame*,Sp);
371 SET_HDR(fp,&catch_frame_info,CCCS);
372 fp->handler = handler;
374 Su = stgCast(StgUpdateFrame*,fp);
377 static inline void PopCatchFrame( void )
379 /* NB: doesn't assume that Sp == Su */
380 /* fprintf(stderr,"Popping catch frame\n"); */
381 Sp = stgCast(StgStackPtr,Su) + sizeofW(StgCatchFrame);
382 Su = stgCast(StgCatchFrame*,Su)->link;
385 static inline void PushSeqFrame( void )
388 /* ToDo: stack check! */
389 Sp -= sizeofW(StgSeqFrame*); /* ToDo: this can't be right */
390 fp = stgCast(StgSeqFrame*,Sp);
391 SET_HDR(fp,&seq_frame_info,CCCS);
393 Su = stgCast(StgUpdateFrame*,fp);
396 static inline void PopSeqFrame( void )
398 /* NB: doesn't assume that Sp == Su */
399 Sp = stgCast(StgStackPtr,Su) + sizeofW(StgSeqFrame);
400 Su = stgCast(StgSeqFrame*,Su)->link;
403 static inline StgClosure* raiseAnError( StgClosure* errObj )
406 switch (get_itbl(Su)->type) {
408 UPD_INPLACE1(Su->updatee,&raise_info,errObj);
409 Sp = stgCast(StgStackPtr,Su) + sizeofW(StgUpdateFrame);
415 case CATCH_FRAME: /* found it! */
417 StgCatchFrame* fp = stgCast(StgCatchFrame*,Su);
418 StgClosure *handler = fp->handler;
420 Sp += sizeofW(StgCatchFrame); /* Pop */
425 barf("raiseError: STOP_FRAME");
427 barf("raiseError: weird activation record");
432 static StgClosure* raisePrim(char* msg)
434 /* ToDo: figure out some way to turn the msg into a Haskell Exception
435 * Hack: we don't know how to build an Exception but we do know how
436 * to build a (recursive!) error object.
437 * The result isn't pretty but it's (slightly) better than nothing.
439 nat size = sizeof(StgClosure) + 1;
440 StgClosure* errObj = stgCast(StgClosure*,grabHpNonUpd(size));
441 SET_INFO(errObj,&raise_info);
442 errObj->payload[0] = errObj;
447 /* At the moment, I prefer to put it on stdout to make things as
448 * close to Hugs' old behaviour as possible.
450 fprintf(stdout, "Program error: %s", msg);
453 return raiseAnError(stgCast(StgClosure*,errObj));
456 #define raiseIndex(where) raisePrim("Array index out of range in " where)
457 #define raiseDiv0(where) raisePrim("Division by 0 in " where)
459 /* --------------------------------------------------------------------------
461 * ------------------------------------------------------------------------*/
465 unsigned char x = PopTaggedChar(); \
466 unsigned char y = PopTaggedChar(); \
472 unsigned char x = PopTaggedChar(); \
483 StgInt x = PopTaggedInt(); \
484 StgWord y = PopTaggedWord(); \
490 StgInt x = PopTaggedInt(); \
491 StgInt y = PopTaggedInt(); \
497 StgInt x = PopTaggedInt(); \
498 StgInt y = PopTaggedInt(); \
509 StgInt x = PopTaggedInt(); \
515 StgInt x = PopTaggedInt(); \
526 StgInt x = PopTaggedInt(); \
537 StgInt x = PopTaggedInt(); \
543 PushTaggedFloat(e); \
548 StgInt x = PopTaggedInt(); \
549 PushTaggedFloat(e); \
554 PushTaggedDouble(e); \
559 StgInt x = PopTaggedInt(); \
560 PushTaggedDouble(e); \
566 StgWord x = PopTaggedWord(); \
567 StgWord y = PopTaggedWord(); \
573 StgWord x = PopTaggedWord(); \
574 StgWord y = PopTaggedWord(); \
580 StgWord x = PopTaggedWord(); \
586 StgWord x = PopTaggedWord(); \
594 StgAddr x = PopTaggedAddr(); \
595 StgAddr y = PopTaggedAddr(); \
600 StgAddr x = PopTaggedAddr(); \
605 StgAddr x = PopTaggedAddr(); \
606 int y = PopTaggedInt(); \
613 StgAddr x = PopTaggedAddr(); \
614 int y = PopTaggedInt(); \
621 StgAddr x = PopTaggedAddr(); \
622 int y = PopTaggedInt(); \
625 PushTaggedInt64(r); \
629 StgAddr x = PopTaggedAddr(); \
630 int y = PopTaggedInt(); \
637 StgAddr x = PopTaggedAddr(); \
638 int y = PopTaggedInt(); \
641 PushTaggedFloat(r); \
645 StgAddr x = PopTaggedAddr(); \
646 int y = PopTaggedInt(); \
649 PushTaggedDouble(r); \
653 StgAddr x = PopTaggedAddr(); \
654 int y = PopTaggedInt(); \
657 PushTaggedStablePtr(r); \
661 StgAddr x = PopTaggedAddr(); \
662 int y = PopTaggedInt(); \
663 StgChar z = PopTaggedChar(); \
668 StgAddr x = PopTaggedAddr(); \
669 int y = PopTaggedInt(); \
670 StgInt z = PopTaggedInt(); \
675 StgAddr x = PopTaggedAddr(); \
676 int y = PopTaggedInt(); \
677 StgInt64 z = PopTaggedInt64(); \
682 StgAddr x = PopTaggedAddr(); \
683 int y = PopTaggedInt(); \
684 StgAddr z = PopTaggedAddr(); \
689 StgAddr x = PopTaggedAddr(); \
690 int y = PopTaggedInt(); \
691 StgFloat z = PopTaggedFloat(); \
696 StgAddr x = PopTaggedAddr(); \
697 int y = PopTaggedInt(); \
698 StgDouble z = PopTaggedDouble(); \
703 StgAddr x = PopTaggedAddr(); \
704 int y = PopTaggedInt(); \
705 StgStablePtr z = PopTaggedStablePtr(); \
709 #endif /* PROVIDE_ADDR */
713 StgFloat x = PopTaggedFloat(); \
714 StgFloat y = PopTaggedFloat(); \
720 StgFloat x = PopTaggedFloat(); \
721 StgFloat y = PopTaggedFloat(); \
722 PushTaggedFloat(e); \
727 StgFloat x = PopTaggedFloat(); \
728 PushTaggedFloat(e); \
733 StgFloat x = PopTaggedFloat(); \
739 StgFloat x = PopTaggedFloat(); \
745 StgFloat x = PopTaggedFloat(); \
746 PushTaggedDouble(e); \
751 StgDouble x = PopTaggedDouble(); \
752 StgDouble y = PopTaggedDouble(); \
758 StgDouble x = PopTaggedDouble(); \
759 StgDouble y = PopTaggedDouble(); \
760 PushTaggedDouble(e); \
765 StgDouble x = PopTaggedDouble(); \
771 StgDouble x = PopTaggedDouble(); \
772 PushTaggedDouble(e); \
777 StgDouble x = PopTaggedDouble(); \
783 StgDouble x = PopTaggedDouble(); \
784 PushTaggedFloat(e); \
790 StgInt64 x = PopTaggedInt64(); \
791 int y = PopTaggedInt(); \
792 PushTaggedFloat(e); \
796 StgInt64 x = PopTaggedInt64(); \
797 int y = PopTaggedInt(); \
798 PushTaggedDouble(e); \
802 StgInt64 x = PopTaggedInt64(); \
803 StgInt64 y = PopTaggedInt64(); \
808 StgInt64 x = PopTaggedInt64(); \
809 PushTaggedInt64(e); \
813 StgInt64 x = PopTaggedInt64(); \
814 StgInt64 y = PopTaggedInt64(); \
815 PushTaggedInt64(e); \
819 StgInt64 x = PopTaggedInt64(); \
820 StgWord y = PopTaggedWord(); \
821 PushTaggedInt64(e); \
823 #define OP_zz_zZ(e1,e2) \
825 StgInt64 x = PopTaggedInt64(); \
826 StgInt64 y = PopTaggedInt64(); \
827 PushTaggedInt64(e1); \
828 PushTaggedInt64(e2); \
832 StgInt64 x = PopTaggedInt64(); \
833 StgInt64 y = PopTaggedInt64(); \
838 PushTaggedInt64(e); \
842 StgInt64 x = PopTaggedInt64(); \
847 StgInt x = PopTaggedInt(); \
848 PushTaggedInt64(e); \
853 StgInt64 x = PopTaggedInt64(); \
858 StgWord x = PopTaggedWord(); \
859 PushTaggedInt64(e); \
864 StgInt64 x = PopTaggedInt64(); \
865 printf("%lld = %f\n",x,(float)(e)); \
866 PushTaggedFloat(e); \
870 StgFloat x = PopTaggedFloat(); \
871 PushTaggedInt64(e); \
875 StgInt64 x = PopTaggedInt64(); \
876 PushTaggedDouble(e); \
880 StgDouble x = PopTaggedDouble(); \
881 PushTaggedInt64(e); \
885 #ifdef PROVIDE_INTEGER
889 mpz_ptr x = PopTaggedInteger(); \
890 int y = PopTaggedInt(); \
891 PushTaggedFloat(e); \
895 StgFloat x = PopTaggedFloat(); \
896 mpz_ptr r1 = mpz_alloc(); \
900 PushTaggedInteger(r1); \
904 mpz_ptr x = PopTaggedInteger(); \
905 int y = PopTaggedInt(); \
906 PushTaggedDouble(e); \
910 StgDouble x = PopTaggedDouble(); \
911 mpz_ptr r1 = mpz_alloc(); \
915 PushTaggedInteger(r1); \
919 mpz_ptr x = PopTaggedInteger(); \
920 mpz_ptr r = mpz_alloc(); \
922 PushTaggedInteger(r); \
926 mpz_ptr x = PopTaggedInteger(); \
927 mpz_ptr y = PopTaggedInteger(); \
928 mpz_ptr r = mpz_alloc(); \
930 PushTaggedInteger(r); \
934 mpz_ptr x = PopTaggedInteger(); \
935 mpz_ptr y = PopTaggedInteger(); \
940 mpz_ptr x = PopTaggedInteger(); \
945 StgInt x = PopTaggedInt(); \
946 mpz_ptr r = mpz_alloc(); \
948 PushTaggedInteger(r); \
953 mpz_ptr x = PopTaggedInteger(); \
954 PushTaggedInt64(e); \
958 StgInt64 x = PopTaggedInt64(); \
959 mpz_ptr r = mpz_alloc(); \
961 PushTaggedInteger(r); \
967 mpz_ptr x = PopTaggedInteger(); \
972 StgWord x = PopTaggedWord(); \
973 mpz_ptr r = mpz_alloc(); \
975 PushTaggedInteger(r); \
980 mpz_ptr x = PopTaggedInteger(); \
981 PushTaggedFloat(e); \
985 StgFloat x = PopTaggedFloat(); \
986 mpz_ptr r = mpz_alloc(); \
988 PushTaggedInteger(r); \
992 mpz_ptr x = PopTaggedInteger(); \
993 PushTaggedDouble(e); \
997 StgDouble x = PopTaggedDouble(); \
998 mpz_ptr r = mpz_alloc(); \
1000 PushTaggedInteger(r); \
1003 #endif /* ifdef PROVIDE_INTEGER */
1005 #ifdef PROVIDE_ARRAY
1006 #define HEADER_mI(ty,where) \
1007 StgArrWords* x = stgCast(StgArrWords*,PopPtr()); \
1008 nat i = PopTaggedInt(); \
1009 if (i * sizeof(ty) + (sizeof(ty)) > sizeof(StgWord) * x->words) { \
1010 obj = raiseIndex(where); \
1013 #define OP_mI_ty(ty,where,s) \
1015 HEADER_mI(mycat2(Stg,ty),where) \
1016 { mycat2(Stg,ty) r; \
1018 mycat2(PushTagged,ty)(r); \
1021 #define OP_mIty_(ty,where,s) \
1023 HEADER_mI(mycat2(Stg,ty),where) \
1025 mycat2(Stg,ty) z = mycat2(PopTagged,ty)(); \
1030 #endif /* PROVIDE_ARRAY */
1033 /* This is written as one giant function in the hope that gcc will do
1034 * a better job of register allocation.
1036 StgThreadReturnCode enter( StgClosure* obj )
1038 /* We use a char so that we'll do a context_switch check every 256
1041 char enterCount = 0;
1043 /* ASSERT(StorageMgrInfo.hp_start <= Hp && Hp < HpLim && HpLim == StorageMgrInfo.hplim); */
1044 ASSERT(SpLim <= Sp && Sp <= stgCast(StgPtr,Su));
1047 fprintf(stderr,"Sp = %p\tSu = %p\n", Sp, Su);
1048 printStack(Sp,CurrentTSO->stack+CurrentTSO->stack_size,Su);
1049 fprintf(stderr,"Entering: "); printObj(obj);
1055 /*belch("Starting sanity check");
1057 *checkTSO(CurrentTSO, heap_step);
1058 * This check fails if we've done any updates because we
1059 * whack into holes in the heap.
1061 *belch("Ending sanity check");
1068 fprintf(stderr,"Continue?\n");
1072 if (++enterCount == 0 && context_switch) {
1073 PushCPtr(obj); /* code to restart with */
1074 return ThreadYielding;
1076 switch ( get_itbl(obj)->type ) {
1077 case INVALID_OBJECT:
1078 barf("Invalid object %p",obj);
1081 StgBCO* bco = stgCast(StgBCO*,obj);
1083 #if 1 /* We don't use an explicit HP_CHECK anymore */
1084 if (doYouWantToGC()) {
1085 PushCPtr(obj); /* code to restart with */
1086 return HeapOverflow;
1090 ASSERT(pc < bco->n_instrs);
1092 fprintf(stderr,"Sp = %p\tSu = %p\tpc = %d\t", Sp, Su, pc);
1094 /*fprintf(stderr,"\t"); printStackObj(Sp); */
1095 fprintf(stderr,"\n");
1097 switch (bcoInstr(bco,pc++)) {
1098 case i_INTERNAL_ERROR:
1099 barf("INTERNAL_ERROR at %p:%d",bco,pc-1);
1101 barf("PANIC at %p:%d",bco,pc-1);
1105 int n = bcoInstr(bco,pc++);
1106 /* ToDo: we could allocate the whole thing now and
1107 * slice it up ourselves
1109 if (doYouWantToGC()) {
1110 PushCPtr(obj); /* code to restart with */
1111 return HeapOverflow;
1118 int n = bcoInstr(bco,pc++);
1119 if (Sp - n < SpLim) {
1120 PushCPtr(obj); /* code to restart with */
1121 return StackOverflow;
1127 /* ToDo: make sure that hp check allows for possible PAP */
1128 nat n = bcoInstr(bco,pc++);
1129 if (stgCast(StgPtr,Sp + n) > stgCast(StgPtr,Su)) {
1130 StgWord words = (P_)Su - Sp;
1132 /* first build a PAP */
1133 ASSERT((P_)Su >= Sp); /* was (words >= 0) but that's always true */
1134 if (words == 0) { /* optimisation */
1135 /* Skip building the PAP and update with an indirection. */
1136 } else { /* Build the PAP. */
1137 /* In the evaluator, we avoid the need to do
1138 * a heap check here by including the size of
1139 * the PAP in the heap check we performed
1140 * when we entered the BCO.
1143 StgPAP* pap = stgCast(StgPAP*,grabHpNonUpd(PAP_sizeW(words)));
1144 SET_HDR(pap,&PAP_info,CC_pap);
1145 pap->n_args = words;
1147 for(i = 0; i < (I_)words; ++i) {
1148 payloadWord(pap,i) = Sp[i];
1151 obj = stgCast(StgClosure*,pap);
1154 /* now deal with "update frame" */
1155 /* as an optimisation, we process all on top of stack instead of just the top one */
1158 switch (get_itbl(Su)->type) {
1163 PopUpdateFrame(obj);
1167 return ThreadFinished;
1172 barf("Invalid update frame during argcheck");
1174 } while (Sp==(P_)Su);
1181 int words = bcoInstr(bco,pc++);
1182 PushPtr(grabHpUpd(AP_sizeW(words)));
1185 case i_ALLOC_CONSTR:
1187 StgInfoTable* info = bcoConstAddr(bco,bcoInstr(bco,pc++));
1188 StgClosure* c = stgCast(StgClosure*,grabHpNonUpd(sizeW_fromITBL(info)));
1190 PushPtr(stgCast(StgPtr,c));
1195 int x = bcoInstr(bco,pc++); /* ToDo: Word not Int! */
1196 int y = bcoInstr(bco,pc++);
1197 StgAP_UPD* o = stgCast(StgAP_UPD*,stackPtr(x));
1198 SET_HDR(o,&AP_UPD_info,??);
1200 o->fun = stgCast(StgClosure*,PopPtr());
1201 for(x=0; x < y; ++x) {
1202 payloadWord(o,x) = PopWord();
1205 fprintf(stderr,"\tBuilt ");
1206 printObj(stgCast(StgClosure*,o));
1212 int x = bcoInstr(bco,pc++);
1213 int y = bcoInstr(bco,pc++);
1214 StgPAP* o = stgCast(StgPAP*,stackPtr(x));
1215 SET_HDR(o,&PAP_info,??);
1217 o->fun = stgCast(StgClosure*,PopPtr());
1218 for(x=0; x < y; ++x) {
1219 payloadWord(o,x) = PopWord();
1222 fprintf(stderr,"\tBuilt ");
1223 printObj(stgCast(StgClosure*,o));
1229 int offset = bcoInstr(bco,pc++);
1230 StgClosure* o = stgCast(StgClosure*,stackPtr(offset));
1231 const StgInfoTable* info = get_itbl(o);
1232 nat p = info->layout.payload.ptrs;
1233 nat np = info->layout.payload.nptrs;
1235 for(i=0; i < p; ++i) {
1236 payloadCPtr(o,i) = PopCPtr();
1238 for(i=0; i < np; ++i) {
1239 payloadWord(o,p+i) = 0xdeadbeef;
1242 fprintf(stderr,"\tBuilt ");
1243 printObj(stgCast(StgClosure*,o));
1249 int x = bcoInstr(bco,pc++);
1250 int y = bcoInstr(bco,pc++);
1251 ASSERT(Sp+x+y <= stgCast(StgPtr,Su));
1252 /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
1254 setStackWord(x+y,stackWord(x));
1266 PushPtr(bcoConstPtr(bco,bcoInstr(bco,pc++)));
1267 PushPtr(stgCast(StgPtr,&ret_bco_info));
1272 int tag = bcoInstr(bco,pc++);
1273 StgWord offset = bcoInstr(bco,pc++);
1274 if (constrTag(stgCast(StgClosure*,stackPtr(0))) != tag) {
1281 StgClosure* o = stgCast(StgClosure*,stackPtr(0));
1282 const StgInfoTable* itbl = get_itbl(o);
1283 int i = itbl->layout.payload.ptrs;
1284 ASSERT( itbl->type == CONSTR
1285 || itbl->type == CONSTR_STATIC
1286 || itbl->type == CONSTR_NOCAF_STATIC
1289 PushCPtr(payloadCPtr(o,i));
1295 PushPtr(stackPtr(bcoInstr(bco,pc++)));
1300 PushPtr(stgCast(StgPtr,bcoConstPtr(bco,bcoInstr(bco,pc++))));
1305 StgWord o1 = bcoInstr(bco,pc++);
1306 StgWord o2 = bcoInstr(bco,pc++);
1307 StgWord o = o1*256 + o2;
1308 PushPtr(stgCast(StgPtr,bcoConstPtr(bco,o)));
1313 PushTaggedRealWorld();
1318 PushTaggedInt(taggedStackInt(bcoInstr(bco,pc++)));
1323 PushTaggedInt(bcoConstInt(bco,bcoInstr(bco,pc++)));
1333 StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(IZh_sizeW));
1334 SET_HDR(o,&IZh_con_info,??);
1335 payloadWord(o,0) = PopTaggedInt();
1337 fprintf(stderr,"\tBuilt ");
1338 printObj(stgCast(StgClosure*,o));
1340 PushPtr(stgCast(StgPtr,o));
1345 StgClosure* con = stgCast(StgClosure*,stackPtr(0));
1346 /* ASSERT(isIntLike(con)); */
1347 PushTaggedInt(payloadWord(con,0));
1352 StgWord offset = bcoInstr(bco,pc++);
1353 StgInt x = PopTaggedInt();
1354 StgInt y = PopTaggedInt();
1360 #ifdef PROVIDE_INT64
1363 PushTaggedInt64(taggedStackInt64(bcoInstr(bco,pc++)));
1368 PushTaggedInt64(bcoConstInt64(bco,bcoInstr(bco,pc++)));
1371 case i_RETURN_INT64:
1373 ASSERT(0); /* ToDo(); */
1378 StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(I64Zh_sizeW));
1379 SET_HDR(o,&I64Zh_con_info,??);
1380 ASSIGN_Int64(&payloadWord(o,0),PopTaggedInt64());
1382 fprintf(stderr,"\tBuilt ");
1383 printObj(stgCast(StgClosure*,o));
1385 PushPtr(stgCast(StgPtr,o));
1388 case i_UNPACK_INT64:
1390 StgClosure* con = stgCast(StgClosure*,stackPtr(0));
1391 /*ASSERT(isInt64Like(con)); */
1392 PushTaggedInt64(PK_Int64(&payloadWord(con,0)));
1396 #ifdef PROVIDE_INTEGER
1397 case i_CONST_INTEGER:
1399 char* s = bcoConstAddr(bco,bcoInstr(bco,pc++));
1400 mpz_ptr r = mpz_alloc();
1401 if (s[0] == '0' && s[1] == 'x') {
1402 mpz_set_str(r,s+2,16);
1404 mpz_set_str(r,s,10);
1406 PushTaggedInteger(r);
1414 PushTaggedWord(taggedStackWord(bcoInstr(bco,pc++)));
1419 PushTaggedWord(bcoConstWord(bco,bcoInstr(bco,pc++)));
1429 StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(WZh_sizeW));
1431 SET_HDR(o,&WZh_con_info,??);
1432 payloadWord(o,0) = PopTaggedWord();
1434 fprintf(stderr,"\tBuilt ");
1435 printObj(stgCast(StgClosure*,o));
1437 PushPtr(stgCast(StgPtr,o));
1442 StgClosure* con = stgCast(StgClosure*,stackPtr(0));
1443 /* ASSERT(isWordLike(con)); */
1444 PushTaggedWord(payloadWord(con,0));
1451 PushTaggedAddr(taggedStackAddr(bcoInstr(bco,pc++)));
1456 PushTaggedAddr(bcoConstAddr(bco,bcoInstr(bco,pc++)));
1466 StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(AZh_sizeW));
1467 SET_HDR(o,&AZh_con_info,??);
1468 payloadPtr(o,0) = PopTaggedAddr();
1470 fprintf(stderr,"\tBuilt ");
1471 printObj(stgCast(StgClosure*,o));
1473 PushPtr(stgCast(StgPtr,o));
1478 StgClosure* con = stgCast(StgClosure*,stackPtr(0));
1479 /* ASSERT(isAddrLike(con)); */
1480 PushTaggedAddr(payloadPtr(con,0));
1486 PushTaggedChar(taggedStackChar(bcoInstr(bco,pc++)));
1491 PushTaggedChar(bcoConstChar(bco,bcoInstr(bco,pc++)));
1501 StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(CZh_sizeW));
1502 SET_HDR(o,&CZh_con_info,??);
1503 payloadWord(o,0) = PopTaggedChar();
1504 PushPtr(stgCast(StgPtr,o));
1506 fprintf(stderr,"\tBuilt ");
1507 printObj(stgCast(StgClosure*,o));
1513 StgClosure* con = stgCast(StgClosure*,stackPtr(0));
1514 /* ASSERT(isCharLike(con)); */
1515 PushTaggedChar(payloadWord(con,0));
1520 PushTaggedFloat(taggedStackFloat(bcoInstr(bco,pc++)));
1525 PushTaggedFloat(bcoConstFloat(bco,bcoInstr(bco,pc++)));
1528 case i_RETURN_FLOAT:
1535 StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(FZh_sizeW));
1536 SET_HDR(o,&FZh_con_info,??);
1537 ASSIGN_FLT(&payloadWord(o,0),PopTaggedFloat());
1539 fprintf(stderr,"\tBuilt ");
1540 printObj(stgCast(StgClosure*,o));
1542 PushPtr(stgCast(StgPtr,o));
1545 case i_UNPACK_FLOAT:
1547 StgClosure* con = stgCast(StgClosure*,stackPtr(0));
1548 /* ASSERT(isFloatLike(con)); */
1549 PushTaggedFloat(PK_FLT(&payloadWord(con,0)));
1554 PushTaggedDouble(taggedStackDouble(bcoInstr(bco,pc++)));
1557 case i_CONST_DOUBLE:
1559 PushTaggedDouble(bcoConstDouble(bco,bcoInstr(bco,pc++)));
1562 case i_RETURN_DOUBLE:
1569 StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(DZh_sizeW));
1570 SET_HDR(o,&DZh_con_info,??);
1571 ASSIGN_DBL(&payloadWord(o,0),PopTaggedDouble());
1573 fprintf(stderr,"\tBuilt ");
1574 printObj(stgCast(StgClosure*,o));
1576 PushPtr(stgCast(StgPtr,o));
1579 case i_UNPACK_DOUBLE:
1581 StgClosure* con = stgCast(StgClosure*,stackPtr(0));
1582 /* ASSERT(isDoubleLike(con)); */
1583 PushTaggedDouble(PK_DBL(&payloadWord(con,0)));
1586 #ifdef PROVIDE_STABLE
1589 PushTaggedStablePtr(taggedStackStable(bcoInstr(bco,pc++)));
1592 case i_RETURN_STABLE:
1599 StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(StableZh_sizeW));
1600 SET_HDR(o,&StablePtr_con_info,??);
1601 payloadWord(o,0) = PopTaggedStablePtr();
1603 fprintf(stderr,"\tBuilt ");
1604 printObj(stgCast(StgClosure*,o));
1606 PushPtr(stgCast(StgPtr,o));
1609 case i_UNPACK_STABLE:
1611 StgClosure* con = stgCast(StgClosure*,stackPtr(0));
1612 /* ASSERT(isStableLike(con)); */
1613 PushTaggedStablePtr(payloadWord(con,0));
1619 switch (bcoInstr(bco,pc++)) {
1620 case i_INTERNAL_ERROR1:
1621 barf("INTERNAL_ERROR1 at %p:%d",bco,pc-1);
1623 case i_gtChar: OP_CC_B(x>y); break;
1624 case i_geChar: OP_CC_B(x>=y); break;
1625 case i_eqChar: OP_CC_B(x==y); break;
1626 case i_neChar: OP_CC_B(x!=y); break;
1627 case i_ltChar: OP_CC_B(x<y); break;
1628 case i_leChar: OP_CC_B(x<=y); break;
1629 case i_charToInt: OP_C_I(x); break;
1630 case i_intToChar: OP_I_C(x); break;
1632 case i_gtInt: OP_II_B(x>y); break;
1633 case i_geInt: OP_II_B(x>=y); break;
1634 case i_eqInt: OP_II_B(x==y); break;
1635 case i_neInt: OP_II_B(x!=y); break;
1636 case i_ltInt: OP_II_B(x<y); break;
1637 case i_leInt: OP_II_B(x<=y); break;
1638 case i_minInt: OP__I(INT_MIN); break;
1639 case i_maxInt: OP__I(INT_MAX); break;
1640 case i_plusInt: OP_II_I(x+y); break;
1641 case i_minusInt: OP_II_I(x-y); break;
1642 case i_timesInt: OP_II_I(x*y); break;
1645 int x = PopTaggedInt();
1646 int y = PopTaggedInt();
1648 obj = raiseDiv0("quotInt");
1651 /* ToDo: protect against minInt / -1 errors
1652 * (repeat for all other division primops)
1659 int x = PopTaggedInt();
1660 int y = PopTaggedInt();
1662 obj = raiseDiv0("remInt");
1670 StgInt x = PopTaggedInt();
1671 StgInt y = PopTaggedInt();
1673 obj = raiseDiv0("quotRemInt");
1676 PushTaggedInt(x%y); /* last result */
1677 PushTaggedInt(x/y); /* first result */
1680 case i_negateInt: OP_I_I(-x); break;
1682 case i_andInt: OP_II_I(x&y); break;
1683 case i_orInt: OP_II_I(x|y); break;
1684 case i_xorInt: OP_II_I(x^y); break;
1685 case i_notInt: OP_I_I(~x); break;
1686 case i_shiftLInt: OP_IW_I(x<<y); break;
1687 case i_shiftRAInt: OP_IW_I(x>>y); break; /* ToDo */
1688 case i_shiftRLInt: OP_IW_I(x>>y); break; /* ToDo */
1690 #ifdef PROVIDE_INT64
1691 case i_gtInt64: OP_zz_B(x>y); break;
1692 case i_geInt64: OP_zz_B(x>=y); break;
1693 case i_eqInt64: OP_zz_B(x==y); break;
1694 case i_neInt64: OP_zz_B(x!=y); break;
1695 case i_ltInt64: OP_zz_B(x<y); break;
1696 case i_leInt64: OP_zz_B(x<=y); break;
1697 case i_minInt64: OP__z(0x800000000000LL); break;
1698 case i_maxInt64: OP__z(0x7fffffffffffLL); break;
1699 case i_plusInt64: OP_zz_z(x+y); break;
1700 case i_minusInt64: OP_zz_z(x-y); break;
1701 case i_timesInt64: OP_zz_z(x*y); break;
1704 StgInt64 x = PopTaggedInt64();
1705 StgInt64 y = PopTaggedInt64();
1707 obj = raiseDiv0("quotInt64");
1710 /* ToDo: protect against minInt64 / -1 errors
1711 * (repeat for all other division primops)
1713 PushTaggedInt64(x/y);
1718 StgInt64 x = PopTaggedInt64();
1719 StgInt64 y = PopTaggedInt64();
1721 obj = raiseDiv0("remInt64");
1724 PushTaggedInt64(x%y);
1727 case i_quotRemInt64:
1729 StgInt64 x = PopTaggedInt64();
1730 StgInt64 y = PopTaggedInt64();
1732 obj = raiseDiv0("quotRemInt64");
1735 PushTaggedInt64(x%y); /* last result */
1736 PushTaggedInt64(x/y); /* first result */
1739 case i_negateInt64: OP_z_z(-x); break;
1741 case i_andInt64: OP_zz_z(x&y); break;
1742 case i_orInt64: OP_zz_z(x|y); break;
1743 case i_xorInt64: OP_zz_z(x^y); break;
1744 case i_notInt64: OP_z_z(~x); break;
1745 case i_shiftLInt64: OP_zW_z(x<<y); break;
1746 case i_shiftRAInt64: OP_zW_z(x>>y); break; /* ToDo */
1747 case i_shiftRLInt64: OP_zW_z(x>>y); break; /* ToDo */
1749 case i_int64ToInt: OP_z_I(x); break;
1750 case i_intToInt64: OP_I_z(x); break;
1752 case i_int64ToWord: OP_z_W(x); break;
1753 case i_wordToInt64: OP_W_z(x); break;
1755 case i_int64ToFloat: OP_z_F(x); break;
1756 case i_floatToInt64: OP_F_z(x); break;
1757 case i_int64ToDouble: OP_z_D(x); break;
1758 case i_doubleToInt64: OP_D_z(x); break;
1761 case i_gtWord: OP_WW_B(x>y); break;
1762 case i_geWord: OP_WW_B(x>=y); break;
1763 case i_eqWord: OP_WW_B(x==y); break;
1764 case i_neWord: OP_WW_B(x!=y); break;
1765 case i_ltWord: OP_WW_B(x<y); break;
1766 case i_leWord: OP_WW_B(x<=y); break;
1767 case i_minWord: OP__W(0); break;
1768 case i_maxWord: OP__W(UINT_MAX); break;
1769 case i_plusWord: OP_WW_W(x+y); break;
1770 case i_minusWord: OP_WW_W(x-y); break;
1771 case i_timesWord: OP_WW_W(x*y); break;
1774 StgWord x = PopTaggedWord();
1775 StgWord y = PopTaggedWord();
1777 obj = raiseDiv0("quotWord");
1780 PushTaggedWord(x/y);
1785 StgWord x = PopTaggedWord();
1786 StgWord y = PopTaggedWord();
1788 obj = raiseDiv0("remWord");
1791 PushTaggedWord(x%y);
1796 StgWord x = PopTaggedWord();
1797 StgWord y = PopTaggedWord();
1799 obj = raiseDiv0("quotRemWord");
1802 PushTaggedWord(x%y); /* last result */
1803 PushTaggedWord(x/y); /* first result */
1806 case i_negateWord: OP_W_W(-x); break;
1807 case i_andWord: OP_WW_W(x&y); break;
1808 case i_orWord: OP_WW_W(x|y); break;
1809 case i_xorWord: OP_WW_W(x^y); break;
1810 case i_notWord: OP_W_W(~x); break;
1811 case i_shiftLWord: OP_WW_W(x<<y); break;
1812 case i_shiftRAWord: OP_WW_W(x>>y); break; /* ToDo */
1813 case i_shiftRLWord: OP_WW_W(x>>y); break; /* ToDo */
1814 case i_intToWord: OP_I_W(x); break;
1815 case i_wordToInt: OP_W_I(x); break;
1818 case i_gtAddr: OP_AA_B(x>y); break;
1819 case i_geAddr: OP_AA_B(x>=y); break;
1820 case i_eqAddr: OP_AA_B(x==y); break;
1821 case i_neAddr: OP_AA_B(x!=y); break;
1822 case i_ltAddr: OP_AA_B(x<y); break;
1823 case i_leAddr: OP_AA_B(x<=y); break;
1824 case i_intToAddr: OP_I_A((StgAddr)x); break; /* ToDo */
1825 case i_addrToInt: OP_A_I((StgInt)x); break; /* ToDo */
1827 case i_indexCharOffAddr: OP_AI_C(indexCharOffAddrZh(r,x,y)); break;
1828 case i_readCharOffAddr: OP_AI_C(indexCharOffAddrZh(r,x,y)); break;
1829 case i_writeCharOffAddr: OP_AIC_(writeCharOffAddrZh(x,y,z)); break;
1831 case i_indexIntOffAddr: OP_AI_I(indexIntOffAddrZh(r,x,y)); break;
1832 case i_readIntOffAddr: OP_AI_I(indexIntOffAddrZh(r,x,y)); break;
1833 case i_writeIntOffAddr: OP_AII_(writeIntOffAddrZh(x,y,z)); break;
1834 #ifdef PROVIDE_INT64
1835 case i_indexInt64OffAddr: OP_AI_z(indexInt64OffAddrZh(r,x,y)); break;
1836 case i_readInt64OffAddr: OP_AI_z(indexInt64OffAddrZh(r,x,y)); break;
1837 case i_writeInt64OffAddr: OP_AIz_(writeInt64OffAddrZh(x,y,z)); break;
1840 case i_indexAddrOffAddr: OP_AI_A(indexAddrOffAddrZh(r,x,y)); break;
1841 case i_readAddrOffAddr: OP_AI_A(indexAddrOffAddrZh(r,x,y)); break;
1842 case i_writeAddrOffAddr: OP_AIA_(writeAddrOffAddrZh(x,y,z)); break;
1844 case i_indexFloatOffAddr: OP_AI_F(indexFloatOffAddrZh(r,x,y)); break;
1845 case i_readFloatOffAddr: OP_AI_F(indexFloatOffAddrZh(r,x,y)); break;
1846 case i_writeFloatOffAddr: OP_AIF_(writeFloatOffAddrZh(x,y,z)); break;
1848 case i_indexDoubleOffAddr: OP_AI_D(indexDoubleOffAddrZh(r,x,y)); break;
1849 case i_readDoubleOffAddr: OP_AI_D(indexDoubleOffAddrZh(r,x,y)); break;
1850 case i_writeDoubleOffAddr: OP_AID_(writeDoubleOffAddrZh(x,y,z)); break;
1852 #ifdef PROVIDE_STABLE
1853 case i_indexStableOffAddr: OP_AI_s(indexStablePtrOffAddrZh(r,x,y)); break;
1854 case i_readStableOffAddr: OP_AI_s(indexStablePtrOffAddrZh(r,x,y)); break;
1855 case i_writeStableOffAddr: OP_AIs_(writeStablePtrOffAddrZh(x,y,z)); break;
1858 #endif /* PROVIDE_ADDR */
1860 #ifdef PROVIDE_INTEGER
1861 case i_compareInteger:
1863 mpz_ptr x = PopTaggedInteger();
1864 mpz_ptr y = PopTaggedInteger();
1865 StgInt r = mpz_cmp(x,y);
1866 PushTaggedInt(r<0 ? -1 : (r>0 ? 1 : 0));
1869 case i_negateInteger: OP_Z_Z(mpz_neg(r,x)); break;
1870 case i_plusInteger: OP_ZZ_Z(mpz_add(r,x,y)); break;
1871 case i_minusInteger: OP_ZZ_Z(mpz_sub(r,x,y)); break;
1872 case i_timesInteger: OP_ZZ_Z(mpz_mul(r,x,y)); break;
1873 case i_quotRemInteger:
1875 mpz_ptr x = PopTaggedInteger();
1876 mpz_ptr y = PopTaggedInteger();
1877 mpz_ptr q = mpz_alloc();
1878 mpz_ptr r = mpz_alloc();
1879 if (mpz_sgn(y) == 0) {
1880 obj = raiseDiv0("quotRemInteger");
1883 mpz_tdiv_qr(q,r,x,y);
1884 PushTaggedInteger(r); /* last result */
1885 PushTaggedInteger(q); /* first result */
1888 case i_divModInteger:
1890 mpz_ptr x = PopTaggedInteger();
1891 mpz_ptr y = PopTaggedInteger();
1892 mpz_ptr q = mpz_alloc();
1893 mpz_ptr r = mpz_alloc();
1894 if (mpz_sgn(y) == 0) {
1895 obj = raiseDiv0("divModInteger");
1898 mpz_fdiv_qr(q,r,x,y);
1899 PushTaggedInteger(r); /* last result */
1900 PushTaggedInteger(q); /* first result */
1903 case i_integerToInt: OP_Z_I(mpz_get_si(x)); break;
1904 case i_intToInteger: OP_I_Z(mpz_set_si(r,x)); break;
1905 #ifdef PROVIDE_INT64
1906 case i_integerToInt64: OP_Z_z(mpz_get_si(x)); break;
1907 case i_int64ToInteger: OP_z_Z(mpz_set_si(r,x)); break;
1910 /* NB Use of mpz_get_si is quite deliberate since otherwise
1911 * -255 is converted to 255.
1913 case i_integerToWord: OP_Z_W(mpz_get_si(x)); break;
1914 case i_wordToInteger: OP_W_Z(mpz_set_ui(r,x)); break;
1916 case i_integerToFloat: OP_Z_F(mpz_get_d(x)); break;
1917 case i_floatToInteger: OP_F_Z(mpz_set_d(r,x)); break;
1918 case i_integerToDouble: OP_Z_D(mpz_get_d(x)); break;
1919 case i_doubleToInteger: OP_D_Z(mpz_set_d(r,x)); break;
1920 #endif /* PROVIDE_INTEGER */
1922 case i_gtFloat: OP_FF_B(x>y); break;
1923 case i_geFloat: OP_FF_B(x>=y); break;
1924 case i_eqFloat: OP_FF_B(x==y); break;
1925 case i_neFloat: OP_FF_B(x!=y); break;
1926 case i_ltFloat: OP_FF_B(x<y); break;
1927 case i_leFloat: OP_FF_B(x<=y); break;
1928 case i_minFloat: OP__F(FLT_MIN); break;
1929 case i_maxFloat: OP__F(FLT_MAX); break;
1930 case i_radixFloat: OP__I(FLT_RADIX); break;
1931 case i_digitsFloat: OP__I(FLT_MANT_DIG); break;
1932 case i_minExpFloat: OP__I(FLT_MIN_EXP); break;
1933 case i_maxExpFloat: OP__I(FLT_MAX_EXP); break;
1934 case i_plusFloat: OP_FF_F(x+y); break;
1935 case i_minusFloat: OP_FF_F(x-y); break;
1936 case i_timesFloat: OP_FF_F(x*y); break;
1939 StgFloat x = PopTaggedFloat();
1940 StgFloat y = PopTaggedFloat();
1943 obj = raiseDiv0("divideFloat");
1947 PushTaggedFloat(x/y);
1950 case i_negateFloat: OP_F_F(-x); break;
1951 case i_floatToInt: OP_F_I(x); break;
1952 case i_intToFloat: OP_I_F(x); break;
1953 case i_expFloat: OP_F_F(exp(x)); break;
1954 case i_logFloat: OP_F_F(log(x)); break;
1955 case i_sqrtFloat: OP_F_F(sqrt(x)); break;
1956 case i_sinFloat: OP_F_F(sin(x)); break;
1957 case i_cosFloat: OP_F_F(cos(x)); break;
1958 case i_tanFloat: OP_F_F(tan(x)); break;
1959 case i_asinFloat: OP_F_F(asin(x)); break;
1960 case i_acosFloat: OP_F_F(acos(x)); break;
1961 case i_atanFloat: OP_F_F(atan(x)); break;
1962 case i_sinhFloat: OP_F_F(sinh(x)); break;
1963 case i_coshFloat: OP_F_F(cosh(x)); break;
1964 case i_tanhFloat: OP_F_F(tanh(x)); break;
1965 case i_powerFloat: OP_FF_F(pow(x,y)); break;
1967 #ifdef PROVIDE_INT64
1968 /* Based on old Hugs code */
1969 /* ToDo: use ~/fptools/ghc/runtime/prims/PrimArith.lc */
1970 case i_encodeFloatz: OP_zI_F(ldexp(x,y)); break;
1971 case i_decodeFloatz:
1973 /* ToDo: this code is known to give very approximate results
1974 * (even when StgInt64 overflow doesn't occur)
1976 double f0 = PopTaggedFloat();
1978 double f1 = frexp((double)(f0),&n); /* 0.5 <= f1 < 1 */
1979 double f2 = ldexp(f1,FLT_MANT_DIG); /* 2^m-1 <= f2 < 2^m, m=FLT_MANT_DIG */
1980 PushTaggedInt(n-FLT_MANT_DIG);
1981 PushTaggedInt64((StgInt64)f2);
1982 #if 1 /* paranoia */
1983 if (ldexp((StgInt64)f2,n-FLT_MANT_DIG) != f0) {
1984 fprintf(stderr,"*** primDecodeFloat mismatch: %.10f != %.10f\n",
1985 ldexp((StgInt64)f2,n-FLT_MANT_DIG),f0);
1990 #endif /* PROVIDE_INT64 */
1991 #ifdef PROVIDE_INTEGER
1992 case i_encodeFloatZ: OP_ZI_F(__encodeFloat(x,y)); break;
1993 case i_decodeFloatZ: OP_F_ZI(__decodeFloat(r1,&r2,x)); break;
1995 case i_isNaNFloat: OP_F_B(isFloatNaN(x)); break;
1996 case i_isInfiniteFloat: OP_F_B(isFloatInfinite(x)); break;
1997 case i_isNegativeZeroFloat: OP_F_B(isFloatNegativeZero(x)); break;
1998 case i_isDenormalizedFloat: OP_F_B(isFloatDenormalized(x)); break;
1999 case i_gtDouble: OP_DD_B(x>y); break;
2000 case i_geDouble: OP_DD_B(x>=y); break;
2001 case i_eqDouble: OP_DD_B(x==y); break;
2002 case i_neDouble: OP_DD_B(x!=y); break;
2003 case i_ltDouble: OP_DD_B(x<y); break;
2004 case i_leDouble: OP_DD_B(x<=y) break;
2005 case i_minDouble: OP__D(DBL_MIN); break;
2006 case i_maxDouble: OP__D(DBL_MAX); break;
2007 case i_radixDouble: OP__I(FLT_RADIX); break;
2008 case i_digitsDouble: OP__I(DBL_MANT_DIG); break;
2009 case i_minExpDouble: OP__I(DBL_MIN_EXP); break;
2010 case i_maxExpDouble: OP__I(DBL_MAX_EXP); break;
2011 case i_plusDouble: OP_DD_D(x+y); break;
2012 case i_minusDouble: OP_DD_D(x-y); break;
2013 case i_timesDouble: OP_DD_D(x*y); break;
2014 case i_divideDouble:
2016 StgDouble x = PopTaggedDouble();
2017 StgDouble y = PopTaggedDouble();
2020 obj = raiseDiv0("divideDouble");
2024 PushTaggedDouble(x/y);
2027 case i_negateDouble: OP_D_D(-x); break;
2028 case i_doubleToInt: OP_D_I(x); break;
2029 case i_intToDouble: OP_I_D(x); break;
2030 case i_doubleToFloat: OP_D_F(x); break;
2031 case i_floatToDouble: OP_F_F(x); break;
2032 case i_expDouble: OP_D_D(exp(x)); break;
2033 case i_logDouble: OP_D_D(log(x)); break;
2034 case i_sqrtDouble: OP_D_D(sqrt(x)); break;
2035 case i_sinDouble: OP_D_D(sin(x)); break;
2036 case i_cosDouble: OP_D_D(cos(x)); break;
2037 case i_tanDouble: OP_D_D(tan(x)); break;
2038 case i_asinDouble: OP_D_D(asin(x)); break;
2039 case i_acosDouble: OP_D_D(acos(x)); break;
2040 case i_atanDouble: OP_D_D(atan(x)); break;
2041 case i_sinhDouble: OP_D_D(sinh(x)); break;
2042 case i_coshDouble: OP_D_D(cosh(x)); break;
2043 case i_tanhDouble: OP_D_D(tanh(x)); break;
2044 case i_powerDouble: OP_DD_D(pow(x,y)); break;
2045 #ifdef PROVIDE_INT64
2046 case i_encodeDoublez: OP_zI_D(ldexp(x,y)); break;
2047 case i_decodeDoublez:
2049 /* ToDo: this code is known to give very approximate results
2050 * (even when StgInt64 overflow doesn't occur)
2052 double f0 = PopTaggedDouble();
2054 double f1 = frexp((double)(f0),&n); /* 0.5 <= f1 < 1 */
2055 double f2 = ldexp(f1,FLT_MANT_DIG); /* 2^m-1 <= f2 < 2^m, m=FLT_MANT_DIG */
2056 PushTaggedInt(n-FLT_MANT_DIG);
2057 PushTaggedInt64((StgInt64)f2);
2058 #if 1 /* paranoia */
2059 if (ldexp((StgInt64)f2,n-FLT_MANT_DIG) != f0) {
2060 fprintf(stderr,"*** primDecodeDouble mismatch: %.10f != %.10f\n",
2061 ldexp((StgInt64)f2,n-FLT_MANT_DIG),f0);
2066 #endif /* PROVIDE_INT64 */
2067 #ifdef PROVIDE_INTEGER
2068 case i_encodeDoubleZ: OP_ZI_D(__encodeDouble(x,y)); break;
2069 case i_decodeDoubleZ: OP_D_ZI(__decodeDouble(r1,&r2,x)); break;
2070 #endif /* PROVIDE_INTEGER */
2071 case i_isNaNDouble: OP_D_B(isDoubleNaN(x)); break;
2072 case i_isInfiniteDouble: OP_D_B(isDoubleInfinite(x)); break;
2073 case i_isNegativeZeroDouble: OP_D_B(isDoubleNegativeZero(x)); break;
2074 case i_isDenormalizedDouble: OP_D_B(isDoubleDenormalized(x)); break;
2075 case i_isIEEEDouble:
2077 PushTaggedBool(rtsTrue);
2081 barf("Unrecognised primop1");
2087 switch (bcoInstr(bco,pc++)) {
2088 case i_INTERNAL_ERROR2:
2089 barf("INTERNAL_ERROR2 at %p:%d",bco,pc-1);
2090 case i_catch: /* catch#{e,h} */
2096 /* catch suffers the same problem as takeMVar:
2097 * it tries to do control flow even if it isn't
2098 * the last instruction in the BCO.
2099 * This can leave a mess on the stack if the
2100 * last instructions are anything important
2101 * like SLIDE. Our vile hack depends on the
2102 * fact that with the current code generator,
2103 * we know exactly that i_catch is followed
2104 * by code that drops 2 variables off the
2113 case i_raise: /* raise#{err} */
2115 StgClosure* err = PopCPtr();
2116 obj = raiseAnError(err);
2119 case i_force: /* force#{x} (evaluate x, primreturn nothing) */
2124 /* force suffers the same problem as takeMVar:
2125 * it tries to do control flow even if it isn't
2126 * the last instruction in the BCO.
2127 * This can leave a mess on the stack if the
2128 * last instructions are anything important
2129 * like SLIDE. Our vile hack depends on the
2130 * fact that with the current code generator,
2131 * we know exactly that i_force is followed
2132 * by code that drops 1 variable off the stack.
2140 #ifdef PROVIDE_ARRAY
2143 StgClosure* init = PopCPtr();
2145 = stgCast(StgMutVar*,allocate(sizeofW(StgMutVar)));
2146 SET_HDR(mv,&MUT_VAR_info,CCCS);
2148 PushPtr(stgCast(StgPtr,mv));
2153 StgMutVar* mv = stgCast(StgMutVar*,PopPtr());
2159 StgMutVar* mv = stgCast(StgMutVar*,PopPtr());
2160 StgClosure* value = PopCPtr();
2166 nat n = PopTaggedInt(); /* or Word?? */
2167 StgClosure* init = PopCPtr();
2168 StgWord size = sizeofW(StgArrPtrs) + n;
2171 = stgCast(StgArrPtrs*,allocate(size));
2172 SET_HDR(arr,&MUT_ARR_PTRS_info,CCCS);
2174 for (i = 0; i < n; ++i) {
2175 arr->payload[i] = init;
2177 PushPtr(stgCast(StgPtr,arr));
2183 StgArrPtrs* arr = stgCast(StgArrPtrs*,PopPtr());
2184 nat i = PopTaggedInt(); /* or Word?? */
2185 StgWord n = arr->ptrs;
2187 obj = raiseIndex("{index,read}Array");
2190 PushCPtr(arr->payload[i]);
2195 StgArrPtrs* arr = stgCast(StgArrPtrs*,PopPtr());
2196 nat i = PopTaggedInt(); /* or Word? */
2197 StgClosure* v = PopCPtr();
2198 StgWord n = arr->ptrs;
2200 obj = raiseIndex("{index,read}Array");
2203 arr->payload[i] = v;
2207 case i_sizeMutableArray:
2209 StgArrPtrs* arr = stgCast(StgArrPtrs*,PopPtr());
2210 PushTaggedInt(arr->ptrs);
2213 case i_unsafeFreezeArray:
2215 StgArrPtrs* arr = stgCast(StgArrPtrs*,PopPtr());
2216 SET_INFO(arr,&MUT_ARR_PTRS_FROZEN_info);
2217 PushPtr(stgCast(StgPtr,arr));
2220 case i_unsafeFreezeByteArray:
2222 /* Delightfully simple :-) */
2226 case i_sameMutableArray:
2227 case i_sameMutableByteArray:
2229 StgPtr x = PopPtr();
2230 StgPtr y = PopPtr();
2231 PushTaggedBool(x==y);
2235 case i_newByteArray:
2237 nat n = PopTaggedInt(); /* or Word?? */
2238 StgInt words = (n+sizeof(W_)-1)/sizeof(W_);
2239 StgWord size = sizeofW(StgArrWords) + words;
2241 StgArrWords* arr = stgCast(StgArrWords*,allocate(size));
2242 SET_HDR(arr,&MUT_ARR_WORDS_info,CCCS);
2245 for (i = 0; i < n; ++i) {
2246 arr->payload[i] = 0xdeadbeef;
2249 PushPtr(stgCast(StgPtr,arr));
2253 /* Most of these generate alignment warnings on Sparcs and similar architectures.
2254 * These are harmless and are caused by the cast to C* in BYTE_ARR_CTS.
2256 case i_indexCharArray: OP_mI_ty(Char,"indexCharArray", indexCharArrayZh(r,x,i)); break;
2257 case i_readCharArray: OP_mI_ty(Char,"readCharArray", readCharArrayZh(r,x,i)); break;
2258 case i_writeCharArray: OP_mIty_(Char,"writeCharArray", writeCharArrayZh(x,i,z)); break;
2260 case i_indexIntArray: OP_mI_ty(Int,"indexIntArray", indexIntArrayZh(r,x,i)); break;
2261 case i_readIntArray: OP_mI_ty(Int,"readIntArray", readIntArrayZh(r,x,i)); break;
2262 case i_writeIntArray: OP_mIty_(Int,"writeIntArray", writeIntArrayZh(x,i,z)); break;
2263 #ifdef PROVIDE_INT64
2264 case i_indexInt64Array: OP_mI_ty(Int64,"indexInt64Array", indexInt64ArrayZh(r,x,i)); break;
2265 case i_readInt64Array: OP_mI_ty(Int64,"readInt64Array", readInt64ArrayZh(r,x,i)); break;
2266 case i_writeInt64Array: OP_mIty_(Int64,"writeInt64Array", writeInt64ArrayZh(x,i,z)); break;
2269 case i_indexAddrArray: OP_mI_ty(Addr,"indexAddrArray", indexAddrArrayZh(r,x,i)); break;
2270 case i_readAddrArray: OP_mI_ty(Addr,"readAddrArray", readAddrArrayZh(r,x,i)); break;
2271 case i_writeAddrArray: OP_mIty_(Addr,"writeAddrArray", writeAddrArrayZh(x,i,z)); break;
2273 case i_indexFloatArray: OP_mI_ty(Float,"indexFloatArray", indexFloatArrayZh(r,x,i)); break;
2274 case i_readFloatArray: OP_mI_ty(Float,"readFloatArray", readFloatArrayZh(r,x,i)); break;
2275 case i_writeFloatArray: OP_mIty_(Float,"writeFloatArray", writeFloatArrayZh(x,i,z)); break;
2277 case i_indexDoubleArray: OP_mI_ty(Double,"indexDoubleArray", indexDoubleArrayZh(r,x,i)); break;
2278 case i_readDoubleArray: OP_mI_ty(Double,"readDoubleArray", readDoubleArrayZh(r,x,i)); break;
2279 case i_writeDoubleArray: OP_mIty_(Double,"writeDoubleArray", writeDoubleArrayZh(x,i,z)); break;
2281 #ifdef PROVIDE_STABLE
2282 case i_indexStableArray: OP_mI_ty(StablePtr,"indexStableArray", indexStablePtrArrayZh(r,x,i)); break;
2283 case i_readStableArray: OP_mI_ty(StablePtr,"readStableArray", readStablePtrArrayZh(r,x,i)); break;
2284 case i_writeStableArray: OP_mIty_(StablePtr,"writeStableArray", writeStablePtrArrayZh(x,i,z)); break;
2287 #endif /* PROVIDE_ARRAY */
2288 #ifdef PROVIDE_COERCE
2289 case i_unsafeCoerce:
2291 /* Another nullop */
2295 #ifdef PROVIDE_PTREQUALITY
2296 case i_reallyUnsafePtrEquality:
2297 { /* identical to i_sameRef */
2298 StgPtr x = PopPtr();
2299 StgPtr y = PopPtr();
2300 PushTaggedBool(x==y);
2304 #ifdef PROVIDE_FOREIGN
2305 /* ForeignObj# operations */
2306 case i_makeForeignObj:
2308 StgForeignObj *result
2309 = stgCast(StgForeignObj*,allocate(sizeofW(StgForeignObj)));
2310 SET_HDR(result,&FOREIGN_info,CCCS);
2311 result -> data = PopTaggedAddr();
2312 PushPtr(stgCast(StgPtr,result));
2315 #endif /* PROVIDE_FOREIGN */
2320 = stgCast(StgWeak*,allocate(sizeofW(StgWeak)));
2321 SET_HDR(w, &WEAK_info, CCCS);
2323 w->value = PopCPtr();
2324 w->finaliser = PopCPtr();
2325 w->link = weak_ptr_list;
2327 IF_DEBUG(weak, fprintf(stderr,"New weak pointer at %p\n",w));
2328 PushPtr(stgCast(StgPtr,w));
2333 StgWeak *w = stgCast(StgWeak*,PopPtr());
2334 if (w->header.info == &WEAK_info) {
2335 PushCPtr(w->value); /* last result */
2336 PushTaggedInt(1); /* first result */
2338 PushPtr(stgCast(StgPtr,w)); /* ToDo: error thunk would be better */
2343 #endif /* PROVIDE_WEAK */
2344 #ifdef PROVIDE_STABLE
2345 /* StablePtr# operations */
2346 case i_makeStablePtr:
2348 StgStablePtr stable_ptr;
2349 if (stable_ptr_free == NULL) {
2350 enlargeStablePtrTable();
2353 stable_ptr = stable_ptr_free - stable_ptr_table;
2354 stable_ptr_free = (P_*)*stable_ptr_free;
2355 stable_ptr_table[stable_ptr] = PopPtr();
2357 PushTaggedStablePtr(stable_ptr);
2360 case i_deRefStablePtr:
2362 StgStablePtr stable_ptr = PopTaggedStablePtr();
2363 PushPtr(stable_ptr_table[stable_ptr]);
2367 case i_freeStablePtr:
2369 StgStablePtr stable_ptr = PopTaggedStablePtr();
2370 stable_ptr_table[stable_ptr] = (P_)stable_ptr_free;
2371 stable_ptr_free = stable_ptr_table + stable_ptr;
2374 #endif /* PROVIDE_STABLE */
2375 #ifdef PROVIDE_CONCURRENT
2378 StgClosure* c = PopCPtr();
2379 StgTSO* t = createGenThread(RtsFlags.GcFlags.initialStkSize,c);
2380 PushPtr(stgCast(StgPtr,t));
2382 /* switch at the earliest opportunity */
2384 /* but don't automatically switch to GHC - or you'll waste your
2385 * time slice switching back.
2387 * Actually, there's more to it than that: the default
2388 * (ThreadEnterGHC) causes the thread to crash - don't
2389 * understand why. - ADR
2391 t->whatNext = ThreadEnterHugs;
2396 StgTSO* tso = stgCast(StgTSO*,PopPtr());
2398 if (tso == CurrentTSO) { /* suicide */
2399 return ThreadFinished;
2404 { /* identical to i_sameRef */
2405 StgPtr x = PopPtr();
2406 StgPtr y = PopPtr();
2407 PushTaggedBool(x==y);
2412 StgMVar *mvar = stgCast(StgMVar*,allocate(sizeofW(StgMVar)));
2413 SET_INFO(mvar,&EMPTY_MVAR_info);
2414 mvar->head = mvar->tail = EndTSOQueue;
2415 /* ToDo: this is a little strange */
2416 mvar->value = stgCast(StgClosure*,&END_TSO_QUEUE_closure);
2417 PushPtr(stgCast(StgPtr,mvar));
2422 ToDo: another way out of the problem might be to add an explicit
2423 continuation to primTakeMVar: takeMVar v = primTakeMVar v takeMVar.
2424 The problem with this plan is that now I dont know how much to chop
2429 StgMVar *mvar = stgCast(StgMVar*,PopPtr());
2430 /* If the MVar is empty, put ourselves
2431 * on its blocking queue, and wait
2432 * until we're woken up.
2434 if (GET_INFO(mvar) != &FULL_MVAR_info) {
2435 if (mvar->head == EndTSOQueue) {
2436 mvar->head = CurrentTSO;
2438 mvar->tail->link = CurrentTSO;
2440 CurrentTSO->link = EndTSOQueue;
2441 mvar->tail = CurrentTSO;
2443 /* Hack, hack, hack.
2444 * When we block, we push a restart closure
2445 * on the stack - but which closure?
2446 * We happen to know that the BCO we're
2447 * executing looks like this:
2456 * 14: ALLOC_CONSTR 0x8213a80
2466 * so we rearrange the stack to look the
2467 * way it did when we entered this BCO
2469 * What a disgusting hack!
2475 return ThreadBlocked;
2478 PushCPtr(mvar->value);
2479 SET_INFO(mvar,&EMPTY_MVAR_info);
2480 /* ToDo: this is a little strange */
2481 mvar->value = (StgClosure*)&END_TSO_QUEUE_closure;
2488 StgMVar* mvar = stgCast(StgMVar*,PopPtr());
2489 StgClosure* value = PopCPtr();
2490 if (GET_INFO(mvar) == &FULL_MVAR_info) {
2491 obj = raisePrim("putMVar {full MVar}");
2494 /* wake up the first thread on the
2495 * queue, it will continue with the
2496 * takeMVar operation and mark the
2499 StgTSO* tso = mvar->head;
2500 SET_INFO(mvar,&FULL_MVAR_info);
2501 mvar->value = value;
2502 if (tso != EndTSOQueue) {
2503 PUSH_ON_RUN_QUEUE(tso);
2504 mvar->head = tso->link;
2505 tso->link = EndTSOQueue;
2506 if (mvar->head == EndTSOQueue) {
2507 mvar->tail = EndTSOQueue;
2511 /* yield for better communication performance */
2518 /* As PrimOps.h says: Hmm, I'll think about these later. */
2521 #endif /* PROVIDE_CONCURRENT */
2525 CFunDescriptor* descriptor = PopTaggedAddr();
2526 StgAddr funPtr = PopTaggedAddr();
2527 ccall(descriptor,funPtr);
2531 barf("Unrecognised primop2");
2536 barf("Unrecognised instruction");
2539 barf("Ran off the end of bco - yoiks");
2544 StgCAF* caf = stgCast(StgCAF*,obj);
2545 if (Sp - sizeofW(StgUpdateFrame) < SpLim) {
2546 PushCPtr(obj); /* code to restart with */
2547 return StackOverflow;
2549 /* ToDo: look for Sp==Su && stackInt(0) == UPD_FRAME and insert an indirection immediately */
2551 StgBlackHole* bh = stgCast(StgBlackHole*,grabHpUpd(BLACKHOLE_sizeW()));
2552 SET_INFO(bh,&CAF_BLACKHOLE_info);
2553 bh->blocking_queue = EndTSOQueue;
2554 IF_DEBUG(gccafs,fprintf(stderr,"Created CAF_BLACKHOLE %p for CAF %p in evaluator\n",bh,caf));
2555 SET_INFO(caf,&CAF_ENTERED_info);
2556 caf->value = stgCast(StgClosure*,bh);
2557 PUSH_UPD_FRAME(bh,0);
2558 Sp -= sizeofW(StgUpdateFrame);
2560 caf->link = enteredCAFs;
2567 StgCAF* caf = stgCast(StgCAF*,obj);
2568 obj = caf->value; /* it's just a fancy indirection */
2574 StgBlackHole* bh = stgCast(StgBlackHole*,obj);
2575 /* Put ourselves on the blocking queue for this black hole and block */
2576 CurrentTSO->link = bh->blocking_queue;
2577 bh->blocking_queue = CurrentTSO;
2578 PushCPtr(obj); /* code to restart with */
2579 return ThreadBlocked;
2583 StgAP_UPD* ap = stgCast(StgAP_UPD*,obj);
2585 if (Sp - (i + sizeofW(StgUpdateFrame)) < SpLim) {
2586 PushCPtr(obj); /* code to restart with */
2587 return StackOverflow;
2589 /* ToDo: look for Sp==Su && stackInt(0) == UPD_FRAME and insert an indirection immediately */
2590 PUSH_UPD_FRAME(ap,0);
2591 Sp -= sizeofW(StgUpdateFrame);
2593 PushWord(payloadWord(ap,i));
2596 #ifndef LAZY_BLACKHOLING
2598 /* superfluous - but makes debugging easier */
2599 StgBlackHole* bh = stgCast(StgBlackHole*,ap);
2600 SET_INFO(bh,&BLACKHOLE_info);
2601 bh->blocking_queue = EndTSOQueue;
2602 IF_DEBUG(gccafs,fprintf(stderr,"Eagerly blackholed AP_UPD %p in evaluator\n",bh));
2605 #endif /* LAZY_BLACKHOLING */
2610 StgPAP* pap = stgCast(StgPAP*,obj);
2611 int i = pap->n_args; /* ToDo: stack check */
2612 /* ToDo: if PAP is in whnf, we can update any update frames
2616 PushWord(payloadWord(pap,i));
2623 obj = stgCast(StgInd*,obj)->indirectee;
2627 case CONSTR_INTLIKE:
2628 case CONSTR_CHARLIKE:
2630 case CONSTR_NOCAF_STATIC:
2633 switch (get_itbl(stgCast(StgClosure*,Sp))->type) {
2638 PopUpdateFrame(obj);
2648 /*fprintf(stderr,"Sp = %p\tSu = %p\n", Sp, Su);*/
2649 /*printStack(Sp,CurrentTSO->stack+CurrentTSO->stack_size,Su);*/
2652 return ThreadFinished;
2663 case RET_SMALL: /* return to GHC */
2667 barf("todo: RET_[VEC_]{BIG,SMALL}");
2669 belch("entered CONSTR with invalid continuation on stack");
2671 printObj(stgCast(StgClosure*,Sp))
2673 barf("bailing out");
2679 CurrentTSO->whatNext = ThreadEnterGHC;
2680 PushCPtr(obj); /* code to restart with */
2681 return ThreadYielding;
2684 barf("Ran off the end of enter - yoiks");
2687 /* -----------------------------------------------------------------------------
2688 * ccall support code:
2689 * marshall moves args from C stack to Haskell stack
2690 * unmarshall moves args from Haskell stack to C stack
2691 * argSize calculates how much space you need on the C stack
2692 * ---------------------------------------------------------------------------*/
2694 /* Pop arguments off the C stack and Push them onto the Hugs stack.
2695 * Used when preparing for C calling Haskell or in response to
2696 * Haskell calling C.
2698 nat marshall(char arg_ty, void* arg)
2702 PushTaggedInt(*((int*)arg));
2703 return ARG_SIZE(INT_TAG);
2704 #ifdef PROVIDE_INT64
2706 PushTaggedInt64(*((StgInt64*)arg));
2707 return ARG_SIZE(INT64_TAG);
2709 #ifdef TODO_PROVIDE_INTEGER
2711 PushTaggedInteger(*((mpz_ptr*)arg));
2712 return ARG_SIZE(INTEGER_TAG);
2716 PushTaggedWord(*((unsigned int*)arg));
2717 return ARG_SIZE(WORD_TAG);
2720 PushTaggedChar(*((char*)arg));
2721 return ARG_SIZE(CHAR_TAG);
2723 PushTaggedFloat(*((float*)arg));
2724 return ARG_SIZE(FLOAT_TAG);
2726 PushTaggedDouble(*((double*)arg));
2727 return ARG_SIZE(DOUBLE_TAG);
2730 PushTaggedAddr(*((void**)arg));
2731 return ARG_SIZE(ADDR_TAG);
2734 PushTaggedStablePtr(*((StgStablePtr*)arg));
2735 return ARG_SIZE(STABLE_TAG);
2737 /* Not allowed in this direction - you have to
2738 * call makeForeignPtr explicitly
2740 barf("marshall: ForeignPtr#\n");
2742 #ifdef PROVIDE_ARRAY
2746 /* Not allowed in this direction */
2747 barf("marshall: [Mutable]ByteArray#\n");
2750 barf("marshall: unrecognised arg type %d\n",arg_ty);
2755 /* Pop arguments off the Hugs stack and Push them onto the C stack.
2756 * Used when preparing for Haskell calling C or in response to
2757 * C calling Haskell.
2759 nat unmarshall(char res_ty, void* res)
2763 *((int*)res) = PopTaggedInt();
2764 return ARG_SIZE(INT_TAG);
2765 #ifdef PROVIDE_INT64
2767 *((StgInt64*)res) = PopTaggedInt64();
2768 return ARG_SIZE(INT64_TAG);
2770 #ifdef TODO_PROVIDE_INTEGER
2772 *((mpz_ptr*)res) = PopTaggedInteger();
2773 return ARG_SIZE(INTEGER_TAG);
2777 *((unsigned int*)res) = PopTaggedWord();
2778 return ARG_SIZE(WORD_TAG);
2781 *((int*)res) = PopTaggedChar();
2782 return ARG_SIZE(CHAR_TAG);
2784 *((float*)res) = PopTaggedFloat();
2785 return ARG_SIZE(FLOAT_TAG);
2787 *((double*)res) = PopTaggedDouble();
2788 return ARG_SIZE(DOUBLE_TAG);
2791 *((void**)res) = PopTaggedAddr();
2792 return ARG_SIZE(ADDR_TAG);
2795 *((StgStablePtr*)res) = PopTaggedStablePtr();
2796 return ARG_SIZE(STABLE_TAG);
2799 StgForeignObj *result = stgCast(StgForeignObj*,PopPtr());
2800 *((void**)res) = result->data;
2801 return sizeofW(StgPtr);
2803 #ifdef PROVIDE_ARRAY
2808 StgArrPtrs* arr = stgCast(StgArrPtrs*,PopPtr());
2809 *((void**)res) = stgCast(void*,&(arr->payload));
2810 return sizeofW(StgPtr);
2813 barf("unmarshall: unrecognised result type %d\n",res_ty);
2817 nat argSize( const char* ks )
2820 for( ; *ks != '\0'; ++ks) {
2823 sz += sizeof(StgWord) * ARG_SIZE(INT_TAG);
2825 #ifdef PROVIDE_INT64
2827 sz += sizeof(StgWord) * ARG_SIZE(INT64_TAG);
2830 #ifdef TODO_PROVIDE_INTEGER
2832 sz += sizeof(StgWord) * ARG_SIZE(INTEGER_TAG);
2837 sz += sizeof(StgWord) * ARG_SIZE(WORD_TAG);
2841 sz += sizeof(StgWord) * ARG_SIZE(CHAR_TAG);
2844 sz += sizeof(StgWord) * ARG_SIZE(FLOAT_TAG);
2847 sz += sizeof(StgWord) * ARG_SIZE(DOUBLE_TAG);
2851 sz += sizeof(StgWord) * ARG_SIZE(ADDR_TAG);
2854 #ifdef PROVIDE_STABLE
2856 sz += sizeof(StgWord) * ARG_SIZE(STABLE_TAG);
2859 #ifdef PROVIDE_FOREIGN
2862 #ifdef PROVIDE_ARRAY
2866 sz += sizeof(StgPtr);
2869 barf("argSize: unrecognised result type %d\n",*ks);
2876 #endif /* INTERPRETER */