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 "rts/PosixSource.h"
  10 #include "Rts.h"
  11 #include "RtsAPI.h"
  12 #include "RtsFlags.h"
  13 #include "HsFFI.h"
  14
  15 #include "RtsUtils.h"
  16 #include "Prelude.h"
  17 #include "Schedule.h"
  18 #include "Capability.h"
  19 #include "StableName.h"
  20 #include "StablePtr.h"
  21 #include "Threads.h"
  22 #include "Weak.h"
  23 #include "sm/NonMoving.h"
  24
  25 /* ----------------------------------------------------------------------------
  26    Building Haskell objects from C datatypes.
  27    ------------------------------------------------------------------------- */
  28 HaskellObj
  29 rts_mkChar (Capability *cap, HsChar c)
  30 {
  31   StgClosure *p;
  32   // See Note [Precomputed static closures]
  33   if (c <= MAX_CHARLIKE) {
  34     p = (StgClosure *)CHARLIKE_CLOSURE(c);
  35   } else {
  36     p = (StgClosure *)allocate(cap, CONSTR_sizeW(0,1));
  37     SET_HDR(p, Czh_con_info, CCS_SYSTEM);
  38     p->payload[0] = (StgClosure *)(StgWord)(StgChar)c;
  39   }
  40   return TAG_CLOSURE(1, p);
  41 }
  42
  43 HaskellObj
  44 rts_mkInt (Capability *cap, HsInt i)
  45 {
  46   StgClosure *p;
  47   // See Note [Precomputed static closures]
  48   if (i >= MIN_INTLIKE && i <= MAX_INTLIKE) {
  49     p = (StgClosure *)INTLIKE_CLOSURE(i);
  50   } else {
  51     p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,1));
  52     SET_HDR(p, Izh_con_info, CCS_SYSTEM);
  53     *(StgInt *)p->payload = i;
  54   }
  55   return TAG_CLOSURE(1, p);
  56 }
  57
  58 HaskellObj
  59 rts_mkInt8 (Capability *cap, HsInt8 i)
  60 {
  61   StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,1));
  62   SET_HDR(p, I8zh_con_info, CCS_SYSTEM);
  63   *(StgInt8 *)p->payload = i;
  64   return TAG_CLOSURE(1, p);
  65 }
  66
  67 HaskellObj
  68 rts_mkInt16 (Capability *cap, HsInt16 i)
  69 {
  70   StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,1));
  71   SET_HDR(p, I16zh_con_info, CCS_SYSTEM);
  72   *(StgInt16 *)p->payload = i;
  73   return TAG_CLOSURE(1, p);
  74 }
  75
  76 HaskellObj
  77 rts_mkInt32 (Capability *cap, HsInt32 i)
  78 {
  79   StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,1));
  80   SET_HDR(p, I32zh_con_info, CCS_SYSTEM);
  81   *(StgInt32 *)p->payload = i;
  82   return TAG_CLOSURE(1, p);
  83 }
  84
  85 HaskellObj
  86 rts_mkInt64 (Capability *cap, HsInt64 i)
  87 {
  88   StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,sizeofW(StgInt64)));
  89   SET_HDR(p, I64zh_con_info, CCS_SYSTEM);
  90   ASSIGN_Int64((P_)&(p->payload[0]), i);
  91   return TAG_CLOSURE(1, p);
  92 }
  93
  94 HaskellObj
  95 rts_mkWord (Capability *cap, HsWord i)
  96 {
  97   StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,1));
  98   SET_HDR(p, Wzh_con_info, CCS_SYSTEM);
  99   *(StgWord *)p->payload = i;
 100   return TAG_CLOSURE(1, p);
 101 }
 102
 103 HaskellObj
 104 rts_mkWord8 (Capability *cap, HsWord8 w)
 105 {
 106   StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,1));
 107   SET_HDR(p, W8zh_con_info, CCS_SYSTEM);
 108   *(StgWord8 *)p->payload = w;
 109   return TAG_CLOSURE(1, p);
 110 }
 111
 112 HaskellObj
 113 rts_mkWord16 (Capability *cap, HsWord16 w)
 114 {
 115   StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,1));
 116   SET_HDR(p, W16zh_con_info, CCS_SYSTEM);
 117   *(StgWord16 *)p->payload = w;
 118   return TAG_CLOSURE(1, p);
 119 }
 120
 121 HaskellObj
 122 rts_mkWord32 (Capability *cap, HsWord32 w)
 123 {
 124   StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,1));
 125   SET_HDR(p, W32zh_con_info, CCS_SYSTEM);
 126   *(StgWord32 *)p->payload = w;
 127   return TAG_CLOSURE(1, p);
 128 }
 129
 130 HaskellObj
 131 rts_mkWord64 (Capability *cap, HsWord64 w)
 132 {
 133   StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,sizeofW(StgWord64)));
 134   SET_HDR(p, W64zh_con_info, CCS_SYSTEM);
 135   ASSIGN_Word64((P_)&(p->payload[0]), w);
 136   return TAG_CLOSURE(1, p);
 137 }
 138
 139
 140 HaskellObj
 141 rts_mkFloat (Capability *cap, HsFloat f)
 142 {
 143   StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,1));
 144   SET_HDR(p, Fzh_con_info, CCS_SYSTEM);
 145   ASSIGN_FLT((P_)p->payload, (StgFloat)f);
 146   return TAG_CLOSURE(1, p);
 147 }
 148
 149 HaskellObj
 150 rts_mkDouble (Capability *cap, HsDouble d)
 151 {
 152   StgClosure *p = (StgClosure *)allocate(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 TAG_CLOSURE(1, p);
 156 }
 157
 158 HaskellObj
 159 rts_mkStablePtr (Capability *cap, HsStablePtr s)
 160 {
 161   StgClosure *p = (StgClosure *)allocate(cap,sizeofW(StgHeader)+1);
 162   SET_HDR(p, StablePtr_con_info, CCS_SYSTEM);
 163   p->payload[0] = (StgClosure *)s;
 164   return TAG_CLOSURE(1, p);
 165 }
 166
 167 HaskellObj
 168 rts_mkPtr (Capability *cap, HsPtr a)
 169 {
 170   StgClosure *p = (StgClosure *)allocate(cap,sizeofW(StgHeader)+1);
 171   SET_HDR(p, Ptr_con_info, CCS_SYSTEM);
 172   p->payload[0] = (StgClosure *)a;
 173   return TAG_CLOSURE(1, p);
 174 }
 175
 176 HaskellObj
 177 rts_mkFunPtr (Capability *cap, HsFunPtr a)
 178 {
 179   StgClosure *p = (StgClosure *)allocate(cap,sizeofW(StgHeader)+1);
 180   SET_HDR(p, FunPtr_con_info, CCS_SYSTEM);
 181   p->payload[0] = (StgClosure *)a;
 182   return TAG_CLOSURE(1, p);
 183 }
 184
 185 HaskellObj
 186 rts_mkBool (Capability *cap STG_UNUSED, HsBool b)
 187 {
 188   if (b) {
 189     return TAG_CLOSURE(2, (StgClosure *)True_closure);
 190   } else {
 191     return TAG_CLOSURE(1, (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 *)allocate(cap,sizeofW(StgThunk) + 2);
 207     // Here we don't want to use CCS_SYSTEM, because it's a hidden cost centre,
 208     // and evaluating Haskell code under a hidden cost centre leads to
 209     // confusing profiling output. (#7753)
 210     SET_HDR(ap, (StgInfoTable *)&stg_ap_2_upd_info, CCS_MAIN);
 211     ap->payload[0] = f;
 212     ap->payload[1] = arg;
 213     return (StgClosure *)ap;
 214 }
 215
 216 /* ----------------------------------------------------------------------------
 217    Deconstructing Haskell objects
 218
 219    We would like to assert that we have the right kind of object in
 220    each case, but this is problematic because in GHCi the info table
 221    for the D# constructor (say) might be dynamically loaded.  Hence we
 222    omit these assertions for now.
 223    ------------------------------------------------------------------------- */
 224
 225 HsChar
 226 rts_getChar (HaskellObj p)
 227 {
 228     // See comment above:
 229     // ASSERT(p->header.info == Czh_con_info ||
 230     //        p->header.info == Czh_static_info);
 231     return (StgChar)(StgWord)(UNTAG_CLOSURE(p)->payload[0]);
 232 }
 233
 234 HsInt
 235 rts_getInt (HaskellObj p)
 236 {
 237     // See comment above:
 238     // ASSERT(p->header.info == Izh_con_info ||
 239     //        p->header.info == Izh_static_info);
 240     return *(HsInt *)(UNTAG_CLOSURE(p)->payload);
 241 }
 242
 243 HsInt8
 244 rts_getInt8 (HaskellObj p)
 245 {
 246     // See comment above:
 247     // ASSERT(p->header.info == I8zh_con_info ||
 248     //        p->header.info == I8zh_static_info);
 249     return *(HsInt8 *)(UNTAG_CLOSURE(p)->payload);
 250 }
 251
 252 HsInt16
 253 rts_getInt16 (HaskellObj p)
 254 {
 255     // See comment above:
 256     // ASSERT(p->header.info == I16zh_con_info ||
 257     //        p->header.info == I16zh_static_info);
 258     return *(HsInt16 *)(UNTAG_CLOSURE(p)->payload);
 259 }
 260
 261 HsInt32
 262 rts_getInt32 (HaskellObj p)
 263 {
 264     // See comment above:
 265     // ASSERT(p->header.info == I32zh_con_info ||
 266     //        p->header.info == I32zh_static_info);
 267     return *(HsInt32 *)(UNTAG_CLOSURE(p)->payload);
 268 }
 269
 270 HsInt64
 271 rts_getInt64 (HaskellObj p)
 272 {
 273     // See comment above:
 274     // ASSERT(p->header.info == I64zh_con_info ||
 275     //        p->header.info == I64zh_static_info);
 276     return PK_Int64((P_)&(UNTAG_CLOSURE(p)->payload[0]));
 277 }
 278
 279 HsWord
 280 rts_getWord (HaskellObj p)
 281 {
 282     // See comment above:
 283     // ASSERT(p->header.info == Wzh_con_info ||
 284     //        p->header.info == Wzh_static_info);
 285     return *(HsWord *)(UNTAG_CLOSURE(p)->payload);
 286 }
 287
 288 HsWord8
 289 rts_getWord8 (HaskellObj p)
 290 {
 291     // See comment above:
 292     // ASSERT(p->header.info == W8zh_con_info ||
 293     //        p->header.info == W8zh_static_info);
 294     return *(HsWord8 *)(UNTAG_CLOSURE(p)->payload);
 295 }
 296
 297 HsWord16
 298 rts_getWord16 (HaskellObj p)
 299 {
 300     // See comment above:
 301     // ASSERT(p->header.info == W16zh_con_info ||
 302     //        p->header.info == W16zh_static_info);
 303     return *(HsWord16 *)(UNTAG_CLOSURE(p)->payload);
 304 }
 305
 306 HsWord32
 307 rts_getWord32 (HaskellObj p)
 308 {
 309     // See comment above:
 310     // ASSERT(p->header.info == W32zh_con_info ||
 311     //        p->header.info == W32zh_static_info);
 312     return *(HsWord32 *)(UNTAG_CLOSURE(p)->payload);
 313 }
 314
 315 HsWord64
 316 rts_getWord64 (HaskellObj p)
 317 {
 318     // See comment above:
 319     // ASSERT(p->header.info == W64zh_con_info ||
 320     //        p->header.info == W64zh_static_info);
 321     return PK_Word64((P_)&(UNTAG_CLOSURE(p)->payload[0]));
 322 }
 323
 324 HsFloat
 325 rts_getFloat (HaskellObj p)
 326 {
 327     // See comment above:
 328     // ASSERT(p->header.info == Fzh_con_info ||
 329     //        p->header.info == Fzh_static_info);
 330     return (float)(PK_FLT((P_)UNTAG_CLOSURE(p)->payload));
 331 }
 332
 333 HsDouble
 334 rts_getDouble (HaskellObj p)
 335 {
 336     // See comment above:
 337     // ASSERT(p->header.info == Dzh_con_info ||
 338     //        p->header.info == Dzh_static_info);
 339     return (double)(PK_DBL((P_)UNTAG_CLOSURE(p)->payload));
 340 }
 341
 342 HsStablePtr
 343 rts_getStablePtr (HaskellObj p)
 344 {
 345     // See comment above:
 346     // ASSERT(p->header.info == StablePtr_con_info ||
 347     //        p->header.info == StablePtr_static_info);
 348     return (StgStablePtr)(UNTAG_CLOSURE(p)->payload[0]);
 349 }
 350
 351 HsPtr
 352 rts_getPtr (HaskellObj p)
 353 {
 354     // See comment above:
 355     // ASSERT(p->header.info == Ptr_con_info ||
 356     //        p->header.info == Ptr_static_info);
 357     return (Capability *)(UNTAG_CLOSURE(p)->payload[0]);
 358 }
 359
 360 HsFunPtr
 361 rts_getFunPtr (HaskellObj p)
 362 {
 363     // See comment above:
 364     // ASSERT(p->header.info == FunPtr_con_info ||
 365     //        p->header.info == FunPtr_static_info);
 366     return (void *)(UNTAG_CLOSURE(p)->payload[0]);
 367 }
 368
 369 HsBool
 370 rts_getBool (HaskellObj p)
 371 {
 372     const StgWord tag = GET_CLOSURE_TAG(p);
 373     if (tag > 0) {
 374         return tag - 1;
 375     }
 376
 377     const StgInfoTable *info;
 378
 379     info = get_itbl((const StgClosure *)UNTAG_CONST_CLOSURE(p));
 380     if (info->srt == 0) { // srt is the constructor tag
 381         return 0;
 382     } else {
 383         return 1;
 384     }
 385 }
 386
 387 /* -----------------------------------------------------------------------------
 388    Creating threads
 389    -------------------------------------------------------------------------- */
 390
 391 INLINE_HEADER void pushClosure   (StgTSO *tso, StgWord c) {
 392   tso->stackobj->sp--;
 393   tso->stackobj->sp[0] = (W_) c;
 394 }
 395
 396 StgTSO *
 397 createGenThread (Capability *cap, W_ stack_size,  StgClosure *closure)
 398 {
 399   StgTSO *t;
 400   t = createThread (cap, stack_size);
 401   pushClosure(t, (W_)closure);
 402   pushClosure(t, (W_)&stg_enter_info);
 403   return t;
 404 }
 405
 406 StgTSO *
 407 createIOThread (Capability *cap, W_ stack_size,  StgClosure *closure)
 408 {
 409   StgTSO *t;
 410   t = createThread (cap, stack_size);
 411   pushClosure(t, (W_)&stg_ap_v_info);
 412   pushClosure(t, (W_)closure);
 413   pushClosure(t, (W_)&stg_enter_info);
 414   return t;
 415 }
 416
 417 /*
 418  * Same as above, but also evaluate the result of the IO action
 419  * to whnf while we're at it.
 420  */
 421
 422 StgTSO *
 423 createStrictIOThread(Capability *cap, W_ stack_size,  StgClosure *closure)
 424 {
 425   StgTSO *t;
 426   t = createThread(cap, stack_size);
 427   pushClosure(t, (W_)&stg_forceIO_info);
 428   pushClosure(t, (W_)&stg_ap_v_info);
 429   pushClosure(t, (W_)closure);
 430   pushClosure(t, (W_)&stg_enter_info);
 431   return t;
 432 }
 433
 434 /* ----------------------------------------------------------------------------
 435    Evaluating Haskell expressions
 436
 437    The running task (capability->running_task) must be bounded i.e. you must
 438    call newBoundTask() before calling these functions. Note that rts_lock() and
 439    rts_pause() both call newBoundTask().
 440    ------------------------------------------------------------------------- */
 441
 442 void rts_eval (/* inout */ Capability **cap,
 443                /* in    */ HaskellObj p,
 444                /* out */   HaskellObj *ret)
 445 {
 446     StgTSO *tso;
 447
 448     tso = createGenThread(*cap, RtsFlags.GcFlags.initialStkSize, p);
 449     scheduleWaitThread(tso,ret,cap);
 450 }
 451
 452 void rts_eval_ (/* inout */ Capability **cap,
 453                 /* in    */ HaskellObj p,
 454                 /* in    */ unsigned int stack_size,
 455                 /* out   */ HaskellObj *ret)
 456 {
 457     StgTSO *tso;
 458
 459     tso = createGenThread(*cap, stack_size, p);
 460     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 void rts_evalIO (/* inout */ Capability **cap,
 468                  /* in    */ HaskellObj p,
 469                  /* out */   HaskellObj *ret)
 470 {
 471     StgTSO* tso;
 472
 473     tso = createStrictIOThread(*cap, RtsFlags.GcFlags.initialStkSize, p);
 474     scheduleWaitThread(tso,ret,cap);
 475 }
 476
 477 /*
 478  * rts_inCall() is similar to rts_evalIO, but expects to be called as an incall,
 479  * and is not expected to be called by user code directly.
 480  */
 481 void rts_inCall (/* inout */ Capability **cap,
 482                  /* in    */ HaskellObj p,
 483                  /* out */   HaskellObj *ret)
 484 {
 485     StgTSO* tso;
 486
 487     tso = createStrictIOThread(*cap, RtsFlags.GcFlags.initialStkSize, p);
 488     if ((*cap)->running_task->preferred_capability != -1) {
 489         // enabled_capabilities should not change between here and waitCapability()
 490         ASSERT((*cap)->no == ((*cap)->running_task->preferred_capability % enabled_capabilities));
 491         // we requested explicit affinity; don't move this thread from now on.
 492         tso->flags |= TSO_LOCKED;
 493     }
 494     scheduleWaitThread(tso,ret,cap);
 495 }
 496
 497 /*
 498  * rts_evalStableIOMain() is suitable for calling main Haskell thread
 499  * stored in (StablePtr (IO a)) it calls rts_evalStableIO but wraps
 500  * function in GHC.TopHandler.runMainIO that installs top_handlers.
 501  * See #12903.
 502  */
 503 void rts_evalStableIOMain(/* inout */ Capability **cap,
 504                           /* in    */ HsStablePtr s,
 505                           /* out   */ HsStablePtr *ret)
 506 {
 507     StgTSO* tso;
 508     StgClosure *p, *r, *w;
 509     SchedulerStatus stat;
 510
 511     p = (StgClosure *)deRefStablePtr(s);
 512     w = rts_apply(*cap, &ghczminternal_GHCziInternalziTopHandler_runMainIO_closure, p);
 513     tso = createStrictIOThread(*cap, RtsFlags.GcFlags.initialStkSize, w);
 514     // async exceptions are always blocked by default in the created
 515     // thread.  See #1048.
 516     tso->flags |= TSO_BLOCKEX | TSO_INTERRUPTIBLE;
 517     scheduleWaitThread(tso,&r,cap);
 518     stat = rts_getSchedStatus(*cap);
 519
 520     if (stat == Success && ret != NULL) {
 521         ASSERT(r != NULL);
 522         *ret = getStablePtr((StgPtr)r);
 523     }
 524 }
 525
 526 /*
 527  * rts_evalStableIO() is suitable for calling from Haskell.  It
 528  * evaluates a value of the form (StablePtr (IO a)), forcing the
 529  * action's result to WHNF before returning.  The result is returned
 530  * in a StablePtr.
 531  */
 532 void rts_evalStableIO (/* inout */ Capability **cap,
 533                        /* in    */ HsStablePtr s,
 534                        /* out */   HsStablePtr *ret)
 535 {
 536     StgTSO* tso;
 537     StgClosure *p, *r;
 538     SchedulerStatus stat;
 539
 540     p = (StgClosure *)deRefStablePtr(s);
 541     tso = createStrictIOThread(*cap, RtsFlags.GcFlags.initialStkSize, p);
 542     // async exceptions are always blocked by default in the created
 543     // thread.  See #1048.
 544     tso->flags |= TSO_BLOCKEX | TSO_INTERRUPTIBLE;
 545     scheduleWaitThread(tso,&r,cap);
 546     stat = rts_getSchedStatus(*cap);
 547
 548     if (stat == Success && ret != NULL) {
 549         ASSERT(r != NULL);
 550         *ret = getStablePtr((StgPtr)r);
 551     }
 552 }
 553
 554 /*
 555  * Like rts_evalIO(), but doesn't force the action's result.
 556  */
 557 void rts_evalLazyIO (/* inout */ Capability **cap,
 558                      /* in    */ HaskellObj p,
 559                      /* out */   HaskellObj *ret)
 560 {
 561     StgTSO *tso;
 562
 563     tso = createIOThread(*cap, RtsFlags.GcFlags.initialStkSize, p);
 564     scheduleWaitThread(tso,ret,cap);
 565 }
 566
 567 void rts_evalLazyIO_ (/* inout */ Capability **cap,
 568                       /* in    */ HaskellObj p,
 569                       /* in    */ unsigned int stack_size,
 570                       /* out   */ HaskellObj *ret)
 571 {
 572     StgTSO *tso;
 573
 574     tso = createIOThread(*cap, stack_size, p);
 575     scheduleWaitThread(tso,ret,cap);
 576 }
 577
 578 /* Convenience function for decoding the returned status. */
 579
 580 void
 581 rts_checkSchedStatus (char* site, Capability *cap)
 582 {
 583     SchedulerStatus rc = cap->running_task->incall->rstat;
 584     switch (rc) {
 585     case Success:
 586         return;
 587     case Killed:
 588         errorBelch("%s: uncaught exception",site);
 589         stg_exit(EXIT_FAILURE);
 590     case Interrupted:
 591         errorBelch("%s: interrupted", site);
 592 #if defined(THREADED_RTS)
 593         // The RTS is shutting down, and the process will probably
 594         // soon exit.  We don't want to preempt the shutdown
 595         // by exiting the whole process here, so we just terminate the
 596         // current thread.  Don't forget to release the cap first though.
 597         rts_unlock(cap);
 598         shutdownThread();
 599 #else
 600         stg_exit(EXIT_FAILURE);
 601 #endif
 602     default:
 603         errorBelch("%s: Return code (%d) not ok",(site),(rc));
 604         stg_exit(EXIT_FAILURE);
 605     }
 606 }
 607
 608 SchedulerStatus
 609 rts_getSchedStatus (Capability *cap)
 610 {
 611     return cap->running_task->incall->rstat;
 612 }
 613
 614 #if defined(THREADED_RTS)
 615 // The task that paused the RTS. The rts_pausing_task variable is owned by the
 616 // task that owns all capabilities (there is at most one such task).
 617 //
 618 // It's possible to remove this and instead define the pausing task as whichever
 619 // task owns all capabilities, but using `rts_pausing_task` leads to marginally
 620 // cleaner code/API and better error messages.
 621 Task * rts_pausing_task = NULL;
 622 #endif
 623
 624 Capability *
 625 rts_lock (void)
 626 {
 627     Capability *cap;
 628     Task *task;
 629
 630     // Bound the current task. This is necessary to support rts_eval* functions.
 631     task = newBoundTask();
 632
 633     if (task->running_finalizers) {
 634         errorBelch("error: a C finalizer called back into Haskell.\n"
 635                    "   This was previously allowed, but is disallowed in GHC 6.10.2 and later.\n"
 636                    "   To create finalizers that may call back into Haskell, use\n"
 637                    "   Foreign.Concurrent.newForeignPtr instead of Foreign.newForeignPtr.");
 638         stg_exit(EXIT_FAILURE);
 639     }
 640
 641 #if defined(THREADED_RTS)
 642     if (rts_pausing_task == task) {
 643         errorBelch("error: rts_lock: The RTS is already paused by this thread.\n"
 644                    "   There is no need to call rts_lock if you have already called rts_pause.");
 645         stg_exit(EXIT_FAILURE);
 646     }
 647 #endif
 648
 649     cap = NULL;
 650     waitForCapability(&cap, task);
 651
 652     if (task->incall->prev_stack == NULL) {
 653       // This is a new outermost call from C into Haskell land.
 654       // Until the corresponding call to rts_unlock, this task
 655       // is doing work on behalf of the RTS.
 656       traceTaskCreate(task, cap);
 657     }
 658
 659     return (Capability *)cap;
 660 }
 661
 662 // Exiting the RTS: we hold a Capability that is not necessarily the
 663 // same one that was originally returned by rts_lock(), because
 664 // rts_evalIO() etc. may return a new one.  Now that we have
 665 // investigated the return value, we can release the Capability,
 666 // and free the Task (in that order).
 667
 668 void
 669 rts_unlock (Capability *cap)
 670 {
 671     Task *task;
 672
 673     task = cap->running_task;
 674     ASSERT_FULL_CAPABILITY_INVARIANTS(cap,task);
 675
 676     // Now release the Capability. With the capability released, GC
 677     // may happen. NB. does not try to put the current Task on the
 678     // worker queue.
 679     // NB. keep cap->lock held while we call exitMyTask(). This
 680     // is necessary during shutdown, where we want the invariant that
 681     // after shutdownCapability(), all the Tasks associated with the
 682     // Capability have completed their shutdown too. Otherwise we
 683     // could have exitMyTask()/workerTaskStop() running at some
 684     // random point in the future, which causes problems for
 685     // freeTaskManager().
 686     ACQUIRE_LOCK(&cap->lock);
 687     releaseCapability_(cap,false);
 688
 689     // Finally, we can release the Task to the free list.
 690     exitMyTask();
 691     RELEASE_LOCK(&cap->lock);
 692
 693     if (task->incall == NULL) {
 694       // This is the end of an outermost call from C into Haskell land.
 695       // From here on, the task goes back to C land and we should not count
 696       // it as doing work on behalf of the RTS.
 697       traceTaskDelete(task);
 698     }
 699 }
 700
 701 struct PauseToken_ {
 702     Capability *capability;
 703 };
 704
 705 Capability *pauseTokenCapability(PauseToken *pauseToken) {
 706     return pauseToken->capability;
 707 }
 708
 709 #if defined(THREADED_RTS)
 710
 711 // See Note [Locking and Pausing the RTS]
 712 PauseToken *rts_pause (void)
 713 {
 714
 715     // Wait for any nonmoving collection to finish before pausing the RTS.
 716     // The nonmoving collector needs to synchronise with the mutator,
 717     // so pausing the mutator while a collection is ongoing might lead to deadlock or
 718     // capabilities being prematurely re-awoken.
 719     if (RtsFlags.GcFlags.useNonmoving) {
 720         nonmovingBlockConcurrentMark(true);
 721     }
 722
 723
 724     // It is an error if this thread already paused the RTS. If another
 725     // thread has paused the RTS, then rts_pause will block until rts_resume is
 726     // called (and compete with other threads calling rts_pause). The blocking
 727     // behavior is implied by the use of `stopAllCapabilities`.
 728     Task * task = getMyTask();
 729     if (rts_pausing_task == task)
 730     {
 731         // This task already passed the RTS.
 732         errorBelch("error: rts_pause: This thread has already paused the RTS.");
 733         stg_exit(EXIT_FAILURE);
 734     }
 735
 736     // The current task must not own a capability. This is true for non-worker
 737     // threads e.g. when making a safe FFI call. We allow pausing when
 738     // `task->cap->running_task != task` because the capability can be taken by
 739     // other capabilities. Doing this check is justified because rts_pause is a
 740     // user facing function and we want good error reporting. We also don't
 741     // expect rts_pause to be performance critical.
 742     //
 743     // N.B. we use a relaxed load since there is no easy way to synchronize
 744     // here and this check is ultimately just a convenience for the user..
 745     if (task->cap && RELAXED_LOAD(&task->cap->running_task) == task)
 746     {
 747         // This task owns a capability (and it can't be taken by other capabilities).
 748         errorBelch(task->cap->in_haskell
 749             ? ("error: rts_pause: attempting to pause via an unsafe FFI call.\n"
 750                "   Perhaps a 'foreign import unsafe' should be 'safe'?")
 751             : ("error: rts_pause: attempting to pause from a Task that owns a capability.\n"
 752                "   Have you already acquired a capability e.g. with rts_lock?"));
 753         stg_exit(EXIT_FAILURE);
 754     }
 755
 756     // Bound the current task. This is necessary to support rts_eval* functions.
 757     task = newBoundTask();
 758     stopAllCapabilities(NULL, task);
 759
 760     // Now we own all capabilities so we own rts_pausing_task and may set it.
 761     rts_pausing_task = task;
 762
 763     PauseToken *token = stgMallocBytes(sizeof(PauseToken), "rts_pause");
 764     token->capability = task->cap;
 765     return token;
 766 }
 767
 768 static void assert_isPausedOnMyTask(const char *functionName);
 769
 770 // See Note [Locking and Pausing the RTS]. The pauseToken argument is here just
 771 // for symmetry with rts_pause and to match the pattern of rts_lock/rts_unlock.
 772 void rts_resume (PauseToken *pauseToken)
 773 {
 774     assert_isPausedOnMyTask("rts_resume");
 775     Task * task = getMyTask();
 776
 777     // Now we own all capabilities so we own rts_pausing_task and may write to
 778     // it.
 779     rts_pausing_task = NULL;
 780
 781     // releaseAllCapabilities will not block because the current task owns all
 782     // capabilities.
 783     releaseAllCapabilities(getNumCapabilities(), NULL, task);
 784     exitMyTask();
 785     stgFree(pauseToken);
 786
 787     if (RtsFlags.GcFlags.useNonmoving) {
 788         nonmovingUnblockConcurrentMark();
 789     }
 790 }
 791
 792 // See RtsAPI.h
 793 bool rts_isPaused(void)
 794 {
 795     return rts_pausing_task != NULL;
 796 }
 797
 798 // Check that the rts_pause was called on this thread/task and this thread owns
 799 // all capabilities. If not, outputs an error and exits with EXIT_FAILURE.
 800 static void assert_isPausedOnMyTask(const char *functionName)
 801 {
 802     Task * task = getMyTask();
 803     if (rts_pausing_task == NULL)
 804     {
 805         errorBelch (
 806             "error: %s: the rts is not paused. Did you forget to call rts_pause?",
 807             functionName);
 808         stg_exit(EXIT_FAILURE);
 809     }
 810
 811     if (task != rts_pausing_task)
 812     {
 813         // We don't have ownership of rts_pausing_task, so it may have changed
 814         // just after the above read. Still, we are guaranteed that
 815         // rts_pausing_task won't be set to the current task (because the
 816         // current task is here now!), so the error messages are still correct.
 817         errorBelch (
 818             "error: %s: called from a different OS thread than rts_pause.",
 819             functionName);
 820
 821         stg_exit(EXIT_FAILURE);
 822     }
 823
 824     // Check that we own all capabilities.
 825     for (unsigned int i = 0; i < getNumCapabilities(); i++)
 826     {
 827         Capability *cap = getCapability(i);
 828         if (cap->running_task != task)
 829         {
 830             errorBelch (
 831                 "error: %s: the pausing thread does not own all capabilities.\n"
 832                 "   Have you manually released a capability after calling rts_pause?",
 833                 functionName);
 834             stg_exit(EXIT_FAILURE);
 835         }
 836     }
 837 }
 838
 839 // See RtsAPI.h
 840 void rts_listThreads(ListThreadsCb cb, void *user)
 841 {
 842     assert_isPausedOnMyTask("rts_listThreads");
 843
 844     // The rts is paused and can only be resumed by the current thread. Hence it
 845     // is safe to read global thread data.
 846
 847     for (uint32_t g=0; g < RtsFlags.GcFlags.generations; g++) {
 848         StgTSO *tso = generations[g].threads;
 849         while (tso != END_TSO_QUEUE) {
 850             cb(user, tso);
 851             tso = tso->global_link;
 852         }
 853     }
 854 }
 855
 856 struct list_roots_ctx {
 857     ListRootsCb cb;
 858     void *user;
 859 };
 860
 861 // This is an evac_fn.
 862 static void list_roots_helper(void *user, StgClosure **p) {
 863     struct list_roots_ctx *ctx = (struct list_roots_ctx *) user;
 864     ctx->cb(ctx->user, *p);
 865 }
 866
 867 // See RtsAPI.h
 868 void rts_listMiscRoots (ListRootsCb cb, void *user)
 869 {
 870     assert_isPausedOnMyTask("rts_listMiscRoots");
 871
 872     struct list_roots_ctx ctx;
 873     ctx.cb = cb;
 874     ctx.user = user;
 875
 876     threadStableNameTable(&list_roots_helper, (void *)&ctx);
 877     threadStablePtrTable(&list_roots_helper, (void *)&ctx);
 878 }
 879
 880 #else
 881 PauseToken STG_NORETURN
 882 *rts_pause (void)
 883 {
 884     errorBelch("Warning: Pausing the RTS is only possible for "
 885                "multithreaded RTS.");
 886     stg_exit(EXIT_FAILURE);
 887 }
 888
 889 void STG_NORETURN
 890 rts_resume (PauseToken *pauseToken STG_UNUSED)
 891 {
 892     errorBelch("Warning: Resuming the RTS is only possible for "
 893                "multithreaded RTS.");
 894     stg_exit(EXIT_FAILURE);
 895 }
 896
 897 bool rts_isPaused(void)
 898 {
 899     errorBelch("Warning: Pausing/Resuming the RTS is only possible for "
 900                "multithreaded RTS.");
 901     return false;
 902 }
 903
 904 // See RtsAPI.h
 905 void rts_listThreads(ListThreadsCb cb STG_UNUSED, void *user STG_UNUSED)
 906 {
 907     errorBelch("Warning: rts_listThreads is only possible for multithreaded RTS.");
 908 }
 909
 910 // See RtsAPI.h
 911 void rts_listMiscRoots (ListRootsCb cb STG_UNUSED, void *user STG_UNUSED)
 912 {
 913     errorBelch("Warning: rts_listMiscRoots is only possible for multithreaded RTS.");
 914 }
 915 #endif
 916
 917 void rts_done (void)
 918 {
 919     freeMyTask();
 920 }
 921
 922 /* -----------------------------------------------------------------------------
 923    tryPutMVar from outside Haskell
 924
 925    The C call
 926
 927       hs_try_putmvar(cap, mvar)
 928
 929    is equivalent to the Haskell call
 930
 931       tryPutMVar mvar ()
 932
 933    but it is
 934
 935      * non-blocking: takes a bounded, short, amount of time
 936      * asynchronous: the actual putMVar may be performed after the
 937        call returns.  That's why hs_try_putmvar() doesn't return a
 938        result to say whether the put succeeded.
 939
 940    NOTE: this call transfers ownership of the StablePtr to the RTS, which will
 941    free it after the tryPutMVar has taken place.  The reason is that otherwise,
 942    it would be very difficult for the caller to arrange to free the StablePtr
 943    in all circumstances.
 944
 945    For more details, see the section "Waking up Haskell threads from C" in the
 946    User's Guide.
 947    -------------------------------------------------------------------------- */
 948
 949 void hs_try_putmvar (/* in */ int capability,
 950                      /* in */ HsStablePtr mvar)
 951 {
 952     Task *task = getMyTask();
 953     Capability *cap;
 954     Capability *task_old_cap USED_IF_THREADS;
 955
 956     if (capability < 0) {
 957         capability = task->preferred_capability;
 958         if (capability < 0) {
 959             capability = 0;
 960         }
 961     }
 962     cap = getCapability(capability % enabled_capabilities);
 963
 964 #if !defined(THREADED_RTS)
 965
 966     performTryPutMVar(cap, (StgMVar*)deRefStablePtr(mvar), Unit_closure);
 967     freeStablePtr(mvar);
 968
 969 #else
 970
 971     ACQUIRE_LOCK(&cap->lock);
 972     // If the capability is free, we can perform the tryPutMVar immediately
 973     if (cap->running_task == NULL) {
 974         cap->running_task = task;
 975         task_old_cap = task->cap;
 976         task->cap = cap;
 977         RELEASE_LOCK(&cap->lock);
 978
 979         performTryPutMVar(cap, (StgMVar*)deRefStablePtr(mvar), Unit_closure);
 980
 981         freeStablePtr(mvar);
 982
 983         // Wake up the capability, which will start running the thread that we
 984         // just awoke (if there was one).
 985         releaseCapability(cap);
 986         task->cap = task_old_cap;
 987     } else {
 988         PutMVar *p = stgMallocBytes(sizeof(PutMVar),"hs_try_putmvar");
 989         // We cannot deref the StablePtr if we don't have a capability,
 990         // so we have to store it and deref it later.
 991         p->mvar = mvar;
 992         p->link = cap->putMVars;
 993         cap->putMVars = p;
 994         RELEASE_LOCK(&cap->lock);
 995     }
 996
 997 #endif
 998 }