ghc/rts/RtsAPI.c

   1 /* ----------------------------------------------------------------------------
   2  * $Id: RtsAPI.c,v 1.34 2002/04/13 05:28:04 sof Exp $
   3  *
   4  * (c) The GHC Team, 1998-2001
   5  *
   6  * API for invoking Haskell functions via the RTS
   7  *
   8  * --------------------------------------------------------------------------*/
   9
  10 #include "PosixSource.h"
  11 #include "Rts.h"
  12 #include "Storage.h"
  13 #include "RtsAPI.h"
  14 #include "SchedAPI.h"
  15 #include "RtsFlags.h"
  16 #include "RtsUtils.h"
  17 #include "Prelude.h"
  18 #include "OSThreads.h"
  19 #include "Schedule.h"
  20
  21 #if defined(THREADED_RTS)
  22 #define WAIT_MAIN_THREAD(tso,ret) waitThread_(tso,ret,rtsFalse)
  23 #define WAIT_EXT_THREAD(tso,ret) waitThread_(tso,ret,rtsTrue)
  24 #else
  25 #define WAIT_MAIN_THREAD(tso,ret) waitThread(tso,ret)
  26 #define WAIT_EXT_THREAD(tso,ret) waitThread(tso,ret)
  27 #endif
  28
  29 #if defined(RTS_SUPPORTS_THREADS)
  30 /* Cheesy locking scheme while waiting for the
  31  * RTS API to change.
  32  */
  33 static Mutex     alloc_mutex = INIT_MUTEX_VAR;
  34 static Condition alloc_cond  = INIT_COND_VAR;
  35 #define INVALID_THREAD_ID ((OSThreadId)(-1))
  36
  37 /* Thread currently owning the allocator */
  38 static OSThreadId c_id = INVALID_THREAD_ID;
  39
  40 static StgPtr alloc(nat n)
  41 {
  42   OSThreadId tid = osThreadId();
  43   ACQUIRE_LOCK(&alloc_mutex);
  44   if (tid == c_id) {
  45     /* I've got the lock, just allocate() */
  46     ;
  47   } else if (c_id == INVALID_THREAD_ID) {
  48     c_id = tid;
  49   } else {
  50     waitCondition(&alloc_cond, &alloc_mutex);
  51     c_id = tid;
  52   }
  53   RELEASE_LOCK(&alloc_mutex);
  54   return allocate(n);
  55 }
  56
  57 static void releaseAllocLock(void)
  58 {
  59   ACQUIRE_LOCK(&alloc_mutex);
  60   /* Reset the allocator owner */
  61   c_id = INVALID_THREAD_ID;
  62   RELEASE_LOCK(&alloc_mutex);
  63
  64   /* Free up an OS thread waiting to get in */
  65   signalCondition(&alloc_cond);
  66 }
  67 #else
  68 # define alloc(n) allocate(n)
  69 # define releaseAllocLock() /* nothing */
  70 #endif
  71
  72
  73 /* ----------------------------------------------------------------------------
  74    Building Haskell objects from C datatypes.
  75    ------------------------------------------------------------------------- */
  76 HaskellObj
  77 rts_mkChar (HsChar c)
  78 {
  79   StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
  80   SET_HDR(p, Czh_con_info, CCS_SYSTEM);
  81   p->payload[0]  = (StgClosure *)(StgChar)c;
  82   return p;
  83 }
  84
  85 HaskellObj
  86 rts_mkInt (HsInt i)
  87 {
  88   StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
  89   SET_HDR(p, Izh_con_info, CCS_SYSTEM);
  90   p->payload[0]  = (StgClosure *)(StgInt)i;
  91   return p;
  92 }
  93
  94 HaskellObj
  95 rts_mkInt8 (HsInt8 i)
  96 {
  97   StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
  98   SET_HDR(p, I8zh_con_info, CCS_SYSTEM);
  99   /* Make sure we mask out the bits above the lowest 8 */
 100   p->payload[0]  = (StgClosure *)(StgInt)((unsigned)i & 0xff);
 101   return p;
 102 }
 103
 104 HaskellObj
 105 rts_mkInt16 (HsInt16 i)
 106 {
 107   StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
 108   SET_HDR(p, I16zh_con_info, CCS_SYSTEM);
 109   /* Make sure we mask out the relevant bits */
 110   p->payload[0]  = (StgClosure *)(StgInt)((unsigned)i & 0xffff);
 111   return p;
 112 }
 113
 114 HaskellObj
 115 rts_mkInt32 (HsInt32 i)
 116 {
 117   StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
 118   SET_HDR(p, I32zh_con_info, CCS_SYSTEM);
 119   p->payload[0]  = (StgClosure *)(StgInt)((unsigned)i & 0xffffffff);
 120   return p;
 121 }
 122
 123 HaskellObj
 124 rts_mkInt64 (HsInt64 i)
 125 {
 126   long long *tmp;
 127   StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,2));
 128   SET_HDR(p, I64zh_con_info, CCS_SYSTEM);
 129   tmp  = (long long*)&(p->payload[0]);
 130   *tmp = (StgInt64)i;
 131   return p;
 132 }
 133
 134 HaskellObj
 135 rts_mkWord (HsWord i)
 136 {
 137   StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
 138   SET_HDR(p, Wzh_con_info, CCS_SYSTEM);
 139   p->payload[0]  = (StgClosure *)(StgWord)i;
 140   return p;
 141 }
 142
 143 HaskellObj
 144 rts_mkWord8 (HsWord8 w)
 145 {
 146   /* see rts_mkInt* comments */
 147   StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
 148   SET_HDR(p, W8zh_con_info, CCS_SYSTEM);
 149   p->payload[0]  = (StgClosure *)(StgWord)(w & 0xff);
 150   return p;
 151 }
 152
 153 HaskellObj
 154 rts_mkWord16 (HsWord16 w)
 155 {
 156   /* see rts_mkInt* comments */
 157   StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
 158   SET_HDR(p, W16zh_con_info, CCS_SYSTEM);
 159   p->payload[0]  = (StgClosure *)(StgWord)(w & 0xffff);
 160   return p;
 161 }
 162
 163 HaskellObj
 164 rts_mkWord32 (HsWord32 w)
 165 {
 166   /* see rts_mkInt* comments */
 167   StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
 168   SET_HDR(p, W32zh_con_info, CCS_SYSTEM);
 169   p->payload[0]  = (StgClosure *)(StgWord)(w & 0xffffffff);
 170   return p;
 171 }
 172
 173 HaskellObj
 174 rts_mkWord64 (HsWord64 w)
 175 {
 176   unsigned long long *tmp;
 177
 178   StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,2));
 179   /* see mk_Int8 comment */
 180   SET_HDR(p, W64zh_con_info, CCS_SYSTEM);
 181   tmp  = (unsigned long long*)&(p->payload[0]);
 182   *tmp = (StgWord64)w;
 183   return p;
 184 }
 185
 186 HaskellObj
 187 rts_mkFloat (HsFloat f)
 188 {
 189   StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
 190   SET_HDR(p, Fzh_con_info, CCS_SYSTEM);
 191   ASSIGN_FLT((P_)p->payload, (StgFloat)f);
 192   return p;
 193 }
 194
 195 HaskellObj
 196 rts_mkDouble (HsDouble d)
 197 {
 198   StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,sizeofW(StgDouble)));
 199   SET_HDR(p, Dzh_con_info, CCS_SYSTEM);
 200   ASSIGN_DBL((P_)p->payload, (StgDouble)d);
 201   return p;
 202 }
 203
 204 HaskellObj
 205 rts_mkStablePtr (HsStablePtr s)
 206 {
 207   StgClosure *p = (StgClosure *)alloc(sizeofW(StgHeader)+1);
 208   SET_HDR(p, StablePtr_con_info, CCS_SYSTEM);
 209   p->payload[0]  = (StgClosure *)s;
 210   return p;
 211 }
 212
 213 HaskellObj
 214 rts_mkPtr (HsPtr a)
 215 {
 216   StgClosure *p = (StgClosure *)alloc(sizeofW(StgHeader)+1);
 217   SET_HDR(p, Ptr_con_info, CCS_SYSTEM);
 218   p->payload[0]  = (StgClosure *)a;
 219   return p;
 220 }
 221
 222 #ifdef COMPILER /* GHC has em, Hugs doesn't */
 223 HaskellObj
 224 rts_mkBool (HsBool b)
 225 {
 226   if (b) {
 227     return (StgClosure *)True_closure;
 228   } else {
 229     return (StgClosure *)False_closure;
 230   }
 231 }
 232
 233 HaskellObj
 234 rts_mkString (char *s)
 235 {
 236   return rts_apply((StgClosure *)unpackCString_closure, rts_mkPtr(s));
 237 }
 238 #endif /* COMPILER */
 239
 240 HaskellObj
 241 rts_apply (HaskellObj f, HaskellObj arg)
 242 {
 243   StgAP_UPD *ap = (StgAP_UPD *)alloc(AP_sizeW(1));
 244   SET_HDR(ap, &stg_AP_UPD_info, CCS_SYSTEM);
 245   ap->n_args = 1;
 246   ap->fun    = f;
 247   ap->payload[0] = arg;
 248   return (StgClosure *)ap;
 249 }
 250
 251 /* ----------------------------------------------------------------------------
 252    Deconstructing Haskell objects
 253    ------------------------------------------------------------------------- */
 254
 255 HsChar
 256 rts_getChar (HaskellObj p)
 257 {
 258   if ( p->header.info == Czh_con_info ||
 259        p->header.info == Czh_static_info) {
 260     return (StgChar)(StgWord)(p->payload[0]);
 261   } else {
 262     barf("rts_getChar: not a Char");
 263   }
 264 }
 265
 266 HsInt
 267 rts_getInt (HaskellObj p)
 268 {
 269   if ( 1 ||
 270        p->header.info == Izh_con_info ||
 271        p->header.info == Izh_static_info ) {
 272     return (HsInt)(p->payload[0]);
 273   } else {
 274     barf("rts_getInt: not an Int");
 275   }
 276 }
 277
 278 HsInt8
 279 rts_getInt8 (HaskellObj p)
 280 {
 281   if ( 1 ||
 282        p->header.info == I8zh_con_info ||
 283        p->header.info == I8zh_static_info ) {
 284     return (HsInt8)(HsInt)(p->payload[0]);
 285   } else {
 286     barf("rts_getInt8: not an Int8");
 287   }
 288 }
 289
 290 HsInt16
 291 rts_getInt16 (HaskellObj p)
 292 {
 293   if ( 1 ||
 294        p->header.info == I16zh_con_info ||
 295        p->header.info == I16zh_static_info ) {
 296     return (HsInt16)(HsInt)(p->payload[0]);
 297   } else {
 298     barf("rts_getInt16: not an Int16");
 299   }
 300 }
 301
 302 HsInt32
 303 rts_getInt32 (HaskellObj p)
 304 {
 305   if ( 1 ||
 306        p->header.info == I32zh_con_info ||
 307        p->header.info == I32zh_static_info ) {
 308     return (HsInt32)(p->payload[0]);
 309   } else {
 310     barf("rts_getInt32: not an Int32");
 311   }
 312 }
 313
 314 HsInt64
 315 rts_getInt64 (HaskellObj p)
 316 {
 317   HsInt64* tmp;
 318   if ( 1 ||
 319        p->header.info == I64zh_con_info ||
 320        p->header.info == I64zh_static_info ) {
 321     tmp = (HsInt64*)&(p->payload[0]);
 322     return *tmp;
 323   } else {
 324     barf("rts_getInt64: not an Int64");
 325   }
 326 }
 327 HsWord
 328 rts_getWord (HaskellObj p)
 329 {
 330   if ( 1 || /* see above comment */
 331        p->header.info == Wzh_con_info ||
 332        p->header.info == Wzh_static_info ) {
 333     return (HsWord)(p->payload[0]);
 334   } else {
 335     barf("rts_getWord: not a Word");
 336   }
 337 }
 338
 339 HsWord8
 340 rts_getWord8 (HaskellObj p)
 341 {
 342   if ( 1 || /* see above comment */
 343        p->header.info == W8zh_con_info ||
 344        p->header.info == W8zh_static_info ) {
 345     return (HsWord8)(HsWord)(p->payload[0]);
 346   } else {
 347     barf("rts_getWord8: not a Word8");
 348   }
 349 }
 350
 351 HsWord16
 352 rts_getWord16 (HaskellObj p)
 353 {
 354   if ( 1 || /* see above comment */
 355        p->header.info == W16zh_con_info ||
 356        p->header.info == W16zh_static_info ) {
 357     return (HsWord16)(HsWord)(p->payload[0]);
 358   } else {
 359     barf("rts_getWord16: not a Word16");
 360   }
 361 }
 362
 363 HsWord32
 364 rts_getWord32 (HaskellObj p)
 365 {
 366   if ( 1 || /* see above comment */
 367        p->header.info == W32zh_con_info ||
 368        p->header.info == W32zh_static_info ) {
 369     return (unsigned int)(p->payload[0]);
 370   } else {
 371     barf("rts_getWord: not a Word");
 372   }
 373 }
 374
 375
 376 HsWord64
 377 rts_getWord64 (HaskellObj p)
 378 {
 379   HsWord64* tmp;
 380   if ( 1 || /* see above comment */
 381        p->header.info == W64zh_con_info ||
 382        p->header.info == W64zh_static_info ) {
 383     tmp = (HsWord64*)&(p->payload[0]);
 384     return *tmp;
 385   } else {
 386     barf("rts_getWord64: not a Word64");
 387   }
 388 }
 389
 390 HsFloat
 391 rts_getFloat (HaskellObj p)
 392 {
 393   if ( p->header.info == Fzh_con_info ||
 394        p->header.info == Fzh_static_info ) {
 395     return (float)(PK_FLT((P_)p->payload));
 396   } else {
 397     barf("rts_getFloat: not a Float");
 398   }
 399 }
 400
 401 HsDouble
 402 rts_getDouble (HaskellObj p)
 403 {
 404   if ( p->header.info == Dzh_con_info ||
 405        p->header.info == Dzh_static_info ) {
 406     return (double)(PK_DBL((P_)p->payload));
 407   } else {
 408     barf("rts_getDouble: not a Double");
 409   }
 410 }
 411
 412 HsStablePtr
 413 rts_getStablePtr (HaskellObj p)
 414 {
 415   if ( p->header.info == StablePtr_con_info ||
 416        p->header.info == StablePtr_static_info ) {
 417     return (StgStablePtr)(p->payload[0]);
 418   } else {
 419     barf("rts_getStablePtr: not a StablePtr");
 420   }
 421 }
 422
 423 HsPtr
 424 rts_getPtr (HaskellObj p)
 425 {
 426   if ( p->header.info == Ptr_con_info ||
 427        p->header.info == Ptr_static_info ) {
 428     return (void *)(p->payload[0]);
 429   } else {
 430     barf("rts_getPtr: not an Ptr");
 431   }
 432 }
 433
 434 #ifdef COMPILER /* GHC has em, Hugs doesn't */
 435 HsBool
 436 rts_getBool (HaskellObj p)
 437 {
 438   if (p == True_closure) {
 439     return 1;
 440   } else if (p == False_closure) {
 441     return 0;
 442   } else {
 443     barf("rts_getBool: not a Bool");
 444   }
 445 }
 446 #endif /* COMPILER */
 447
 448 /* ----------------------------------------------------------------------------
 449    Evaluating Haskell expressions
 450    ------------------------------------------------------------------------- */
 451 SchedulerStatus
 452 rts_eval (HaskellObj p, /*out*/HaskellObj *ret)
 453 {
 454     StgTSO *tso;
 455
 456     tso = createGenThread(RtsFlags.GcFlags.initialStkSize, p);
 457     releaseAllocLock();
 458     scheduleExtThread(tso);
 459     return WAIT_EXT_THREAD(tso, ret);
 460 }
 461
 462 SchedulerStatus
 463 rts_eval_ (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
 464 {
 465     StgTSO *tso;
 466
 467     tso = createGenThread(stack_size, p);
 468     releaseAllocLock();
 469     scheduleExtThread(tso);
 470     return WAIT_EXT_THREAD(tso, ret);
 471 }
 472
 473 /*
 474  * rts_evalIO() evaluates a value of the form (IO a), forcing the action's
 475  * result to WHNF before returning.
 476  */
 477 SchedulerStatus
 478 rts_evalIO (HaskellObj p, /*out*/HaskellObj *ret)
 479 {
 480     StgTSO* tso;
 481
 482     tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
 483     releaseAllocLock();
 484     scheduleExtThread(tso);
 485     return WAIT_EXT_THREAD(tso, ret);
 486 }
 487
 488 /*
 489  * Identical to rts_evalIO(), but won't create a new task/OS thread
 490  * to evaluate the Haskell thread. Used by main() only. Hack.
 491  */
 492 SchedulerStatus
 493 rts_mainEvalIO(HaskellObj p, /*out*/HaskellObj *ret)
 494 {
 495     StgTSO* tso;
 496
 497     tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
 498     releaseAllocLock();
 499     scheduleThread(tso);
 500     return WAIT_MAIN_THREAD(tso, ret);
 501 }
 502
 503 /*
 504  * rts_evalStableIO() is suitable for calling from Haskell.  It
 505  * evaluates a value of the form (StablePtr (IO a)), forcing the
 506  * action's result to WHNF before returning.  The result is returned
 507  * in a StablePtr.
 508  */
 509 SchedulerStatus
 510 rts_evalStableIO (HsStablePtr s, /*out*/HsStablePtr *ret)
 511 {
 512     StgTSO* tso;
 513     StgClosure *p, *r;
 514     SchedulerStatus stat;
 515
 516     p = (StgClosure *)deRefStablePtr(s);
 517     tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
 518     releaseAllocLock();
 519     scheduleExtThread(tso);
 520     stat = WAIT_EXT_THREAD(tso, &r);
 521
 522     if (stat == Success) {
 523         ASSERT(r != NULL);
 524         *ret = getStablePtr((StgPtr)r);
 525     }
 526
 527     return stat;
 528 }
 529
 530 /*
 531  * Like rts_evalIO(), but doesn't force the action's result.
 532  */
 533 SchedulerStatus
 534 rts_evalLazyIO (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
 535 {
 536     StgTSO *tso;
 537
 538     tso = createIOThread(stack_size, p);
 539     releaseAllocLock();
 540     scheduleExtThread(tso);
 541     return WAIT_EXT_THREAD(tso, ret);
 542 }
 543
 544 /* Convenience function for decoding the returned status. */
 545
 546 void
 547 rts_checkSchedStatus ( char* site, SchedulerStatus rc )
 548 {
 549     switch (rc) {
 550     case Success:
 551         return;
 552     case Killed:
 553         barf("%s: uncaught exception",site);
 554     case Interrupted:
 555         barf("%s: interrupted", site);
 556     default:
 557         barf("%s: Return code (%d) not ok",(site),(rc));
 558     }
 559 }