X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Frts%2FRtsAPI.c;h=b05393bc656c341ce509876f5549a22f1371d9d7;hb=571994d0498da9bab4395022899eb286bbd5153b;hp=0009fb69bdede45e0c41e431c3b967b487cd9f59;hpb=0d5d32bf62c39c390934d9ef4b01e2bf2db910f8;p=ghc-hetmet.git diff --git a/ghc/rts/RtsAPI.c b/ghc/rts/RtsAPI.c index 0009fb6..b05393b 100644 --- a/ghc/rts/RtsAPI.c +++ b/ghc/rts/RtsAPI.c @@ -1,7 +1,7 @@ /* ---------------------------------------------------------------------------- - * $Id: RtsAPI.c,v 1.11 2000/03/13 10:53:56 simonmar Exp $ + * $Id: RtsAPI.c,v 1.25 2001/02/08 14:36:21 simonmar Exp $ * - * (c) The GHC Team, 1998-1999 + * (c) The GHC Team, 1998-2001 * * API for invoking Haskell functions via the RTS * @@ -19,176 +19,166 @@ Building Haskell objects from C datatypes. ------------------------------------------------------------------------- */ HaskellObj -rts_mkChar (char c) +rts_mkChar (HsChar c) { StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1)); - p->header.info = (const StgInfoTable*)&Czh_con_info; - p->payload[0] = (StgClosure *)((StgInt)c); + p->header.info = Czh_con_info; + p->payload[0] = (StgClosure *)(StgChar)c; return p; } HaskellObj -rts_mkInt (int i) +rts_mkInt (HsInt i) { StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1)); - p->header.info = (const StgInfoTable*)&Izh_con_info; + p->header.info = Izh_con_info; p->payload[0] = (StgClosure *)(StgInt)i; return p; } HaskellObj -rts_mkInt8 (int i) +rts_mkInt8 (HsInt8 i) { StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1)); - /* This is a 'cheat', using the static info table for Ints, - instead of the one for Int8, but the types have identical - representation. - */ - p->header.info = (const StgInfoTable*)&Izh_con_info; + p->header.info = I8zh_con_info; /* Make sure we mask out the bits above the lowest 8 */ p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xff); return p; } HaskellObj -rts_mkInt16 (int i) +rts_mkInt16 (HsInt16 i) { StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1)); - /* This is a 'cheat', using the static info table for Ints, - instead of the one for Int8, but the types have identical - representation. - */ - p->header.info = (const StgInfoTable*)&Izh_con_info; + p->header.info = I16zh_con_info; /* Make sure we mask out the relevant bits */ p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xffff); return p; } HaskellObj -rts_mkInt32 (int i) +rts_mkInt32 (HsInt32 i) { StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1)); - /* see mk_Int8 comment */ - p->header.info = (const StgInfoTable*)&Izh_con_info; + p->header.info = I32zh_con_info; p->payload[0] = (StgClosure *)(StgInt)i; return p; } HaskellObj -rts_mkInt64 (long long int i) +rts_mkInt64 (HsInt64 i) { long long *tmp; StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,2)); - /* see mk_Int8 comment */ - p->header.info = (const StgInfoTable*)&I64zh_con_info; + p->header.info = I64zh_con_info; tmp = (long long*)&(p->payload[0]); *tmp = (StgInt64)i; return p; } HaskellObj -rts_mkWord (unsigned int i) +rts_mkWord (HsWord i) { StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1)); - p->header.info = (const StgInfoTable*)&Wzh_con_info; + p->header.info = Wzh_con_info; p->payload[0] = (StgClosure *)(StgWord)i; return p; } HaskellObj -rts_mkWord8 (unsigned int w) +rts_mkWord8 (HsWord8 w) { /* see rts_mkInt* comments */ StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1)); - p->header.info = (const StgInfoTable*)&Wzh_con_info; + p->header.info = W8zh_con_info; p->payload[0] = (StgClosure *)(StgWord)(w & 0xff); return p; } HaskellObj -rts_mkWord16 (unsigned int w) +rts_mkWord16 (HsWord16 w) { /* see rts_mkInt* comments */ StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1)); - p->header.info = (const StgInfoTable*)&Wzh_con_info; + p->header.info = W16zh_con_info; p->payload[0] = (StgClosure *)(StgWord)(w & 0xffff); return p; } HaskellObj -rts_mkWord32 (unsigned int w) +rts_mkWord32 (HsWord32 w) { /* see rts_mkInt* comments */ StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1)); - p->header.info = (const StgInfoTable*)&Wzh_con_info; + p->header.info = W32zh_con_info; p->payload[0] = (StgClosure *)(StgWord)w; return p; } HaskellObj -rts_mkWord64 (unsigned long long w) +rts_mkWord64 (HsWord64 w) { unsigned long long *tmp; StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,2)); /* see mk_Int8 comment */ - p->header.info = (const StgInfoTable*)&W64zh_con_info; + p->header.info = W64zh_con_info; tmp = (unsigned long long*)&(p->payload[0]); *tmp = (StgWord64)w; return p; } HaskellObj -rts_mkFloat (float f) +rts_mkFloat (HsFloat f) { StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1)); - p->header.info = (const StgInfoTable*)&Fzh_con_info; + p->header.info = Fzh_con_info; ASSIGN_FLT((P_)p->payload, (StgFloat)f); return p; } HaskellObj -rts_mkDouble (double d) +rts_mkDouble (HsDouble d) { StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,sizeofW(StgDouble))); - p->header.info = (const StgInfoTable*)&Dzh_con_info; + p->header.info = Dzh_con_info; ASSIGN_DBL((P_)p->payload, (StgDouble)d); return p; } HaskellObj -rts_mkStablePtr (StgStablePtr s) +rts_mkStablePtr (HsStablePtr s) { StgClosure *p = (StgClosure *)allocate(sizeofW(StgHeader)+1); - p->header.info = (const StgInfoTable*)&StablePtr_con_info; + p->header.info = StablePtr_con_info; p->payload[0] = (StgClosure *)s; return p; } HaskellObj -rts_mkAddr (void *a) +rts_mkPtr (HsPtr a) { StgClosure *p = (StgClosure *)allocate(sizeofW(StgHeader)+1); - p->header.info = (const StgInfoTable*)&Azh_con_info; + p->header.info = Ptr_con_info; p->payload[0] = (StgClosure *)a; return p; } #ifdef COMPILER /* GHC has em, Hugs doesn't */ HaskellObj -rts_mkBool (int b) +rts_mkBool (HsBool b) { if (b) { - return (StgClosure *)&True_closure; + return (StgClosure *)True_closure; } else { - return (StgClosure *)&False_closure; + return (StgClosure *)False_closure; } } HaskellObj rts_mkString (char *s) { - return rts_apply((StgClosure *)&unpackCString_closure, rts_mkAddr(s)); + return rts_apply((StgClosure *)unpackCString_closure, rts_mkPtr(s)); } #endif /* COMPILER */ @@ -196,10 +186,10 @@ HaskellObj rts_apply (HaskellObj f, HaskellObj arg) { StgAP_UPD *ap = (StgAP_UPD *)allocate(AP_sizeW(1)); - ap->header.info = &AP_UPD_info; + SET_HDR(ap, &stg_AP_UPD_info, CCS_SYSTEM); ap->n_args = 1; ap->fun = f; - ap->payload[0] = (P_)arg; + ap->payload[0] = arg; return (StgClosure *)ap; } @@ -207,117 +197,116 @@ rts_apply (HaskellObj f, HaskellObj arg) Deconstructing Haskell objects ------------------------------------------------------------------------- */ -char +HsChar rts_getChar (HaskellObj p) { - if ( p->header.info == (const StgInfoTable*)&Czh_con_info || - p->header.info == (const StgInfoTable*)&Czh_static_info) { - return (char)(StgWord)(p->payload[0]); + if ( p->header.info == Czh_con_info || + p->header.info == Czh_static_info) { + return (StgChar)(StgWord)(p->payload[0]); } else { barf("getChar: not a Char"); } } -int +HsInt rts_getInt (HaskellObj p) { if ( 1 || - p->header.info == (const StgInfoTable*)&Izh_con_info || - p->header.info == (const StgInfoTable*)&Izh_static_info ) { + p->header.info == Izh_con_info || + p->header.info == Izh_static_info ) { return (int)(p->payload[0]); } else { barf("getInt: not an Int"); } } -int +HsInt32 rts_getInt32 (HaskellObj p) { if ( 1 || - p->header.info == (const StgInfoTable*)&Izh_con_info || - p->header.info == (const StgInfoTable*)&Izh_static_info ) { + p->header.info == I32zh_con_info || + p->header.info == I32zh_static_info ) { return (int)(p->payload[0]); } else { barf("getInt: not an Int"); } } -unsigned int +HsWord rts_getWord (HaskellObj p) { if ( 1 || /* see above comment */ - p->header.info == (const StgInfoTable*)&Wzh_con_info || - p->header.info == (const StgInfoTable*)&Wzh_static_info ) { + p->header.info == Wzh_con_info || + p->header.info == Wzh_static_info ) { return (unsigned int)(p->payload[0]); } else { barf("getWord: not a Word"); } } -unsigned int +HsWord32 rts_getWord32 (HaskellObj p) { if ( 1 || /* see above comment */ - p->header.info == (const StgInfoTable*)&Wzh_con_info || - p->header.info == (const StgInfoTable*)&Wzh_static_info ) { + p->header.info == W32zh_con_info || + p->header.info == W32zh_static_info ) { return (unsigned int)(p->payload[0]); } else { barf("getWord: not a Word"); } } -float +HsFloat rts_getFloat (HaskellObj p) { - if ( p->header.info == (const StgInfoTable*)&Fzh_con_info || - p->header.info == (const StgInfoTable*)&Fzh_static_info ) { + if ( p->header.info == Fzh_con_info || + p->header.info == Fzh_static_info ) { return (float)(PK_FLT((P_)p->payload)); } else { barf("getFloat: not a Float"); } } -double +HsDouble rts_getDouble (HaskellObj p) { - if ( p->header.info == (const StgInfoTable*)&Dzh_con_info || - p->header.info == (const StgInfoTable*)&Dzh_static_info ) { + if ( p->header.info == Dzh_con_info || + p->header.info == Dzh_static_info ) { return (double)(PK_DBL((P_)p->payload)); } else { barf("getDouble: not a Double"); } } -StgStablePtr +HsStablePtr rts_getStablePtr (HaskellObj p) { - if ( p->header.info == (const StgInfoTable*)&StablePtr_con_info || - p->header.info == (const StgInfoTable*)&StablePtr_static_info ) { + if ( p->header.info == StablePtr_con_info || + p->header.info == StablePtr_static_info ) { return (StgStablePtr)(p->payload[0]); } else { barf("getStablePtr: not a StablePtr"); } } -void * -rts_getAddr (HaskellObj p) +HsPtr +rts_getPtr (HaskellObj p) { - if ( p->header.info == (const StgInfoTable*)&Azh_con_info || - p->header.info == (const StgInfoTable*)&Azh_static_info ) { - + if ( p->header.info == Ptr_con_info || + p->header.info == Ptr_static_info ) { return (void *)(p->payload[0]); } else { - barf("getAddr: not an Addr"); + barf("getPtr: not an Ptr"); } } #ifdef COMPILER /* GHC has em, Hugs doesn't */ -int +HsBool rts_getBool (HaskellObj p) { - if (p == &True_closure) { + if (p == True_closure) { return 1; - } else if (p == &False_closure) { + } else if (p == False_closure) { return 0; } else { barf("getBool: not a Bool"); @@ -367,13 +356,36 @@ rts_evalLazyIO (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret) return waitThread(tso, ret); } -/* Convenience function for decoding the returned status. */ +#if defined(PAR) +/* + Needed in the parallel world for non-Main PEs, which do not get a piece + of work to start with --- they have to humbly ask for it +*/ -void rts_checkSchedStatus ( char* site, SchedulerStatus rc ) +SchedulerStatus +rts_evalNothing(unsigned int stack_size) { - if ( rc == Success ) { - return; - } else { - barf("%s: Return code (%d) not ok",(site),(rc)); - } + /* ToDo: propagate real SchedulerStatus back to caller */ + scheduleThread(END_TSO_QUEUE); + return Success; +} +#endif + +/* Convenience function for decoding the returned status. */ + +void +rts_checkSchedStatus ( char* site, SchedulerStatus rc ) +{ + switch (rc) { + case Success: + return; + case Killed: + barf("%s: uncaught exception",site); + case Interrupted: + barf("%s: interrupted", site); + case Deadlock: + barf("%s: no threads to run: infinite loop or deadlock?", site); + default: + barf("%s: Return code (%d) not ok",(site),(rc)); + } }