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
  20 /* ----------------------------------------------------------------------------
  21    Building Haskell objects from C datatypes.
  22
  23    TODO: Currently this code does not tag created pointers,
  24          however it is not unsafe (the contructor code will do it)
  25          just inefficient.
  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)i;
  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)i;
  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)i;
  71   return p;
  72 }
  73
  74 HaskellObj
  75 rts_mkInt64 (Capability *cap, HsInt64 i)
  76 {
  77   StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,2));
  78   SET_HDR(p, I64zh_con_info, CCS_SYSTEM);
  79   ASSIGN_Int64((P_)&(p->payload[0]), i);
  80   return p;
  81 }
  82
  83 HaskellObj
  84 rts_mkWord (Capability *cap, HsWord i)
  85 {
  86   StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
  87   SET_HDR(p, Wzh_con_info, CCS_SYSTEM);
  88   p->payload[0]  = (StgClosure *)(StgWord)i;
  89   return p;
  90 }
  91
  92 HaskellObj
  93 rts_mkWord8 (Capability *cap, HsWord8 w)
  94 {
  95   /* see rts_mkInt* comments */
  96   StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
  97   SET_HDR(p, W8zh_con_info, CCS_SYSTEM);
  98   p->payload[0]  = (StgClosure *)(StgWord)(w & 0xff);
  99   return p;
 100 }
 101
 102 HaskellObj
 103 rts_mkWord16 (Capability *cap, HsWord16 w)
 104 {
 105   /* see rts_mkInt* comments */
 106   StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
 107   SET_HDR(p, W16zh_con_info, CCS_SYSTEM);
 108   p->payload[0]  = (StgClosure *)(StgWord)(w & 0xffff);
 109   return p;
 110 }
 111
 112 HaskellObj
 113 rts_mkWord32 (Capability *cap, HsWord32 w)
 114 {
 115   /* see rts_mkInt* comments */
 116   StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
 117   SET_HDR(p, W32zh_con_info, CCS_SYSTEM);
 118   p->payload[0]  = (StgClosure *)(StgWord)(w & 0xffffffff);
 119   return p;
 120 }
 121
 122 HaskellObj
 123 rts_mkWord64 (Capability *cap, HsWord64 w)
 124 {
 125   StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,2));
 126   /* see mk_Int8 comment */
 127   SET_HDR(p, W64zh_con_info, CCS_SYSTEM);
 128   ASSIGN_Word64((P_)&(p->payload[0]), w);
 129   return p;
 130 }
 131
 132
 133 HaskellObj
 134 rts_mkFloat (Capability *cap, HsFloat f)
 135 {
 136   StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
 137   SET_HDR(p, Fzh_con_info, CCS_SYSTEM);
 138   ASSIGN_FLT((P_)p->payload, (StgFloat)f);
 139   return p;
 140 }
 141
 142 HaskellObj
 143 rts_mkDouble (Capability *cap, HsDouble d)
 144 {
 145   StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,sizeofW(StgDouble)));
 146   SET_HDR(p, Dzh_con_info, CCS_SYSTEM);
 147   ASSIGN_DBL((P_)p->payload, (StgDouble)d);
 148   return p;
 149 }
 150
 151 HaskellObj
 152 rts_mkStablePtr (Capability *cap, HsStablePtr s)
 153 {
 154   StgClosure *p = (StgClosure *)allocateLocal(cap,sizeofW(StgHeader)+1);
 155   SET_HDR(p, StablePtr_con_info, CCS_SYSTEM);
 156   p->payload[0]  = (StgClosure *)s;
 157   return p;
 158 }
 159
 160 HaskellObj
 161 rts_mkPtr (Capability *cap, HsPtr a)
 162 {
 163   StgClosure *p = (StgClosure *)allocateLocal(cap,sizeofW(StgHeader)+1);
 164   SET_HDR(p, Ptr_con_info, CCS_SYSTEM);
 165   p->payload[0]  = (StgClosure *)a;
 166   return p;
 167 }
 168
 169 HaskellObj
 170 rts_mkFunPtr (Capability *cap, HsFunPtr a)
 171 {
 172   StgClosure *p = (StgClosure *)allocateLocal(cap,sizeofW(StgHeader)+1);
 173   SET_HDR(p, FunPtr_con_info, CCS_SYSTEM);
 174   p->payload[0]  = (StgClosure *)a;
 175   return p;
 176 }
 177
 178 HaskellObj
 179 rts_mkBool (Capability *cap STG_UNUSED, HsBool b)
 180 {
 181   if (b) {
 182     return (StgClosure *)True_closure;
 183   } else {
 184     return (StgClosure *)False_closure;
 185   }
 186 }
 187
 188 HaskellObj
 189 rts_mkString (Capability *cap, char *s)
 190 {
 191   return rts_apply(cap, (StgClosure *)unpackCString_closure, rts_mkPtr(cap,s));
 192 }
 193
 194 HaskellObj
 195 rts_apply (Capability *cap, HaskellObj f, HaskellObj arg)
 196 {
 197     StgThunk *ap;
 198
 199     ap = (StgThunk *)allocateLocal(cap,sizeofW(StgThunk) + 2);
 200     SET_HDR(ap, (StgInfoTable *)&stg_ap_2_upd_info, CCS_SYSTEM);
 201     ap->payload[0] = f;
 202     ap->payload[1] = arg;
 203     return (StgClosure *)ap;
 204 }
 205
 206 /* ----------------------------------------------------------------------------
 207    Deconstructing Haskell objects
 208
 209    We would like to assert that we have the right kind of object in
 210    each case, but this is problematic because in GHCi the info table
 211    for the D# constructor (say) might be dynamically loaded.  Hence we
 212    omit these assertions for now.
 213    ------------------------------------------------------------------------- */
 214
 215 HsChar
 216 rts_getChar (HaskellObj p)
 217 {
 218     // See comment above:
 219     // ASSERT(p->header.info == Czh_con_info ||
 220     //        p->header.info == Czh_static_info);
 221     return (StgChar)(StgWord)(UNTAG_CLOSURE(p)->payload[0]);
 222 }
 223
 224 HsInt
 225 rts_getInt (HaskellObj p)
 226 {
 227     // See comment above:
 228     // ASSERT(p->header.info == Izh_con_info ||
 229     //        p->header.info == Izh_static_info);
 230     return (HsInt)(UNTAG_CLOSURE(p)->payload[0]);
 231 }
 232
 233 HsInt8
 234 rts_getInt8 (HaskellObj p)
 235 {
 236     // See comment above:
 237     // ASSERT(p->header.info == I8zh_con_info ||
 238     //        p->header.info == I8zh_static_info);
 239     return (HsInt8)(HsInt)(UNTAG_CLOSURE(p)->payload[0]);
 240 }
 241
 242 HsInt16
 243 rts_getInt16 (HaskellObj p)
 244 {
 245     // See comment above:
 246     // ASSERT(p->header.info == I16zh_con_info ||
 247     //        p->header.info == I16zh_static_info);
 248     return (HsInt16)(HsInt)(UNTAG_CLOSURE(p)->payload[0]);
 249 }
 250
 251 HsInt32
 252 rts_getInt32 (HaskellObj p)
 253 {
 254     // See comment above:
 255     // ASSERT(p->header.info == I32zh_con_info ||
 256     //        p->header.info == I32zh_static_info);
 257   return (HsInt32)(HsInt)(UNTAG_CLOSURE(p)->payload[0]);
 258 }
 259
 260 HsInt64
 261 rts_getInt64 (HaskellObj p)
 262 {
 263     // See comment above:
 264     // ASSERT(p->header.info == I64zh_con_info ||
 265     //        p->header.info == I64zh_static_info);
 266     return PK_Int64((P_)&(UNTAG_CLOSURE(p)->payload[0]));
 267 }
 268
 269 HsWord
 270 rts_getWord (HaskellObj p)
 271 {
 272     // See comment above:
 273     // ASSERT(p->header.info == Wzh_con_info ||
 274     //        p->header.info == Wzh_static_info);
 275     return (HsWord)(UNTAG_CLOSURE(p)->payload[0]);
 276 }
 277
 278 HsWord8
 279 rts_getWord8 (HaskellObj p)
 280 {
 281     // See comment above:
 282     // ASSERT(p->header.info == W8zh_con_info ||
 283     //        p->header.info == W8zh_static_info);
 284     return (HsWord8)(HsWord)(UNTAG_CLOSURE(p)->payload[0]);
 285 }
 286
 287 HsWord16
 288 rts_getWord16 (HaskellObj p)
 289 {
 290     // See comment above:
 291     // ASSERT(p->header.info == W16zh_con_info ||
 292     //        p->header.info == W16zh_static_info);
 293     return (HsWord16)(HsWord)(UNTAG_CLOSURE(p)->payload[0]);
 294 }
 295
 296 HsWord32
 297 rts_getWord32 (HaskellObj p)
 298 {
 299     // See comment above:
 300     // ASSERT(p->header.info == W32zh_con_info ||
 301     //        p->header.info == W32zh_static_info);
 302     return (HsWord32)(HsWord)(UNTAG_CLOSURE(p)->payload[0]);
 303 }
 304
 305 HsWord64
 306 rts_getWord64 (HaskellObj p)
 307 {
 308     // See comment above:
 309     // ASSERT(p->header.info == W64zh_con_info ||
 310     //        p->header.info == W64zh_static_info);
 311     return PK_Word64((P_)&(UNTAG_CLOSURE(p)->payload[0]));
 312 }
 313
 314 HsFloat
 315 rts_getFloat (HaskellObj p)
 316 {
 317     // See comment above:
 318     // ASSERT(p->header.info == Fzh_con_info ||
 319     //        p->header.info == Fzh_static_info);
 320     return (float)(PK_FLT((P_)UNTAG_CLOSURE(p)->payload));
 321 }
 322
 323 HsDouble
 324 rts_getDouble (HaskellObj p)
 325 {
 326     // See comment above:
 327     // ASSERT(p->header.info == Dzh_con_info ||
 328     //        p->header.info == Dzh_static_info);
 329     return (double)(PK_DBL((P_)UNTAG_CLOSURE(p)->payload));
 330 }
 331
 332 HsStablePtr
 333 rts_getStablePtr (HaskellObj p)
 334 {
 335     // See comment above:
 336     // ASSERT(p->header.info == StablePtr_con_info ||
 337     //        p->header.info == StablePtr_static_info);
 338     return (StgStablePtr)(UNTAG_CLOSURE(p)->payload[0]);
 339 }
 340
 341 HsPtr
 342 rts_getPtr (HaskellObj p)
 343 {
 344     // See comment above:
 345     // ASSERT(p->header.info == Ptr_con_info ||
 346     //        p->header.info == Ptr_static_info);
 347     return (Capability *)(UNTAG_CLOSURE(p)->payload[0]);
 348 }
 349
 350 HsFunPtr
 351 rts_getFunPtr (HaskellObj p)
 352 {
 353     // See comment above:
 354     // ASSERT(p->header.info == FunPtr_con_info ||
 355     //        p->header.info == FunPtr_static_info);
 356     return (void *)(UNTAG_CLOSURE(p)->payload[0]);
 357 }
 358
 359 HsBool
 360 rts_getBool (HaskellObj p)
 361 {
 362     StgInfoTable *info;
 363
 364     info = get_itbl((StgClosure *)UNTAG_CLOSURE(p));
 365     if (info->srt_bitmap == 0) { // srt_bitmap is the constructor tag
 366         return 0;
 367     } else {
 368         return 1;
 369     }
 370 }
 371
 372 /* -----------------------------------------------------------------------------
 373    Creating threads
 374    -------------------------------------------------------------------------- */
 375
 376 INLINE_HEADER void pushClosure   (StgTSO *tso, StgWord c) {
 377   tso->sp--;
 378   tso->sp[0] = (W_) c;
 379 }
 380
 381 StgTSO *
 382 createGenThread (Capability *cap, nat stack_size,  StgClosure *closure)
 383 {
 384   StgTSO *t;
 385   t = createThread (cap, stack_size);
 386   pushClosure(t, (W_)closure);
 387   pushClosure(t, (W_)&stg_enter_info);
 388   return t;
 389 }
 390
 391 StgTSO *
 392 createIOThread (Capability *cap, nat stack_size,  StgClosure *closure)
 393 {
 394   StgTSO *t;
 395   t = createThread (cap, stack_size);
 396   pushClosure(t, (W_)&stg_noforceIO_info);
 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->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->stat;
 532 }
 533
 534 Capability *
 535 rts_lock (void)
 536 {
 537     Capability *cap;
 538     Task *task;
 539
 540     task = newBoundTask();
 541
 542     cap = NULL;
 543     waitForReturnCapability(&cap, task);
 544     return (Capability *)cap;
 545 }
 546
 547 // Exiting the RTS: we hold a Capability that is not necessarily the
 548 // same one that was originally returned by rts_lock(), because
 549 // rts_evalIO() etc. may return a new one.  Now that we have
 550 // investigated the return value, we can release the Capability,
 551 // and free the Task (in that order).
 552
 553 void
 554 rts_unlock (Capability *cap)
 555 {
 556     Task *task;
 557
 558     task = cap->running_task;
 559     ASSERT_FULL_CAPABILITY_INVARIANTS(cap,task);
 560
 561     // Now release the Capability.  With the capability released, GC
 562     // may happen.  NB. does not try to put the current Task on the
 563     // worker queue.
 564     // NB. keep cap->lock held while we call boundTaskExiting().  This
 565     // is necessary during shutdown, where we want the invariant that
 566     // after shutdownCapability(), all the Tasks associated with the
 567     // Capability have completed their shutdown too.  Otherwise we
 568     // could have boundTaskExiting()/workerTaskStop() running at some
 569     // random point in the future, which causes problems for
 570     // freeTaskManager().
 571     ACQUIRE_LOCK(&cap->lock);
 572     releaseCapability_(cap,rtsFalse);
 573
 574     // Finally, we can release the Task to the free list.
 575     boundTaskExiting(task);
 576     RELEASE_LOCK(&cap->lock);
 577 }