[project @ 1999-03-01 17:41:50 by simonm]
[ghc-hetmet.git] / ghc / rts / PrimOps.hc
index e865fb1..3fa86b7 100644 (file)
@@ -1,5 +1,7 @@
 /* -----------------------------------------------------------------------------
- * $Id: PrimOps.hc,v 1.10 1999/02/01 18:05:34 simonm Exp $
+ * $Id: PrimOps.hc,v 1.19 1999/03/01 10:17:15 simonm Exp $
+ *
+ * (c) The GHC Team, 1998-1999
  *
  * Primitive functions / data
  *
@@ -74,6 +76,10 @@ const
         R1.w = (W_)(a); R2.w = (W_)(b); R3.w = (W_)(c); R4.w = (W_)d; \
         JMP_(ENTRY_CODE(Sp[0]));
 
+# define RET_NPNP(a,b,c,d) \
+        R1.w = (W_)(a); R2.w = (W_)(b); R3.w = (W_)(c); R4.w = (W_)(d); \
+       JMP_(ENTRY_CODE(Sp[0]));
+
 # define RET_NNPNNP(a,b,c,d,e,f) \
         R1.w = (W_)(a); R2.w = (W_)(b); R3.w = (W_)(c); \
         R4.w = (W_)(d); R5.w = (W_)(e); R6.w = (W_)(f); \
@@ -114,6 +120,15 @@ const
         Sp -= 5;                               \
         JMP_(ENTRY_CODE(Sp[5]));
 
+# define RET_NPNP(a,b,c,d)                     \
+       R1.w = (W_)(a);                         \
+        Sp[-4] = (W_)(b);                      \
+    /*  Sp[-3] = ARGTAG(1); */                 \
+        Sp[-2] = (W_)(c);                      \
+        Sp[-1] = (W_)(d);                      \
+        Sp -= 4;                               \
+        JMP_(ENTRY_CODE(Sp[4]));
+
 # define RET_NNPNNP(a,b,c,d,e,f)               \
         R1.w = (W_)(a);                                \
        Sp[-1] = (W_)(f);                       \
@@ -161,6 +176,7 @@ const
 # define RET_NNP(a,b,c) PUSH_N(6,a); PUSH_N(4,b); PUSH_N(2,c); PUSHED(6)
 
 # define RET_NNNP(a,b,c,d) PUSH_N(7,a); PUSH_N(5,b); PUSH_N(3,c); PUSH_P(1,d); PUSHED(7)       
+# define RET_NPNP(a,b,c,d) PUSH_N(6,a); PUSH_P(4,b); PUSH_N(3,c); PUSH_P(1,d); PUSHED(6)       
 # define RET_NNPNNP(a,b,c,d,e,f) PUSH_N(10,a); PUSH_N(8,b); PUSH_P(6,c); PUSH_N(5,d); PUSH_N(3,e); PUSH_P(1,f); PUSHED(10)
 
 #endif
@@ -197,7 +213,7 @@ const
      size = sizeofW(StgArrWords)+ stuff_size;          \
      p = (StgArrWords *)RET_STGCALL1(P_,allocate,size);        \
      TICK_ALLOC_PRIM(sizeofW(StgArrWords),stuff_size,0); \
-     SET_HDR(p, &MUT_ARR_WORDS_info, CCCS);            \
+     SET_HDR(p, &ARR_WORDS_info, CCCS);                \
      p->words = stuff_size;                            \
      TICK_RET_UNBOXED_TUP(1)                           \
      RET_P(p);                                         \
@@ -298,7 +314,7 @@ FN_(mkWeakzh_fast)
 {
   /* R1.p = key
      R2.p = value
-     R3.p = finaliser
+     R3.p = finalizer
   */
   StgWeak *w;
   FB_
@@ -314,9 +330,9 @@ FN_(mkWeakzh_fast)
   w->key        = R1.cl;
   w->value      = R2.cl;
   if (R3.cl) {
-     w->finaliser  = R3.cl;
-  } else
-     w->finaliser  = &NO_FINALISER_closure;
+     w->finalizer  = R3.cl;
+  } else {
+     w->finalizer  = &NO_FINALIZER_closure;
   }
 
   w->link       = weak_ptr_list;
@@ -328,27 +344,32 @@ FN_(mkWeakzh_fast)
   FE_
 }
 
