ghc/rts/RtsAPI.c

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