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