-FN_(finaliseWeakzh_fast)
+FN_(finalizzeWeakzh_fast)
 {
   /* R1.p = weak ptr
    */
-  StgWeak *w;
+  StgDeadWeak *w;
+  StgClosure *f;
   FB_
   TICK_RET_UNBOXED_TUP(0);
-  w = (StgWeak *)R1.p;
+  w = (StgDeadWeak *)R1.p;
 
-  if (w->finaliser != &NO_FINALISER_info) {
-#ifdef INTERPRETER
-      STGCALL2(StgTSO *, createGenThread,
-               RtsFlags.GcFlags.initialStkSize, w->finaliser);
-#else
-      STGCALL2(StgTSO *, createIOThread,
-               RtsFlags.GcFlags.initialStkSize, w->finaliser);
-#endif
+  /* already dead? */
+  if (w->header.info == &DEAD_WEAK_info) {
+      RET_NP(0,&NO_FINALIZER_closure);
   }
-  w->header.info = &DEAD_WEAK_info;
 
-  JMP_(ENTRY_CODE(Sp[0]));
+  /* kill it */
+  w->header.info = &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);
+  } else {
+      RET_NP(1,f);
+  }
   FE_
 }
 
@@ -385,13 +406,12 @@ FN_(int2Integerzh_fast)
        s = 0;
    }
 
-   /* returns (# alloc :: Int#, 
-                size  :: Int#, 
+   /* returns (# size  :: Int#, 
                 data  :: ByteArray# 
               #)
    */
-   TICK_RET_UNBOXED_TUP(3);
-   RET_NNP(1,s,p);
+   TICK_RET_UNBOXED_TUP(2);
+   RET_NP(s,p);
    FE_
 }
 
@@ -419,13 +439,12 @@ FN_(word2Integerzh_fast)
        s = 0;
    }
 
-   /* returns (# alloc :: Int#, 
-                size  :: Int#, 
+   /* returns (# size  :: Int#, 
                 data  :: ByteArray# 
               #)
    */
-  TICK_RET_UNBOXED_TUP(3);
-   RET_NNP(1,s,p);
+   TICK_RET_UNBOXED_TUP(2);
+   RET_NP(s,p);
    FE_
 }
 
@@ -444,8 +463,12 @@ FN_(addr2Integerzh_fast)
   if (RET_STGCALL3(int, mpz_init_set_str,&result,(str),/*base*/10))
       abort();
 
-  TICK_RET_UNBOXED_TUP(3);
-  RET_NNP(result._mp_alloc, result._mp_size, 
+   /* returns (# size  :: Int#, 
+                data  :: ByteArray# 
+              #)
+   */
+  TICK_RET_UNBOXED_TUP(2);
+  RET_NP(result._mp_size, 
          result._mp_d - sizeofW(StgArrWords));
   FE_
 }
@@ -462,7 +485,7 @@ FN_(int64ToIntegerzh_fast)
 
    StgInt64  val; /* to avoid aliasing */
    W_ hi;
-   I_  s,a, neg, words_needed;
+   I_  s, neg, words_needed;
    StgArrWords* p;     /* address of array result */
    FB_
 
@@ -482,8 +505,6 @@ FN_(int64ToIntegerzh_fast)
    p = stgCast(StgArrWords*,(Hp-words_needed+1))-1;
    SET_ARR_HDR(p, &ARR_WORDS_info, CCCS, words_needed);
 
