ghc/rts/RtsAPI.c

   1 /* ----------------------------------------------------------------------------
   2  * $Id: RtsAPI.c,v 1.37 2002/12/02 14:33:10 simonmar 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     StgClosure *ap;
 236
 237     ap = (StgClosure *)alloc(sizeofW(StgClosure) + 2);
 238     SET_HDR(ap, (StgInfoTable *)&stg_ap_2_upd_info, CCS_SYSTEM);
 239     ap->payload[0] = f;
 240     ap->payload[1] = arg;
 241     return (StgClosure *)ap;
 242 }
 243
 244 /* ----------------------------------------------------------------------------
 245    Deconstructing Haskell objects
 246
 247    We would like to assert that we have the right kind of object in
 248    each case, but this is problematic because in GHCi the info table
 249    for the D# constructor (say) might be dynamically loaded.  Hence we
 250    omit these assertions for now.
 251    ------------------------------------------------------------------------- */
 252
 253 HsChar
 254 rts_getChar (HaskellObj p)
 255 {
 256     // See comment above:
 257     // ASSERT(p->header.info == Czh_con_info ||
 258     //        p->header.info == Czh_static_info);
 259     return (StgChar)(StgWord)(p->payload[0]);
 260 }
 261
 262 HsInt
 263 rts_getInt (HaskellObj p)
 264 {
 265     // See comment above:
 266     // ASSERT(p->header.info == Izh_con_info ||
 267     //        p->header.info == Izh_static_info);
 268     return (HsInt)(p->payload[0]);
 269 }
 270
 271 HsInt8
 272 rts_getInt8 (HaskellObj p)
 273 {
 274     // See comment above:
 275     // ASSERT(p->header.info == I8zh_con_info ||
 276     //        p->header.info == I8zh_static_info);
 277     return (HsInt8)(HsInt)(p->payload[0]);
 278 }
 279
 280 HsInt16
 281 rts_getInt16 (HaskellObj p)
 282 {
 283     // See comment above:
 284     // ASSERT(p->header.info == I16zh_con_info ||
 285     //        p->header.info == I16zh_static_info);
 286     return (HsInt16)(HsInt)(p->payload[0]);
 287 }
 288
 289 HsInt32
 290 rts_getInt32 (HaskellObj p)
 291 {
 292     // See comment above:
 293     // ASSERT(p->header.info == I32zh_con_info ||
 294     //        p->header.info == I32zh_static_info);
 295     return (HsInt32)(p->payload[0]);
 296 }
 297
 298 HsInt64
 299 rts_getInt64 (HaskellObj p)
 300 {
 301     HsInt64* tmp;
 302     // See comment above:
 303     // ASSERT(p->header.info == I64zh_con_info ||
 304     //        p->header.info == I64zh_static_info);
 305     tmp = (HsInt64*)&(p->payload[0]);
 306     return *tmp;
 307 }
 308 HsWord
 309 rts_getWord (HaskellObj p)
 310 {
 311     // See comment above:
 312     // ASSERT(p->header.info == Wzh_con_info ||
 313     //        p->header.info == Wzh_static_info);
 314     return (HsWord)(p->payload[0]);
 315 }
 316
 317 HsWord8
 318 rts_getWord8 (HaskellObj p)
 319 {
 320     // See comment above:
 321     // ASSERT(p->header.info == W8zh_con_info ||
 322     //        p->header.info == W8zh_static_info);
 323     return (HsWord8)(HsWord)(p->payload[0]);
 324 }
 325
 326 HsWord16
 327 rts_getWord16 (HaskellObj p)
 328 {
 329     // See comment above:
 330     // ASSERT(p->header.info == W16zh_con_info ||
 331     //        p->header.info == W16zh_static_info);
 332     return (HsWord16)(HsWord)(p->payload[0]);
 333 }
 334
 335 HsWord32
 336 rts_getWord32 (HaskellObj p)
 337 {
 338     // See comment above:
 339     // ASSERT(p->header.info == W32zh_con_info ||
 340     //        p->header.info == W32zh_static_info);
 341     return (HsWord32)(p->payload[0]);
 342 }
 343
 344
 345 HsWord64
 346 rts_getWord64 (HaskellObj p)
 347 {
 348     HsWord64* tmp;
 349     // See comment above:
 350     // ASSERT(p->header.info == W64zh_con_info ||
 351     //        p->header.info == W64zh_static_info);
 352     tmp = (HsWord64*)&(p->payload[0]);
 353     return *tmp;
 354 }
 355
 356 HsFloat
 357 rts_getFloat (HaskellObj p)
 358 {
 359     // See comment above:
 360     // ASSERT(p->header.info == Fzh_con_info ||
 361     //        p->header.info == Fzh_static_info);
 362     return (float)(PK_FLT((P_)p->payload));
 363 }
 364
 365 HsDouble
 366 rts_getDouble (HaskellObj p)
 367 {
 368     // See comment above:
 369     // ASSERT(p->header.info == Dzh_con_info ||
 370     //        p->header.info == Dzh_static_info);
 371     return (double)(PK_DBL((P_)p->payload));
 372 }
 373
 374 HsStablePtr
 375 rts_getStablePtr (HaskellObj p)
 376 {
 377     // See comment above:
 378     // ASSERT(p->header.info == StablePtr_con_info ||
 379     //        p->header.info == StablePtr_static_info);
 380     return (StgStablePtr)(p->payload[0]);
 381 }
 382
 383 HsPtr
 384 rts_getPtr (HaskellObj p)
 385 {
 386     // See comment above:
 387     // ASSERT(p->header.info == Ptr_con_info ||
 388     //        p->header.info == Ptr_static_info);
 389     return (void *)(p->payload[0]);
 390 }
 391
 392 #ifdef COMPILER /* GHC has em, Hugs doesn't */
 393 HsBool
 394 rts_getBool (HaskellObj p)
 395 {
 396   if (p == True_closure) {
 397     return 1;
 398   } else if (p == False_closure) {
 399     return 0;
 400   } else {
 401     barf("rts_getBool: not a Bool");
 402   }
 403 }
 404 #endif /* COMPILER */
 405
 406 /* ----------------------------------------------------------------------------
 407    Evaluating Haskell expressions
 408    ------------------------------------------------------------------------- */
 409 SchedulerStatus
 410 rts_eval (HaskellObj p, /*out*/HaskellObj *ret)
 411 {
 412     StgTSO *tso;
 413
 414     tso = createGenThread(RtsFlags.GcFlags.initialStkSize, p);
 415     releaseAllocLock();
 416     return scheduleWaitThread(tso,ret);
 417 }
 418
 419 SchedulerStatus
 420 rts_eval_ (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
 421 {
 422     StgTSO *tso;
 423
 424     tso = createGenThread(stack_size, p);
 425     releaseAllocLock();
 426     return scheduleWaitThread(tso,ret);
 427 }
 428
 429 /*
 430  * rts_evalIO() evaluates a value of the form (IO a), forcing the action's
 431  * result to WHNF before returning.
 432  */
 433 SchedulerStatus
 434 rts_evalIO (HaskellObj p, /*out*/HaskellObj *ret)
 435 {
 436     StgTSO* tso;
 437
 438     tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
 439     releaseAllocLock();
 440     return scheduleWaitThread(tso,ret);
 441 }
 442
 443 /*
 444  * Identical to rts_evalIO(), but won't create a new task/OS thread
 445  * to evaluate the Haskell thread. Used by main() only. Hack.
 446  */
 447 SchedulerStatus
 448 rts_mainEvalIO(HaskellObj p, /*out*/HaskellObj *ret)
 449 {
 450     StgTSO* tso;
 451
 452     tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
 453     releaseAllocLock();
 454     scheduleThread(tso);
 455     return waitThread(tso, ret);
 456 }
 457
 458 /*
 459  * rts_evalStableIO() is suitable for calling from Haskell.  It
 460  * evaluates a value of the form (StablePtr (IO a)), forcing the
 461  * action's result to WHNF before returning.  The result is returned
 462  * in a StablePtr.
 463  */
 464 SchedulerStatus
 465 rts_evalStableIO (HsStablePtr s, /*out*/HsStablePtr *ret)
 466 {
 467     StgTSO* tso;
 468     StgClosure *p, *r;
 469     SchedulerStatus stat;
 470
 471     p = (StgClosure *)deRefStablePtr(s);
 472     tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
 473     releaseAllocLock();
 474     stat = scheduleWaitThread(tso,&r);
 475
 476     if (stat == Success) {
 477         ASSERT(r != NULL);
 478         *ret = getStablePtr((StgPtr)r);
 479     }
 480
 481     return stat;
 482 }
 483
 484 /*
 485  * Like rts_evalIO(), but doesn't force the action's result.
 486  */
 487 SchedulerStatus
 488 rts_evalLazyIO (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
 489 {
 490     StgTSO *tso;
 491
 492     tso = createIOThread(stack_size, p);
 493     releaseAllocLock();
 494     return scheduleWaitThread(tso,ret);
 495 }
 496
 497 /* Convenience function for decoding the returned status. */
 498
 499 void
 500 rts_checkSchedStatus ( char* site, SchedulerStatus rc )
 501 {
 502     switch (rc) {
 503     case Success:
 504         return;
 505     case Killed:
 506         barf("%s: uncaught exception",site);
 507     case Interrupted:
 508         barf("%s: interrupted", site);
 509     default:
 510         barf("%s: Return code (%d) not ok",(site),(rc));
 511     }
 512 }