X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Frts%2FPrimOps.hc;h=2d27886911ea94b7e1e3d7c9a140abc7c85b2ebd;hb=f30be2dcc16a3dae31dc8b3f923c8861c5d26fa0;hp=b571db3819ccafc1c0ce16f8dd17a9134cff66c0;hpb=f5448f5c5efe0630cb865ee0d21691a23ea932d3;p=ghc-hetmet.git

diff --git a/ghc/rts/PrimOps.hc b/ghc/rts/PrimOps.hc
index b571db3..2d27886 100644
--- a/ghc/rts/PrimOps.hc
+++ b/ghc/rts/PrimOps.hc
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: PrimOps.hc,v 1.56 2000/11/07 10:42:57 simonmar Exp $
+ * $Id: PrimOps.hc,v 1.64 2000/12/19 12:34:01 sewardj Exp $
  *
  * (c) The GHC Team, 1998-2000
  *
@@ -244,34 +244,24 @@ W_ GHC_ZCCReturnable_static_info[0];
 
 #define BYTES_TO_STGWORDS(n) ((n) + sizeof(W_) - 1)/sizeof(W_)
 
-#define newByteArray(ty,scale)				\
- FN_(new##ty##Arrayzh_fast)				\
+FN_(newByteArrayzh_fast)				\
  {							\
-   W_ stuff_size, size, n;				\
+   W_ size, stuff_size, n;				\
    StgArrWords* p;					\
    FB_							\
-     MAYBE_GC(NO_PTRS,new##ty##Arrayzh_fast);		\
+     MAYBE_GC(NO_PTRS,newByteArrayzh_fast);		\
      n = R1.w;						\
-     stuff_size = BYTES_TO_STGWORDS(n*scale);		\
+     stuff_size = BYTES_TO_STGWORDS(n);			\
      size = sizeofW(StgArrWords)+ stuff_size;		\
      p = (StgArrWords *)RET_STGCALL1(P_,allocate,size);	\
      TICK_ALLOC_PRIM(sizeofW(StgArrWords),stuff_size,0); \
-     SET_HDR(p, &ARR_WORDS_info, CCCS);		\
+     SET_HDR(p, &stg_ARR_WORDS_info, CCCS);		\
      p->words = stuff_size;				\
      TICK_RET_UNBOXED_TUP(1)				\
      RET_P(p);						\
    FE_							\
  }
 
-newByteArray(Char,   1)
-/* Char arrays really contain only 8-bit bytes for compatibility. */
-newByteArray(Int,    sizeof(I_))
-newByteArray(Word,   sizeof(W_))
-newByteArray(Addr,   sizeof(P_))
-newByteArray(Float,  sizeof(StgFloat))
-newByteArray(Double, sizeof(StgDouble))
-newByteArray(StablePtr, sizeof(StgStablePtr))
-
 FN_(newArrayzh_fast)
 {
   W_ size, n, init;
@@ -286,7 +276,7 @@ FN_(newArrayzh_fast)
     arr = (StgMutArrPtrs *)RET_STGCALL1(P_, allocate, size);
     TICK_ALLOC_PRIM(sizeofW(StgMutArrPtrs), n, 0);
 
-    SET_HDR(arr,&MUT_ARR_PTRS_info,CCCS);
+    SET_HDR(arr,&stg_MUT_ARR_PTRS_info,CCCS);
     arr->ptrs = n;
 
     init = R2.w;
@@ -311,7 +301,7 @@ FN_(newMutVarzh_fast)
   CCS_ALLOC(CCCS,sizeofW(StgMutVar));
 
   mv = (StgMutVar *)(Hp-sizeofW(StgMutVar)+1);
-  SET_HDR(mv,&MUT_VAR_info,CCCS);
+  SET_HDR(mv,&stg_MUT_VAR_info,CCCS);
   mv->var = R1.cl;
 
   TICK_RET_UNBOXED_TUP(1);
@@ -338,7 +328,7 @@ FN_(mkForeignObjzh_fast)
   CCS_ALLOC(CCCS,sizeofW(StgForeignObj)); /* ccs prof */
 
   result = (StgForeignObj *) (Hp + 1 - sizeofW(StgForeignObj));
-  SET_HDR(result,&FOREIGN_info,CCCS);
+  SET_HDR(result,&stg_FOREIGN_info,CCCS);
   result->data = R1.p;
 
   /* returns (# s#, ForeignObj# #) */
@@ -352,7 +342,7 @@ FN_(mkForeignObjzh_fast)
 FN_(unsafeThawArrayzh_fast)
 {
   FB_
-  SET_INFO((StgClosure *)R1.cl,&MUT_ARR_PTRS_info);
+  SET_INFO((StgClosure *)R1.cl,&stg_MUT_ARR_PTRS_info);
   recordMutable((StgMutClosure*)R1.cl);
 
   TICK_RET_UNBOXED_TUP(1);
@@ -376,7 +366,7 @@ FN_(mkWeakzh_fast)
   FB_
 
   if (R3.cl == NULL) {
-    R3.cl = &NO_FINALIZER_closure;
+    R3.cl = &stg_NO_FINALIZER_closure;
   }
 
   HP_CHK_GEN_TICKY(sizeofW(StgWeak),R1_PTR|R2_PTR|R3_PTR, mkWeakzh_fast,);
@@ -385,7 +375,7 @@ FN_(mkWeakzh_fast)
   CCS_ALLOC(CCCS,sizeofW(StgWeak)); /* ccs prof */
 
   w = (StgWeak *) (Hp + 1 - sizeofW(StgWeak));
-  SET_HDR(w, &WEAK_info, CCCS);
+  SET_HDR(w, &stg_WEAK_info, CCCS);
 
   w->key        = R1.cl;
   w->value      = R2.cl;
@@ -411,18 +401,18 @@ FN_(finalizzeWeakzh_fast)
   w = (StgDeadWeak *)R1.p;
 
   /* already dead? */
-  if (w->header.info == &DEAD_WEAK_info) {
-      RET_NP(0,&NO_FINALIZER_closure);
+  if (w->header.info == &stg_DEAD_WEAK_info) {
+      RET_NP(0,&stg_NO_FINALIZER_closure);
   }
 
   /* kill it */
-  w->header.info = &DEAD_WEAK_info;
+  w->header.info = &stg_DEAD_WEAK_info;
   f = ((StgWeak *)w)->finalizer;
   w->link = ((StgWeak *)w)->link;
 
   /* return the finalizer */
-  if (f == &NO_FINALIZER_closure) {
-      RET_NP(0,&NO_FINALIZER_closure);
+  if (f == &stg_NO_FINALIZER_closure) {
+      RET_NP(0,&stg_NO_FINALIZER_closure);
   } else {
       RET_NP(1,f);
   }
@@ -449,7 +439,7 @@ FN_(int2Integerzh_fast)
    CCS_ALLOC(CCCS,sizeofW(StgArrWords)+1); /* ccs prof */
 
    p = (StgArrWords *)Hp - 1;
-   SET_ARR_HDR(p, &ARR_WORDS_info, CCCS, 1);
+   SET_ARR_HDR(p, &stg_ARR_WORDS_info, CCCS, 1);
 
    /* mpz_set_si is inlined here, makes things simpler */
    if (val < 0) { 
@@ -486,7 +476,7 @@ FN_(word2Integerzh_fast)
    CCS_ALLOC(CCCS,sizeofW(StgArrWords)+1); /* ccs prof */
 
    p = (StgArrWords *)Hp - 1;
-   SET_ARR_HDR(p, &ARR_WORDS_info, CCCS, 1);
+   SET_ARR_HDR(p, &stg_ARR_WORDS_info, CCCS, 1);
 
    if (val != 0) {
 	s = 1;
@@ -535,7 +525,7 @@ FN_(int64ToIntegerzh_fast)
    CCS_ALLOC(CCCS,sizeofW(StgArrWords)+words_needed); /* ccs prof */
 
    p = (StgArrWords *)(Hp-words_needed+1) - 1;
-   SET_ARR_HDR(p, &ARR_WORDS_info, CCCS, words_needed);
+   SET_ARR_HDR(p, &stg_ARR_WORDS_info, CCCS, words_needed);
 
    if ( val < 0LL ) {
      neg = 1;
@@ -586,7 +576,7 @@ FN_(word64ToIntegerzh_fast)
    CCS_ALLOC(CCCS,sizeofW(StgArrWords)+words_needed); /* ccs prof */
 
    p = (StgArrWords *)(Hp-words_needed+1) - 1;
-   SET_ARR_HDR(p, &ARR_WORDS_info, CCCS, words_needed);
+   SET_ARR_HDR(p, &stg_ARR_WORDS_info, CCCS, words_needed);
 
    hi = (W_)((LW_)val / 0x100000000ULL);
    if ( val >= 0x100000000ULL ) { 
@@ -731,7 +721,6 @@ GMP_TAKE1_RET1(complementIntegerzh_fast, mpz_com);
 GMP_TAKE2_RET2(quotRemIntegerzh_fast, mpz_tdiv_qr);
 GMP_TAKE2_RET2(divModIntegerzh_fast,  mpz_fdiv_qr);
 
-#ifndef FLOATS_AS_DOUBLES
 FN_(decodeFloatzh_fast)
 { 
   MP_INT mantissa;
@@ -750,7 +739,7 @@ FN_(decodeFloatzh_fast)
   /* Be prepared to tell Lennart-coded __decodeFloat	*/
   /* where mantissa._mp_d can be put (it does not care about the rest) */
   p = (StgArrWords *)Hp - 1;
-  SET_ARR_HDR(p,&ARR_WORDS_info,CCCS,1)
+  SET_ARR_HDR(p,&stg_ARR_WORDS_info,CCCS,1)
   mantissa._mp_d = (void *)BYTE_ARR_CTS(p);
 
   /* Perform the operation */
@@ -761,7 +750,6 @@ FN_(decodeFloatzh_fast)
   RET_NNP(exponent,mantissa._mp_size,p);
   FE_
 }
-#endif /* !FLOATS_AS_DOUBLES */
 
 #define DOUBLE_MANTISSA_SIZE (sizeofW(StgDouble))
 #define ARR_SIZE (sizeofW(StgArrWords) + DOUBLE_MANTISSA_SIZE)
@@ -783,7 +771,7 @@ FN_(decodeDoublezh_fast)
   /* Be prepared to tell Lennart-coded __decodeDouble	*/
   /* where mantissa.d can be put (it does not care about the rest) */
   p = (StgArrWords *)(Hp-ARR_SIZE+1);
-  SET_ARR_HDR(p, &ARR_WORDS_info, CCCS, DOUBLE_MANTISSA_SIZE);
+  SET_ARR_HDR(p, &stg_ARR_WORDS_info, CCCS, DOUBLE_MANTISSA_SIZE);
   mantissa._mp_d = (void *)BYTE_ARR_CTS(p);
 
   /* Perform the operation */
@@ -838,9 +826,9 @@ FN_(newMVarzh_fast)
   CCS_ALLOC(CCCS,sizeofW(StgMVar)); /* ccs prof */
   
   mvar = (StgMVar *) (Hp - sizeofW(StgMVar) + 1);
-  SET_HDR(mvar,&EMPTY_MVAR_info,CCCS);
-  mvar->head = mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
-  mvar->value = (StgClosure *)&END_TSO_QUEUE_closure;
+  SET_HDR(mvar,&stg_EMPTY_MVAR_info,CCCS);
+  mvar->head = mvar->tail = (StgTSO *)&stg_END_TSO_QUEUE_closure;
+  mvar->value = (StgClosure *)&stg_END_TSO_QUEUE_closure;
 
   TICK_RET_UNBOXED_TUP(1);
   RET_P(mvar);
@@ -867,31 +855,31 @@ FN_(takeMVarzh_fast)
   /* If the MVar is empty, put ourselves on its blocking queue,
    * and wait until we're woken up.
    */
-  if (info == &EMPTY_MVAR_info) {
-    if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
+  if (info == &stg_EMPTY_MVAR_info) {
+    if (mvar->head == (StgTSO *)&stg_END_TSO_QUEUE_closure) {
       mvar->head = CurrentTSO;
     } else {
       mvar->tail->link = CurrentTSO;
     }
-    CurrentTSO->link = (StgTSO *)&END_TSO_QUEUE_closure;
+    CurrentTSO->link = (StgTSO *)&stg_END_TSO_QUEUE_closure;
     CurrentTSO->why_blocked = BlockedOnMVar;
     CurrentTSO->block_info.closure = (StgClosure *)mvar;
     mvar->tail = CurrentTSO;
 
 #ifdef SMP
     /* unlock the MVar */
-    mvar->header.info = &EMPTY_MVAR_info;
+    mvar->header.info = &stg_EMPTY_MVAR_info;
 #endif
     BLOCK(R1_PTR, takeMVarzh_fast);
   }
 
   val = mvar->value;
-  mvar->value = (StgClosure *)&END_TSO_QUEUE_closure;
+  mvar->value = (StgClosure *)&stg_END_TSO_QUEUE_closure;
 
   /* do this last... we might have locked the MVar in the SMP case,
    * and writing the info pointer will unlock it.
    */
-  SET_INFO(mvar,&EMPTY_MVAR_info);
+  SET_INFO(mvar,&stg_EMPTY_MVAR_info);
 
   TICK_RET_UNBOXED_TUP(1);
   RET_P(val);
@@ -915,24 +903,24 @@ FN_(tryTakeMVarzh_fast)
   info = GET_INFO(mvar);
 #endif
 
-  if (info == &EMPTY_MVAR_info) {
+  if (info == &stg_EMPTY_MVAR_info) {
 
 #ifdef SMP
     /* unlock the MVar */
-    mvar->header.info = &EMPTY_MVAR_info;
+    mvar->header.info = &stg_EMPTY_MVAR_info;
 #endif
 
     /* HACK: we need a pointer to pass back, so we abuse NO_FINALIZER_closure */
-    RET_NP(0, &NO_FINALIZER_closure);
+    RET_NP(0, &stg_NO_FINALIZER_closure);
   }
 
   val = mvar->value;
-  mvar->value = (StgClosure *)&END_TSO_QUEUE_closure;
+  mvar->value = (StgClosure *)&stg_END_TSO_QUEUE_closure;
 
   /* do this last... we might have locked the MVar in the SMP case,
    * and writing the info pointer will unlock it.
    */
-  SET_INFO(mvar,&EMPTY_MVAR_info);
+  SET_INFO(mvar,&stg_EMPTY_MVAR_info);
 
   TICK_RET_UNBOXED_TUP(1);
   RET_NP(1,val);
@@ -955,7 +943,7 @@ FN_(putMVarzh_fast)
   info = GET_INFO(mvar);
 #endif
 
-  if (info == &FULL_MVAR_info) {
+  if (info == &stg_FULL_MVAR_info) {
 #ifdef INTERPRETER
     fprintf(stderr, "fatal: put on a full MVar in Hugs; aborting\n" );
     exit(1);
@@ -970,7 +958,7 @@ FN_(putMVarzh_fast)
   /* wake up the first thread on the queue, it will continue with the
    * takeMVar operation and mark the MVar empty again.
    */
-  if (mvar->head != (StgTSO *)&END_TSO_QUEUE_closure) {
+  if (mvar->head != (StgTSO *)&stg_END_TSO_QUEUE_closure) {
     ASSERT(mvar->head->why_blocked == BlockedOnMVar);
 #if defined(GRAN)
     mvar->head = RET_STGCALL2(StgTSO *,unblockOne,mvar->head,mvar);
@@ -980,13 +968,13 @@ FN_(putMVarzh_fast)
 #else
     mvar->head = RET_STGCALL1(StgTSO *,unblockOne,mvar->head);
 #endif
-    if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
-      mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
+    if (mvar->head == (StgTSO *)&stg_END_TSO_QUEUE_closure) {
+      mvar->tail = (StgTSO *)&stg_END_TSO_QUEUE_closure;
     }
   }
 
   /* unlocks the MVar in the SMP case */
-  SET_INFO(mvar,&FULL_MVAR_info);
+  SET_INFO(mvar,&stg_FULL_MVAR_info);
 
   /* ToDo: yield here for better communication performance? */
   JMP_(ENTRY_CODE(Sp[0]));
@@ -1013,7 +1001,7 @@ FN_(makeStableNamezh_fast)
   /* Is there already a StableName for this heap object? */
   if (stable_ptr_table[index].sn_obj == NULL) {
     sn_obj = (StgStableName *) (Hp - sizeofW(StgStableName) + 1);
-    sn_obj->header.info = &STABLE_NAME_info;
+    sn_obj->header.info = &stg_STABLE_NAME_info;
     sn_obj->sn = index;
     stable_ptr_table[index].sn_obj = (StgClosure *)sn_obj;
   } else {
@@ -1025,6 +1013,36 @@ FN_(makeStableNamezh_fast)
 }
 
 /* -----------------------------------------------------------------------------
+   Bytecode object primitives
+   -------------------------------------------------------------------------  */
+
+FN_(newBCOzh_fast)
+{
+  /* R1.p = instrs
+     R2.p = literals
+     R3.p = ptrs
+     R4.p = itbls
+  */
+  StgBCO *bco;
+  FB_
+
+  HP_CHK_GEN_TICKY(sizeofW(StgBCO),R1_PTR|R2_PTR|R3_PTR|R4_PTR, newBCOzh_fast,);
+  TICK_ALLOC_PRIM(sizeofW(StgHeader), sizeofW(StgBCO)-sizeofW(StgHeader), 0);
+  CCS_ALLOC(CCCS,sizeofW(StgBCO)); /* ccs prof */
+  bco = (StgBCO *) (Hp + 1 - sizeofW(StgBCO));
+  SET_HDR(bco, &stg_BCO_info, CCCS);
+
+  bco->instrs     = R1.cl;
+  bco->literals   = R2.cl;
+  bco->ptrs       = R3.cl;
+  bco->itbls      = R4.cl;
+
+  TICK_RET_UNBOXED_TUP(1);
+  RET_P(bco);
+  FE_
+}
+
+/* -----------------------------------------------------------------------------
    Thread I/O blocking primitives
    -------------------------------------------------------------------------- */