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