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