rts/RtsAPI.c

   1 /* ----------------------------------------------------------------------------
   2  *
   3  * (c) The GHC Team, 1998-2001
   4  *
   5  * API for invoking Haskell functions via the RTS
   6  *
   7  * --------------------------------------------------------------------------*/
   8
   9 #include "PosixSource.h"
  10 #include "Rts.h"
  11 #include "OSThreads.h"
  12 #include "RtsAPI.h"
  13 #include "SchedAPI.h"
  14 #include "RtsFlags.h"
  15 #include "RtsUtils.h"
  16 #include "Prelude.h"
  17 #include "Schedule.h"
  18 #include "Capability.h"
  19 #include "Stable.h"
  20
  21 #include <stdlib.h>
  22
  23 /* ----------------------------------------------------------------------------
  24    Building Haskell objects from C datatypes.
  25
  26    TODO: Currently this code does not tag created pointers,
  27          however it is not unsafe (the contructor code will do it)
  28          just inefficient.
  29    ------------------------------------------------------------------------- */
  30 HaskellObj
  31 rts_mkChar (Capability *cap, HsChar c)
  32 {
  33   StgClosure *p = (StgClosure *)allocateLocal(cap, CONSTR_sizeW(0,1));
  34   SET_HDR(p, Czh_con_info, CCS_SYSTEM);
  35   p->payload[0]  = (StgClosure *)(StgWord)(StgChar)c;
  36   return p;
  37 }
  38
  39 HaskellObj
  40 rts_mkInt (Capability *cap, HsInt i)
  41 {
  42   StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
  43   SET_HDR(p, Izh_con_info, CCS_SYSTEM);
  44   p->payload[0]  = (StgClosure *)(StgInt)i;
  45   return p;
  46 }
  47
  48 HaskellObj
  49 rts_mkInt8 (Capability *cap, HsInt8 i)
  50 {
  51   StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
  52   SET_HDR(p, I8zh_con_info, CCS_SYSTEM);
  53   /* Make sure we mask out the bits above the lowest 8 */
  54   p->payload[0]  = (StgClosure *)(StgInt)((unsigned)i & 0xff);
  55   return p;
  56 }
  57
  58 HaskellObj
  59 rts_mkInt16 (Capability *cap, HsInt16 i)
  60 {
  61   StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
  62   SET_HDR(p, I16zh_con_info, CCS_SYSTEM);
  63   /* Make sure we mask out the relevant bits */
  64   p->payload[0]  = (StgClosure *)(StgInt)((unsigned)i & 0xffff);
  65   return p;
  66 }
  67
  68 HaskellObj
  69 rts_mkInt32 (Capability *cap, HsInt32 i)
  70 {
  71   StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
  72   SET_HDR(p, I32zh_con_info, CCS_SYSTEM);
  73   p->payload[0]  = (StgClosure *)(StgInt)((unsigned)i & 0xffffffff);
  74   return p;
  75 }
  76
  77 HaskellObj
  78 rts_mkInt64 (Capability *cap, HsInt64 i)
  79 {
  80   llong *tmp;
  81   StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,2));
  82   SET_HDR(p, I64zh_con_info, CCS_SYSTEM);
  83   tmp  = (llong*)&(p->payload[0]);
  84   *tmp = (StgInt64)i;
  85   return p;
  86 }
  87
  88 HaskellObj
  89 rts_mkWord (Capability *cap, HsWord i)
  90 {
  91   StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
  92   SET_HDR(p, Wzh_con_info, CCS_SYSTEM);
  93   p->payload[0]  = (StgClosure *)(StgWord)i;
  94   return p;
  95 }
  96
  97 HaskellObj
  98 rts_mkWord8 (Capability *cap, HsWord8 w)
  99 {
 100   /* see rts_mkInt* comments */
 101   StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
 102   SET_HDR(p, W8zh_con_info, CCS_SYSTEM);
 103   p->payload[0]  = (StgClosure *)(StgWord)(w & 0xff);
 104   return p;
 105 }
 106
 107 HaskellObj
 108 rts_mkWord16 (Capability *cap, HsWord16 w)
 109 {
 110   /* see rts_mkInt* comments */
 111   StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
 112   SET_HDR(p, W16zh_con_info, CCS_SYSTEM);
 113   p->payload[0]  = (StgClosure *)(StgWord)(w & 0xffff);
 114   return p;
 115 }
 116
 117 HaskellObj
 118 rts_mkWord32 (Capability *cap, HsWord32 w)
 119 {
 120   /* see rts_mkInt* comments */
 121   StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
 122   SET_HDR(p, W32zh_con_info, CCS_SYSTEM);
 123   p->payload[0]  = (StgClosure *)(StgWord)(w & 0xffffffff);
 124   return p;
 125 }
 126
 127 HaskellObj
 128 rts_mkWord64 (Capability *cap, HsWord64 w)
 129 {
 130   ullong *tmp;
 131
 132   StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,2));
 133   /* see mk_Int8 comment */
 134   SET_HDR(p, W64zh_con_info, CCS_SYSTEM);
 135   tmp  = (ullong*)&(p->payload[0]);
 136   *tmp = (StgWord64)w;
 137   return p;
 138 }
 139
 140 HaskellObj
 141 rts_mkFloat (Capability *cap, HsFloat f)
 142 {
 143   StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
 144   SET_HDR(p, Fzh_con_info, CCS_SYSTEM);
 145   ASSIGN_FLT((P_)p->payload, (StgFloat)f);
 146   return p;
 147 }
 148
 149 HaskellObj
 150 rts_mkDouble (Capability *cap, HsDouble d)
 151 {
 152   StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,sizeofW(StgDouble)));
 153   SET_HDR(p, Dzh_con_info, CCS_SYSTEM);
 154   ASSIGN_DBL((P_)p->payload, (StgDouble)d);
 155   return p;
 156 }
 157
 158 HaskellObj
 159 rts_mkStablePtr (Capability *cap, HsStablePtr s)
 160 {
 161   StgClosure *p = (StgClosure *)allocateLocal(cap,sizeofW(StgHeader)+1);
 162   SET_HDR(p, StablePtr_con_info, CCS_SYSTEM);
 163   p->payload[0]  = (StgClosure *)s;
 164   return p;
 165 }
 166
 167 HaskellObj
 168 rts_mkPtr (Capability *cap, HsPtr a)
 169 {
 170   StgClosure *p = (StgClosure *)allocateLocal(cap,sizeofW(StgHeader)+1);
 171   SET_HDR(p, Ptr_con_info, CCS_SYSTEM);
 172   p->payload[0]  = (StgClosure *)a;
 173   return p;
 174 }
 175
 176 HaskellObj
 177 rts_mkFunPtr (Capability *cap, HsFunPtr a)
 178 {
 179   StgClosure *p = (StgClosure *)allocateLocal(cap,sizeofW(StgHeader)+1);
 180   SET_HDR(p, FunPtr_con_info, CCS_SYSTEM);
 181   p->payload[0]  = (StgClosure *)a;
 182   return p;
 183 }
 184
 185 HaskellObj
 186 rts_mkBool (Capability *cap STG_UNUSED, HsBool b)
 187 {
 188   if (b) {
 189     return (StgClosure *)True_closure;
 190   } else {
 191     return (StgClosure *)False_closure;
 192   }
 193 }
 194
 195 HaskellObj
 196 rts_mkString (Capability *cap, char *s)
 197 {
 198   return rts_apply(cap, (StgClosure *)unpackCString_closure, rts_mkPtr(cap,s));
 199 }
 200
 201 HaskellObj
 202 rts_apply (Capability *cap, HaskellObj f, HaskellObj arg)
 203 {
 204     StgThunk *ap;
 205
 206     ap = (StgThunk *)allocateLocal(cap,sizeofW(StgThunk) + 2);
 207     SET_HDR(ap, (StgInfoTable *)&stg_ap_2_upd_info, CCS_SYSTEM);
 208     ap->payload[0] = f;
 209     ap->payload[1] = arg;
 210     return (StgClosure *)ap;
 211 }
 212
 213 /* ----------------------------------------------------------------------------
 214    Deconstructing Haskell objects
 215
 216    We would like to assert that we have the right kind of object in
 217    each case, but this is problematic because in GHCi the info table
 218    for the D# constructor (say) might be dynamically loaded.  Hence we
 219    omit these assertions for now.
 220    ------------------------------------------------------------------------- */
 221
 222 HsChar
 223 rts_getChar (HaskellObj p)
 224 {
 225     // See comment above:
 226     // ASSERT(p->header.info == Czh_con_info ||
 227     //        p->header.info == Czh_static_info);
 228     return (StgChar)(StgWord)(UNTAG_CLOSURE(p)->payload[0]);
 229 }
 230
 231 HsInt
 232 rts_getInt (HaskellObj p)
 233 {
 234     // See comment above:
 235     // ASSERT(p->header.info == Izh_con_info ||
 236     //        p->header.info == Izh_static_info);
 237     return (HsInt)(UNTAG_CLOSURE(p)->payload[0]);
 238 }
 239
 240 HsInt8
 241 rts_getInt8 (HaskellObj p)
 242 {
 243     // See comment above:
 244     // ASSERT(p->header.info == I8zh_con_info ||
 245     //        p->header.info == I8zh_static_info);
 246     return (HsInt8)(HsInt)(UNTAG_CLOSURE(p)->payload[0]);
 247 }
 248
 249 HsInt16
 250 rts_getInt16 (HaskellObj p)
 251 {
 252     // See comment above:
 253     // ASSERT(p->header.info == I16zh_con_info ||
 254     //        p->header.info == I16zh_static_info);
 255     return (HsInt16)(HsInt)(UNTAG_CLOSURE(p)->payload[0]);
 256 }
 257
 258 HsInt32
 259 rts_getInt32 (HaskellObj p)
 260 {
 261     // See comment above:
 262     // ASSERT(p->header.info == I32zh_con_info ||
 263     //        p->header.info == I32zh_static_info);
 264   return (HsInt32)(HsInt)(UNTAG_CLOSURE(p)->payload[0]);
 265 }
 266
 267 HsInt64
 268 rts_getInt64 (HaskellObj p)
 269 {
 270     HsInt64* tmp;
 271     // See comment above:
 272     // ASSERT(p->header.info == I64zh_con_info ||
 273     //        p->header.info == I64zh_static_info);
 274     tmp = (HsInt64*)&(UNTAG_CLOSURE(p)->payload[0]);
 275     return *tmp;
 276 }
 277 HsWord
 278 rts_getWord (HaskellObj p)
 279 {
 280     // See comment above:
 281     // ASSERT(p->header.info == Wzh_con_info ||
 282     //        p->header.info == Wzh_static_info);
 283     return (HsWord)(UNTAG_CLOSURE(p)->payload[0]);
 284 }
 285
 286 HsWord8
 287 rts_getWord8 (HaskellObj p)
 288 {
 289     // See comment above:
 290     // ASSERT(p->header.info == W8zh_con_info ||
 291     //        p->header.info == W8zh_static_info);
 292     return (HsWord8)(HsWord)(UNTAG_CLOSURE(p)->payload[0]);
 293 }
 294
 295 HsWord16
 296 rts_getWord16 (HaskellObj p)
 297 {
 298     // See comment above:
 299     // ASSERT(p->header.info == W16zh_con_info ||
 300     //        p->header.info == W16zh_static_info);
 301     return (HsWord16)(HsWord)(UNTAG_CLOSURE(p)->payload[0]);
 302 }
 303
 304 HsWord32
 305 rts_getWord32 (HaskellObj p)
 306 {
 307     // See comment above:
 308     // ASSERT(p->header.info == W32zh_con_info ||
 309     //        p->header.info == W32zh_static_info);
 310     return (HsWord32)(HsWord)(UNTAG_CLOSURE(p)->payload[0]);
 311 }
 312
 313
 314 HsWord64
 315 rts_getWord64 (HaskellObj p)
 316 {
 317     HsWord64* tmp;
 318     // See comment above:
 319     // ASSERT(p->header.info == W64zh_con_info ||
 320     //        p->header.info == W64zh_static_info);
 321     tmp = (HsWord64*)&(UNTAG_CLOSURE(p)->payload[0]);
 322     return *tmp;
 323 }
 324
 325 HsFloat
 326 rts_getFloat (HaskellObj p)
 327 {
 328     // See comment above:
 329     // ASSERT(p->header.info == Fzh_con_info ||
 330     //        p->header.info == Fzh_static_info);
 331     return (float)(PK_FLT((P_)UNTAG_CLOSURE(p)->payload));
 332 }
 333
 334 HsDouble
 335 rts_getDouble (HaskellObj p)
 336 {
 337     // See comment above:
 338     // ASSERT(p->header.info == Dzh_con_info ||
 339     //        p->header.info == Dzh_static_info);
 340     return (double)(PK_DBL((P_)UNTAG_CLOSURE(p)->payload));
 341 }
 342
 343 HsStablePtr
 344 rts_getStablePtr (HaskellObj p)
 345 {
 346     // See comment above:
 347     // ASSERT(p->header.info == StablePtr_con_info ||
 348     //        p->header.info == StablePtr_static_info);
 349     return (StgStablePtr)(UNTAG_CLOSURE(p)->payload[0]);
 350 }
 351
 352 HsPtr
 353 rts_getPtr (HaskellObj p)
 354 {
 355     // See comment above:
 356     // ASSERT(p->header.info == Ptr_con_info ||
 357     //        p->header.info == Ptr_static_info);
 358     return (Capability *)(UNTAG_CLOSURE(p)->payload[0]);
 359 }
 360
 361 HsFunPtr
 362 rts_getFunPtr (HaskellObj p)
 363 {
 364     // See comment above:
 365     // ASSERT(p->header.info == FunPtr_con_info ||
 366     //        p->header.info == FunPtr_static_info);
 367     return (void *)(UNTAG_CLOSURE(p)->payload[0]);
 368 }
 369
 370 HsBool
 371 rts_getBool (HaskellObj p)
 372 {
 373     StgInfoTable *info;
 374
 375     info = get_itbl((StgClosure *)UNTAG_CLOSURE(p));
 376     if (info->srt_bitmap == 0) { // srt_bitmap is the constructor tag
 377         return 0;
 378     } else {
 379         return 1;
 380     }
 381 }
 382
 383 /* -----------------------------------------------------------------------------
 384    Creating threads
 385    -------------------------------------------------------------------------- */
 386
 387 INLINE_HEADER void pushClosure   (StgTSO *tso, StgWord c) {
 388   tso->sp--;
 389   tso->sp[0] = (W_) c;
 390 }
 391
 392 StgTSO *
 393 createGenThread (Capability *cap, nat stack_size,  StgClosure *closure)
 394 {
 395   StgTSO *t;
 396 #if defined(GRAN)
 397   t = createThread (cap, stack_size, NO_PRI);
 398 #else
 399   t = createThread (cap, stack_size);
 400 #endif
 401   pushClosure(t, (W_)closure);
 402   pushClosure(t, (W_)&stg_enter_info);
 403   return t;
 404 }
 405
 406 StgTSO *
 407 createIOThread (Capability *cap, nat stack_size,  StgClosure *closure)
 408 {
 409   StgTSO *t;
 410 #if defined(GRAN)
 411   t = createThread (cap, stack_size, NO_PRI);
 412 #else
 413   t = createThread (cap, stack_size);
 414 #endif
 415   pushClosure(t, (W_)&stg_noforceIO_info);
 416   pushClosure(t, (W_)&stg_ap_v_info);
 417   pushClosure(t, (W_)closure);
 418   pushClosure(t, (W_)&stg_enter_info);
 419   return t;
 420 }
 421
 422 /*
 423  * Same as above, but also evaluate the result of the IO action
 424  * to whnf while we're at it.
 425  */
 426
 427 StgTSO *
 428 createStrictIOThread(Capability *cap, nat stack_size,  StgClosure *closure)
 429 {
 430   StgTSO *t;
 431 #if defined(GRAN)
 432   t = createThread(cap, stack_size, NO_PRI);
 433 #else
 434   t = createThread(cap, stack_size);
 435 #endif
 436   pushClosure(t, (W_)&stg_forceIO_info);
 437   pushClosure(t, (W_)&stg_ap_v_info);
 438   pushClosure(t, (W_)closure);
 439   pushClosure(t, (W_)&stg_enter_info);
 440   return t;
 441 }
 442
 443 /* ----------------------------------------------------------------------------
 444    Evaluating Haskell expressions
 445    ------------------------------------------------------------------------- */
 446
 447 Capability *
 448 rts_eval (Capability *cap, HaskellObj p, /*out*/HaskellObj *ret)
 449 {
 450     StgTSO *tso;
 451
 452     tso = createGenThread(cap, RtsFlags.GcFlags.initialStkSize, p);
 453     return scheduleWaitThread(tso,ret,cap);
 454 }
 455
 456 Capability *
 457 rts_eval_ (Capability *cap, HaskellObj p, unsigned int stack_size,
 458            /*out*/HaskellObj *ret)
 459 {
 460     StgTSO *tso;
 461
 462     tso = createGenThread(cap, stack_size, p);
 463     return scheduleWaitThread(tso,ret,cap);
 464 }
 465
 466 /*
 467  * rts_evalIO() evaluates a value of the form (IO a), forcing the action's
 468  * result to WHNF before returning.
 469  */
 470 Capability *
 471 rts_evalIO (Capability *cap, HaskellObj p, /*out*/HaskellObj *ret)
 472 {
 473     StgTSO* tso;
 474
 475     tso = createStrictIOThread(cap, RtsFlags.GcFlags.initialStkSize, p);
 476     return scheduleWaitThread(tso,ret,cap);
 477 }
 478
 479 /*
 480  * rts_evalStableIO() is suitable for calling from Haskell.  It
 481  * evaluates a value of the form (StablePtr (IO a)), forcing the
 482  * action's result to WHNF before returning.  The result is returned
 483  * in a StablePtr.
 484  */
 485 Capability *
 486 rts_evalStableIO (Capability *cap, HsStablePtr s, /*out*/HsStablePtr *ret)
 487 {
 488     StgTSO* tso;
 489     StgClosure *p, *r;
 490     SchedulerStatus stat;
 491
 492     p = (StgClosure *)deRefStablePtr(s);
 493     tso = createStrictIOThread(cap, RtsFlags.GcFlags.initialStkSize, p);
 494     cap = scheduleWaitThread(tso,&r,cap);
 495     stat = rts_getSchedStatus(cap);
 496
 497     if (stat == Success && ret != NULL) {
 498         ASSERT(r != NULL);
 499         *ret = getStablePtr((StgPtr)r);
 500     }
 501
 502     return cap;
 503 }
 504
 505 /*
 506  * Like rts_evalIO(), but doesn't force the action's result.
 507  */
 508 Capability *
 509 rts_evalLazyIO (Capability *cap, HaskellObj p, /*out*/HaskellObj *ret)
 510 {
 511     StgTSO *tso;
 512
 513     tso = createIOThread(cap, RtsFlags.GcFlags.initialStkSize, p);
 514     return scheduleWaitThread(tso,ret,cap);
 515 }
 516
 517 Capability *
 518 rts_evalLazyIO_ (Capability *cap, HaskellObj p, unsigned int stack_size,
 519                  /*out*/HaskellObj *ret)
 520 {
 521     StgTSO *tso;
 522
 523     tso = createIOThread(cap, stack_size, p);
 524     return scheduleWaitThread(tso,ret,cap);
 525 }
 526
 527 /* Convenience function for decoding the returned status. */
 528
 529 void
 530 rts_checkSchedStatus (char* site, Capability *cap)
 531 {
 532     SchedulerStatus rc = cap->running_task->stat;
 533     switch (rc) {
 534     case Success:
 535         return;
 536     case Killed:
 537         errorBelch("%s: uncaught exception",site);
 538         stg_exit(EXIT_FAILURE);
 539     case Interrupted:
 540         errorBelch("%s: interrupted", site);
 541         stg_exit(EXIT_FAILURE);
 542     default:
 543         errorBelch("%s: Return code (%d) not ok",(site),(rc));
 544         stg_exit(EXIT_FAILURE);
 545     }
 546 }
 547
 548 SchedulerStatus
 549 rts_getSchedStatus (Capability *cap)
 550 {
 551     return cap->running_task->stat;
 552 }
 553
 554 Capability *
 555 rts_lock (void)
 556 {
 557     Capability *cap;
 558     Task *task;
 559
 560     // ToDo: get rid of this lock in the common case.  We could store
 561     // a free Task in thread-local storage, for example.  That would
 562     // leave just one lock on the path into the RTS: cap->lock when
 563     // acquiring the Capability.
 564     ACQUIRE_LOCK(&sched_mutex);
 565     task = newBoundTask();
 566     RELEASE_LOCK(&sched_mutex);
 567
 568     cap = NULL;
 569     waitForReturnCapability(&cap, task);
 570     return (Capability *)cap;
 571 }
 572
 573 // Exiting the RTS: we hold a Capability that is not necessarily the
 574 // same one that was originally returned by rts_lock(), because
 575 // rts_evalIO() etc. may return a new one.  Now that we have
 576 // investigated the return value, we can release the Capability,
 577 // and free the Task (in that order).
 578
 579 void
 580 rts_unlock (Capability *cap)
 581 {
 582     Task *task;
 583
 584     task = cap->running_task;
 585     ASSERT_FULL_CAPABILITY_INVARIANTS(cap,task);
 586
 587     // slightly delicate ordering of operations below, pay attention!
 588
 589     // We are no longer a bound task/thread.  This is important,
 590     // because the GC can run when we release the Capability below,
 591     // and we don't want it to treat this as a live TSO pointer.
 592     task->tso = NULL;
 593
 594     // Now release the Capability.  With the capability released, GC
 595     // may happen.  NB. does not try to put the current Task on the
 596     // worker queue.
 597     releaseCapability(cap);
 598
 599     // Finally, we can release the Task to the free list.
 600     boundTaskExiting(task);
 601 }