[project @ 2002-12-02 14:33:10 by simonmar]

Fix a bug and clean up some cruft in here:

 - In each function in the rts_getXXXX() family, there was a test that
   the object is actually of the desired type by examining its info
   table.  Some of these tests were disabled, but there was no comment
   explaining why.  I've just (re-)discovered the reason: the
   info table might be dynamically-loaded in the GHCi case.

   Not all the tests were disabled, which lead to bugs using the FFI
   in GHCi (in particular with functions that return Float or Double).

 - I've added consistent, but commented out, assertions to each of
   the rts_getXXXX() functions, and left a comment explaining why
   these reasonable-looking assertions are disabled.

MERGE TO STABLE

diff --git a/ghc/rts/RtsAPI.c b/ghc/rts/RtsAPI.c
index 7449bad..7bfb9d8 100644 (file)
--- a/ghc/rts/RtsAPI.c
+++ b/ghc/rts/RtsAPI.c
@@ -1,5 +1,5 @@
 /* ----------------------------------------------------------------------------
- * $Id: RtsAPI.c,v 1.36 2002/08/16 14:30:21 simonmar Exp $
+ * $Id: RtsAPI.c,v 1.37 2002/12/02 14:33:10 simonmar Exp $
  *
  * (c) The GHC Team, 1998-2001
  *
@@ -243,185 +243,150 @@ rts_apply (HaskellObj f, HaskellObj arg)
 
 /* ----------------------------------------------------------------------------
    Deconstructing Haskell objects
+
+   We would like to assert that we have the right kind of object in
+   each case, but this is problematic because in GHCi the info table
+   for the D# constructor (say) might be dynamically loaded.  Hence we
+   omit these assertions for now.
    ------------------------------------------------------------------------- */
 
 HsChar
 rts_getChar (HaskellObj p)
 {
-  if ( p->header.info == Czh_con_info || 
-       p->header.info == Czh_static_info) {
+    // See comment above:
+    // ASSERT(p->header.info == Czh_con_info ||
+    //        p->header.info == Czh_static_info);
     return (StgChar)(StgWord)(p->payload[0]);
-  } else {
-    barf("rts_getChar: not a Char");
-  }
 }
 
 HsInt
 rts_getInt (HaskellObj p)
 {
-  if ( 1 ||
-       p->header.info == Izh_con_info || 
-       p->header.info == Izh_static_info ) {
+    // See comment above:
+    // ASSERT(p->header.info == Izh_con_info ||
+    //        p->header.info == Izh_static_info);
     return (HsInt)(p->payload[0]);
-  } else {
-    barf("rts_getInt: not an Int");
-  }
 }
 
 HsInt8
 rts_getInt8 (HaskellObj p)
 {
-  if ( 1 ||
-       p->header.info == I8zh_con_info || 
-       p->header.info == I8zh_static_info ) {
+    // See comment above:
+    // ASSERT(p->header.info == I8zh_con_info ||
+    //        p->header.info == I8zh_static_info);
     return (HsInt8)(HsInt)(p->payload[0]);
-  } else {
-    barf("rts_getInt8: not an Int8");
-  }
 }
 
 HsInt16
 rts_getInt16 (HaskellObj p)
 {
-  if ( 1 ||
-       p->header.info == I16zh_con_info || 
-       p->header.info == I16zh_static_info ) {
+    // See comment above:
+    // ASSERT(p->header.info == I16zh_con_info ||
+    //        p->header.info == I16zh_static_info);
     return (HsInt16)(HsInt)(p->payload[0]);
-  } else {
-    barf("rts_getInt16: not an Int16");
-  }
 }
 
 HsInt32
 rts_getInt32 (HaskellObj p)
 {
-  if ( 1 ||
-       p->header.info == I32zh_con_info || 
-       p->header.info == I32zh_static_info ) {
+    // See comment above:
+    // ASSERT(p->header.info == I32zh_con_info ||
+    //        p->header.info == I32zh_static_info);
     return (HsInt32)(p->payload[0]);
-  } else {
-    barf("rts_getInt32: not an Int32");
-  }
 }
 
 HsInt64
 rts_getInt64 (HaskellObj p)
 {
-  HsInt64* tmp;
-  if ( 1 ||
-       p->header.info == I64zh_con_info || 
-       p->header.info == I64zh_static_info ) {
+    HsInt64* tmp;
+    // See comment above:
+    // ASSERT(p->header.info == I64zh_con_info ||
+    //        p->header.info == I64zh_static_info);
     tmp = (HsInt64*)&(p->payload[0]);
     return *tmp;
-  } else {
-    barf("rts_getInt64: not an Int64");
-  }
 }
 HsWord
 rts_getWord (HaskellObj p)
 {
-  if ( 1 || /* see above comment */
-       p->header.info == Wzh_con_info ||
-       p->header.info == Wzh_static_info ) {
+    // See comment above:
+    // ASSERT(p->header.info == Wzh_con_info ||
+    //        p->header.info == Wzh_static_info);
     return (HsWord)(p->payload[0]);
-  } else {
-    barf("rts_getWord: not a Word");
-  }
 }
 
 HsWord8
 rts_getWord8 (HaskellObj p)
 {
-  if ( 1 || /* see above comment */
-       p->header.info == W8zh_con_info ||
-       p->header.info == W8zh_static_info ) {
+    // See comment above:
+    // ASSERT(p->header.info == W8zh_con_info ||
+    //        p->header.info == W8zh_static_info);
     return (HsWord8)(HsWord)(p->payload[0]);
-  } else {
-    barf("rts_getWord8: not a Word8");
-  }
 }
 
 HsWord16
 rts_getWord16 (HaskellObj p)
 {
-  if ( 1 || /* see above comment */
-       p->header.info == W16zh_con_info ||
-       p->header.info == W16zh_static_info ) {
+    // See comment above:
+    // ASSERT(p->header.info == W16zh_con_info ||
+    //        p->header.info == W16zh_static_info);
     return (HsWord16)(HsWord)(p->payload[0]);
-  } else {
-    barf("rts_getWord16: not a Word16");
-  }
 }
 
 HsWord32
 rts_getWord32 (HaskellObj p)
 {
-  if ( 1 || /* see above comment */
-       p->header.info == W32zh_con_info ||
-       p->header.info == W32zh_static_info ) {
-    return (unsigned int)(p->payload[0]);
-  } else {
-    barf("rts_getWord: not a Word");
-  }
+    // See comment above:
+    // ASSERT(p->header.info == W32zh_con_info ||
+    //        p->header.info == W32zh_static_info);
+    return (HsWord32)(p->payload[0]);
 }
 
 
 HsWord64
 rts_getWord64 (HaskellObj p)
 {
-  HsWord64* tmp;
-  if ( 1 || /* see above comment */
-       p->header.info == W64zh_con_info ||
-       p->header.info == W64zh_static_info ) {
+    HsWord64* tmp;
+    // See comment above:
+    // ASSERT(p->header.info == W64zh_con_info ||
+    //        p->header.info == W64zh_static_info);
     tmp = (HsWord64*)&(p->payload[0]);
     return *tmp;
-  } else {
-    barf("rts_getWord64: not a Word64");
-  }
 }
 
 HsFloat
 rts_getFloat (HaskellObj p)
 {
-  if ( p->header.info == Fzh_con_info || 
-       p->header.info == Fzh_static_info ) {
+    // See comment above:
+    // ASSERT(p->header.info == Fzh_con_info ||
+    //        p->header.info == Fzh_static_info);
     return (float)(PK_FLT((P_)p->payload));
-  } else {
-    barf("rts_getFloat: not a Float");
-  }
 }
 
 HsDouble
 rts_getDouble (HaskellObj p)
 {
-  if ( p->header.info == Dzh_con_info || 
-       p->header.info == Dzh_static_info ) {
+    // See comment above:
+    // ASSERT(p->header.info == Dzh_con_info ||
+    //        p->header.info == Dzh_static_info);
     return (double)(PK_DBL((P_)p->payload));
-  } else {
-    barf("rts_getDouble: not a Double");
-  }
 }
 
 HsStablePtr
 rts_getStablePtr (HaskellObj p)
 {
-  if ( p->header.info == StablePtr_con_info || 
-       p->header.info == StablePtr_static_info ) {
+    // See comment above:
+    // ASSERT(p->header.info == StablePtr_con_info ||
+    //        p->header.info == StablePtr_static_info);
     return (StgStablePtr)(p->payload[0]);
-  } else {
-    barf("rts_getStablePtr: not a StablePtr");
-  }
 }
 
 HsPtr
 rts_getPtr (HaskellObj p)
 {
-  if ( p->header.info == Ptr_con_info || 
-       p->header.info == Ptr_static_info ) {
+    // See comment above:
+    // ASSERT(p->header.info == Ptr_con_info ||
+    //        p->header.info == Ptr_static_info);
     return (void *)(p->payload[0]);
-  } else {
-    barf("rts_getPtr: not an Ptr");
-  }
 }
 
 #ifdef COMPILER /* GHC has em, Hugs doesn't */