From 286a25bb4e6c5baf8900874300dc095705d84918 Mon Sep 17 00:00:00 2001 From: simonmar Date: Mon, 2 Dec 2002 14:33:10 +0000 Subject: [PATCH] [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 --- ghc/rts/RtsAPI.c | 143 +++++++++++++++++++++--------------------------------- 1 file changed, 54 insertions(+), 89 deletions(-) diff --git a/ghc/rts/RtsAPI.c b/ghc/rts/RtsAPI.c index 7449bad..7bfb9d8 100644 --- 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 */ -- 1.7.10.4