-   a = words_needed;
-
    if ( val < 0LL ) {
      neg = 1;
      val = -val;
@@ -491,7 +512,7 @@ FN_(int64ToIntegerzh_fast)
 
    hi = (W_)((LW_)val / 0x100000000ULL);
 
-   if ( a == 2 )  { 
+   if ( words_needed == 2 )  { 
       s = 2; 
       Hp[-1] = (W_)val;
       Hp[0] = hi;
@@ -503,13 +524,12 @@ FN_(int64ToIntegerzh_fast)
    }
    s = ( neg ? -s : s );
 
-   /* returns (# alloc :: Int#, 
-                size  :: Int#, 
+   /* returns (# size  :: Int#, 
                 data  :: ByteArray# 
               #)
    */
-   TICK_RET_UNBOXED_TUP(3);
-   RET_NNP(a,s,p);
+   TICK_RET_UNBOXED_TUP(2);
+   RET_NP(s,p);
    FE_
 }
 
@@ -519,7 +539,7 @@ FN_(word64ToIntegerzh_fast)
 
    StgNat64 val; /* to avoid aliasing */
    StgWord hi;
-   I_  s,a,words_needed;
+   I_  s, words_needed;
    StgArrWords* p;     /* address of array result */
    FB_
 
@@ -536,8 +556,6 @@ FN_(word64ToIntegerzh_fast)
    p = stgCast(StgArrWords*,(Hp-words_needed+1))-1;
    SET_ARR_HDR(p, &ARR_WORDS_info, CCCS, words_needed);
 
-   a = words_needed;
-
    hi = (W_)((LW_)val / 0x100000000ULL);
    if ( val >= 0x100000000ULL ) { 
      s = 2;
@@ -550,13 +568,12 @@ FN_(word64ToIntegerzh_fast)
       s = 0;
    }
 
-   /* returns (# alloc :: Int#, 
-                size  :: Int#, 
+   /* returns (# size  :: Int#, 
                 data  :: ByteArray# 
               #)
    */
-   TICK_RET_UNBOXED_TUP(3);
-   RET_NNP(a,s,p);
+   TICK_RET_UNBOXED_TUP(2);
+   RET_NP(s,p);
    FE_
 }
 
@@ -569,25 +586,23 @@ FN_(word64ToIntegerzh_fast)
 FN_(name)                                                              \
 {                                                                      \
   MP_INT arg1, arg2, result;                                           \
-  I_ a1, s1, a2, s2;                                                   \
+  I_ s1, s2;                                                   \
   StgArrWords* d1;                                                     \
   StgArrWords* d2;                                                     \
   FB_                                                                  \
                                                                        \
   /* call doYouWantToGC() */                                           \
-  MAYBE_GC(R3_PTR | R6_PTR, name);                                     \
+  MAYBE_GC(R2_PTR | R4_PTR, name);                                     \
                                                                        \
-  a1 = R1.i;                                                           \
-  s1 = R2.i;                                                           \
-  d1 = stgCast(StgArrWords*,R3.p);                                     \
-  a2 = R4.i;                                                           \
-  s2 = R5.i;                                                           \
-  d2 = stgCast(StgArrWords*,R6.p);                                     \
+  d1 = (StgArrWords *)R2.p;                                            \
+  s1 = R1.i;                                                           \
+  d2 = (StgArrWords *)R4.p;                                            \
+  s2 = R3.i;                                                           \
                                                                        \
-  arg1._mp_alloc       = (a1);                                         \
+  arg1._mp_alloc       = d1->words;                                    \
   arg1._mp_size                = (s1);                                         \
   arg1._mp_d           = (unsigned long int *) (BYTE_ARR_CTS(d1));     \
-  arg2._mp_alloc       = (a2);                                         \
+  arg2._mp_alloc       = d2->words;                                    \
   arg2._mp_size                = (s2);                                         \
   arg2._mp_d           = (unsigned long int *) (BYTE_ARR_CTS(d2));     \
                                                                        \
@@ -596,10 +611,9 @@ FN_(name)                                                          \
   /* Perform the operation */                                          \
   STGCALL3(mp_fun,&result,&arg1,&arg2);                                        \
                                                                        \
-  TICK_RET_UNBOXED_TUP(3);                                             \
-  RET_NNP(result._mp_alloc,                                            \
-         result._mp_size,                                              \
-          result._mp_d-sizeofW(StgArrWords));                          \
+  TICK_RET_UNBOXED_TUP(2);                                             \
+  RET_NP(result._mp_size,                                              \
+         result._mp_d-sizeofW(StgArrWords));                           \
   FE_                                                                  \
 }
 
