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 *)allocate(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 *)allocate(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 *)allocate(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 *)allocate(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 *)allocate(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 *)allocate(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 *)allocate(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 *)allocate(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 *)allocate(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 *)allocate(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 *)allocate(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 *)allocate(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 *)allocate(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 *)allocate(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 *)allocate(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 *)allocate(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 *)allocate(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->stackobj->sp--;
 379   tso->stackobj->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_ap_v_info);
 398   pushClosure(t, (W_)closure);
 399   pushClosure(t, (W_)&stg_enter_info);
 400   return t;
 401 }
 402
 403 /*
 404  * Same as above, but also evaluate the result of the IO action
 405  * to whnf while we're at it.
 406  */
 407
 408 StgTSO *
 409 createStrictIOThread(Capability *cap, nat stack_size,  StgClosure *closure)
 410 {
 411   StgTSO *t;
 412   t = createThread(cap, stack_size);
 413   pushClosure(t, (W_)&stg_forceIO_info);
 414   pushClosure(t, (W_)&stg_ap_v_info);
 415   pushClosure(t, (W_)closure);
 416   pushClosure(t, (W_)&stg_enter_info);
 417   return t;
 418 }
 419
 420 /* ----------------------------------------------------------------------------
 421    Evaluating Haskell expressions
 422    ------------------------------------------------------------------------- */
 423
 424 Capability *
 425 rts_eval (Capability *cap, HaskellObj p, /*out*/HaskellObj *ret)
 426 {
 427     StgTSO *tso;
 428
 429     tso = createGenThread(cap, RtsFlags.GcFlags.initialStkSize, p);
 430     return scheduleWaitThread(tso,ret,cap);
 431 }
 432
 433 Capability *
 434 rts_eval_ (Capability *cap, HaskellObj p, unsigned int stack_size,
 435            /*out*/HaskellObj *ret)
 436 {
 437     StgTSO *tso;
 438
 439     tso = createGenThread(cap, stack_size, p);
 440     return scheduleWaitThread(tso,ret,cap);
 441 }
 442
 443 /*
 444  * rts_evalIO() evaluates a value of the form (IO a), forcing the action's
 445  * result to WHNF before returning.
 446  */
 447 Capability *
 448 rts_evalIO (Capability *cap, HaskellObj p, /*out*/HaskellObj *ret)
 449 {
 450     StgTSO* tso;
 451
 452     tso = createStrictIOThread(cap, RtsFlags.GcFlags.initialStkSize, p);
 453     return scheduleWaitThread(tso,ret,cap);
 454 }
 455
 456 /*
 457  * rts_evalStableIO() is suitable for calling from Haskell.  It
 458  * evaluates a value of the form (StablePtr (IO a)), forcing the
 459  * action's result to WHNF before returning.  The result is returned
 460  * in a StablePtr.
 461  */
 462 Capability *
 463 rts_evalStableIO (Capability *cap, HsStablePtr s, /*out*/HsStablePtr *ret)
 464 {
 465     StgTSO* tso;
 466     StgClosure *p, *r;
 467     SchedulerStatus stat;
 468
 469     p = (StgClosure *)deRefStablePtr(s);
 470     tso = createStrictIOThread(cap, RtsFlags.GcFlags.initialStkSize, p);
 471     // async exceptions are always blocked by default in the created
 472     // thread.  See #1048.
 473     tso->flags |= TSO_BLOCKEX | TSO_INTERRUPTIBLE;
 474     cap = scheduleWaitThread(tso,&r,cap);
 475     stat = rts_getSchedStatus(cap);
 476
 477     if (stat == Success && ret != NULL) {
 478         ASSERT(r != NULL);
 479         *ret = getStablePtr((StgPtr)r);
 480     }
 481
 482     return cap;
 483 }
 484
 485 /*
 486  * Like rts_evalIO(), but doesn't force the action's result.
 487  */
 488 Capability *
 489 rts_evalLazyIO (Capability *cap, HaskellObj p, /*out*/HaskellObj *ret)
 490 {
 491     StgTSO *tso;
 492
 493     tso = createIOThread(cap, RtsFlags.GcFlags.initialStkSize, p);
 494     return scheduleWaitThread(tso,ret,cap);
 495 }
 496
 497 Capability *
 498 rts_evalLazyIO_ (Capability *cap, HaskellObj p, unsigned int stack_size,
 499                  /*out*/HaskellObj *ret)
 500 {
 501     StgTSO *tso;
 502
 503     tso = createIOThread(cap, stack_size, p);
 504     return scheduleWaitThread(tso,ret,cap);
 505 }
 506
 507 /* Convenience function for decoding the returned status. */
 508
 509 void
 510 rts_checkSchedStatus (char* site, Capability *cap)
 511 {
 512     SchedulerStatus rc = cap->running_task->incall->stat;
 513     switch (rc) {
 514     case Success:
 515         return;
 516     case Killed:
 517         errorBelch("%s: uncaught exception",site);
 518         stg_exit(EXIT_FAILURE);
 519     case Interrupted:
 520         errorBelch("%s: interrupted", site);
 521         stg_exit(EXIT_FAILURE);
 522     default:
 523         errorBelch("%s: Return code (%d) not ok",(site),(rc));
 524         stg_exit(EXIT_FAILURE);
 525     }
 526 }
 527
 528 SchedulerStatus
 529 rts_getSchedStatus (Capability *cap)
 530 {
 531     return cap->running_task->incall->stat;
 532 }
 533
 534 Capability *
 535 rts_lock (void)
 536 {
 537     Capability *cap;
 538     Task *task;
 539
 540     task = newBoundTask();
 541
 542     if (task->running_finalizers) {
 543         errorBelch("error: a C finalizer called back into Haskell.\n"
 544                    "   This was previously allowed, but is disallowed in GHC 6.10.2 and later.\n"
 545                    "   To create finalizers that may call back into Haskell, use\n"
 546                    "   Foreign.Concurrent.newForeignPtr instead of Foreign.newForeignPtr.");
 547         stg_exit(EXIT_FAILURE);
 548     }
 549
 550     cap = NULL;
 551     waitForReturnCapability(&cap, task);
 552     return (Capability *)cap;
 553 }
 554
 555 // Exiting the RTS: we hold a Capability that is not necessarily the
 556 // same one that was originally returned by rts_lock(), because
 557 // rts_evalIO() etc. may return a new one.  Now that we have
 558 // investigated the return value, we can release the Capability,
 559 // and free the Task (in that order).
 560
 561 void
 562 rts_unlock (Capability *cap)
 563 {
 564     Task *task;
 565
 566     task = cap->running_task;
 567     ASSERT_FULL_CAPABILITY_INVARIANTS(cap,task);
 568
 569     // Now release the Capability.  With the capability released, GC
 570     // may happen.  NB. does not try to put the current Task on the
 571     // worker queue.
 572     // NB. keep cap->lock held while we call boundTaskExiting().  This
 573     // is necessary during shutdown, where we want the invariant that
 574     // after shutdownCapability(), all the Tasks associated with the
 575     // Capability have completed their shutdown too.  Otherwise we
 576     // could have boundTaskExiting()/workerTaskStop() running at some
 577     // random point in the future, which causes problems for
 578     // freeTaskManager().
 579     ACQUIRE_LOCK(&cap->lock);
 580     releaseCapability_(cap,rtsFalse);
 581
 582     // Finally, we can release the Task to the free list.
 583     boundTaskExiting(task);
 584     RELEASE_LOCK(&cap->lock);
 585 }