ghc/rts/RtsAPI.c

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