@@ -607,25 +621,23 @@ FN_(name)                                                         \
 FN_(name)                                                              \
 {                                                                      \
   MP_INT arg1, arg2, result1, result2;                                 \
-  I_ a1, s1, a2, s2;                                                   \
+  I_ s1, s2;                                                   \
   StgArrWords* d1;                                                     \
   StgArrWords* d2;                                                     \
   FB_                                                                  \
                                                                        \
   /* call doYouWantToGC() */                                           \
-  MAYBE_GC(R3_PTR | R6_PTR, name);                                     \
+  MAYBE_GC(R2_PTR | R4_PTR, name);                                     \
                                                                        \
-  a1 = R1.i;                                                           \
-  s1 = R2.i;                                                           \
-  d1 = stgCast(StgArrWords*,R3.p);                                     \
-  a2 = R4.i;                                                           \
-  s2 = R5.i;                                                           \
-  d2 = stgCast(StgArrWords*,R6.p);                                     \
+  d1 = (StgArrWords *)R2.p;                                            \
+  s1 = R1.i;                                                           \
+  d2 = (StgArrWords *)R4.p;                                            \
+  s2 = R3.i;                                                           \
                                                                        \
-  arg1._mp_alloc       = (a1);                                         \
+  arg1._mp_alloc       = d1->words;                                    \
   arg1._mp_size                = (s1);                                         \
   arg1._mp_d           = (unsigned long int *) (BYTE_ARR_CTS(d1));     \
-  arg2._mp_alloc       = (a2);                                         \
+  arg2._mp_alloc       = d2->words;                                    \
   arg2._mp_size                = (s2);                                         \
   arg2._mp_d           = (unsigned long int *) (BYTE_ARR_CTS(d2));     \
                                                                        \
@@ -635,13 +647,11 @@ FN_(name)                                                         \
   /* Perform the operation */                                          \
   STGCALL4(mp_fun,&result1,&result2,&arg1,&arg2);                      \
                                                                        \
-  TICK_RET_UNBOXED_TUP(6);                                             \
-  RET_NNPNNP(result1._mp_alloc,                                                \
-            result1._mp_size,                                          \
-             result1._mp_d-sizeofW(StgArrWords),                       \
-            result2._mp_alloc,                                         \
-            result2._mp_size,                                          \
-             result2._mp_d-sizeofW(StgArrWords));                      \
+  TICK_RET_UNBOXED_TUP(4);                                             \
+  RET_NPNP(result1._mp_size,                                           \
+           result1._mp_d-sizeofW(StgArrWords),                         \
+          result2._mp_size,                                            \
+           result2._mp_d-sizeofW(StgArrWords));                                \
   FE_                                                                  \
 }
 
@@ -678,9 +688,9 @@ FN_(decodeFloatzh_fast)
   /* Perform the operation */
   STGCALL3(__decodeFloat,&mantissa,&exponent,arg);
 
-  /* returns: (R1 = Int# (expn), R2 = Int#, R3 = Int#, R4 = ByteArray#) */
-  TICK_RET_UNBOXED_TUP(4);
-  RET_NNNP(exponent,mantissa._mp_alloc,mantissa._mp_size,p);
+  /* returns: (Int# (expn), Int#, ByteArray#) */
+  TICK_RET_UNBOXED_TUP(3);
+  RET_NNP(exponent,mantissa._mp_size,p);
   FE_
 }
 #endif /* !FLOATS_AS_DOUBLES */
@@ -711,9 +721,9 @@ FN_(decodeDoublezh_fast)
   /* Perform the operation */
   STGCALL3(__decodeDouble,&mantissa,&exponent,arg);
 
-  /* returns: (R1 = Int# (expn), R2 = Int#, R3 = Int#, R4 = ByteArray#) */
-  TICK_RET_UNBOXED_TUP(4);
-  RET_NNNP(exponent,mantissa._mp_alloc,mantissa._mp_size,p);
+  /* returns: (Int# (expn), Int#, ByteArray#) */
+  TICK_RET_UNBOXED_TUP(3);
+  RET_NNP(exponent,mantissa._mp_size,p);
   FE_
 }
 
@@ -873,9 +883,15 @@ FN_(makeStableNamezh_fast)
   
   index = RET_STGCALL1(StgWord,lookupStableName,R1.p);
 
-  sn_obj = (StgStableName *) (Hp - sizeofW(StgStableName) + 1);
-  sn_obj->header.info = &STABLE_NAME_info;
-  sn_obj->sn = index;
+  /* 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->sn = index;
+    stable_ptr_table[index].sn_obj = (StgClosure *)sn_obj;
+  } else {
+    (StgClosure *)sn_obj = stable_ptr_table[index].sn_obj;
+  }
 
   TICK_RET_UNBOXED_TUP(1);
   RET_P(sn_obj);