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 "Storage.h"
  13 #include "RtsAPI.h"
  14 #include "SchedAPI.h"
  15 #include "RtsFlags.h"
  16 #include "RtsUtils.h"
  17 #include "Prelude.h"
  18 #include "Schedule.h"
  19 #include "Capability.h"
  20
  21 #include <stdlib.h>
  22
  23 /* ----------------------------------------------------------------------------
  24    Building Haskell objects from C datatypes.
  25    ------------------------------------------------------------------------- */
  26 HaskellObj
  27 rts_mkChar (Capability *cap, HsChar c)
  28 {
  29   StgClosure *p = (StgClosure *)allocateLocal(cap, CONSTR_sizeW(0,1));
  30   SET_HDR(p, Czh_con_info, CCS_SYSTEM);
  31   p->payload[0]  = (StgClosure *)(StgWord)(StgChar)c;
  32   return p;
  33 }
  34
  35 HaskellObj
  36 rts_mkInt (Capability *cap, HsInt i)
  37 {
  38   StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
  39   SET_HDR(p, Izh_con_info, CCS_SYSTEM);
  40   p->payload[0]  = (StgClosure *)(StgInt)i;
  41   return p;
  42 }
  43
  44 HaskellObj
  45 rts_mkInt8 (Capability *cap, HsInt8 i)
  46 {
  47   StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
  48   SET_HDR(p, I8zh_con_info, CCS_SYSTEM);
  49   /* Make sure we mask out the bits above the lowest 8 */
  50   p->payload[0]  = (StgClosure *)(StgInt)((unsigned)i & 0xff);
  51   return p;
  52 }
  53
  54 HaskellObj
  55 rts_mkInt16 (Capability *cap, HsInt16 i)
  56 {
  57   StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
  58   SET_HDR(p, I16zh_con_info, CCS_SYSTEM);
  59   /* Make sure we mask out the relevant bits */
  60   p->payload[0]  = (StgClosure *)(StgInt)((unsigned)i & 0xffff);
  61   return p;
  62 }
  63
  64 HaskellObj
  65 rts_mkInt32 (Capability *cap, HsInt32 i)
  66 {
  67   StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
  68   SET_HDR(p, I32zh_con_info, CCS_SYSTEM);
  69   p->payload[0]  = (StgClosure *)(StgInt)((unsigned)i & 0xffffffff);
  70   return p;
  71 }
  72
  73 HaskellObj
  74 rts_mkInt64 (Capability *cap, HsInt64 i)
  75 {
  76   llong *tmp;
  77   StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,2));
  78   SET_HDR(p, I64zh_con_info, CCS_SYSTEM);
  79   tmp  = (llong*)&(p->payload[0]);
  80   *tmp = (StgInt64)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   ullong *tmp;
 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   tmp  = (ullong*)&(p->payload[0]);
 132   *tmp = (StgWord64)w;
 133   return p;
 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)(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)(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)(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)(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)(p->payload[0]);
 261 }
 262
 263 HsInt64
 264 rts_getInt64 (HaskellObj p)
 265 {
 266     HsInt64* tmp;
 267     // See comment above:
 268     // ASSERT(p->header.info == I64zh_con_info ||
 269     //        p->header.info == I64zh_static_info);
 270     tmp = (HsInt64*)&(p->payload[0]);
 271     return *tmp;
 272 }
 273 HsWord
 274 rts_getWord (HaskellObj p)
 275 {
 276     // See comment above:
 277     // ASSERT(p->header.info == Wzh_con_info ||
 278     //        p->header.info == Wzh_static_info);
 279     return (HsWord)(p->payload[0]);
 280 }
 281
 282 HsWord8
 283 rts_getWord8 (HaskellObj p)
 284 {
 285     // See comment above:
 286     // ASSERT(p->header.info == W8zh_con_info ||
 287     //        p->header.info == W8zh_static_info);
 288     return (HsWord8)(HsWord)(p->payload[0]);
 289 }
 290
 291 HsWord16
 292 rts_getWord16 (HaskellObj p)
 293 {
 294     // See comment above:
 295     // ASSERT(p->header.info == W16zh_con_info ||
 296     //        p->header.info == W16zh_static_info);
 297     return (HsWord16)(HsWord)(p->payload[0]);
 298 }
 299
 300 HsWord32
 301 rts_getWord32 (HaskellObj p)
 302 {
 303     // See comment above:
 304     // ASSERT(p->header.info == W32zh_con_info ||
 305     //        p->header.info == W32zh_static_info);
 306     return (HsWord32)(HsWord)(p->payload[0]);
 307 }
 308
 309
 310 HsWord64
 311 rts_getWord64 (HaskellObj p)
 312 {
 313     HsWord64* tmp;
 314     // See comment above:
 315     // ASSERT(p->header.info == W64zh_con_info ||
 316     //        p->header.info == W64zh_static_info);
 317     tmp = (HsWord64*)&(p->payload[0]);
 318     return *tmp;
 319 }
 320
 321 HsFloat
 322 rts_getFloat (HaskellObj p)
 323 {
 324     // See comment above:
 325     // ASSERT(p->header.info == Fzh_con_info ||
 326     //        p->header.info == Fzh_static_info);
 327     return (float)(PK_FLT((P_)p->payload));
 328 }
 329
 330 HsDouble
 331 rts_getDouble (HaskellObj p)
 332 {
 333     // See comment above:
 334     // ASSERT(p->header.info == Dzh_con_info ||
 335     //        p->header.info == Dzh_static_info);
 336     return (double)(PK_DBL((P_)p->payload));
 337 }
 338
 339 HsStablePtr
 340 rts_getStablePtr (HaskellObj p)
 341 {
 342     // See comment above:
 343     // ASSERT(p->header.info == StablePtr_con_info ||
 344     //        p->header.info == StablePtr_static_info);
 345     return (StgStablePtr)(p->payload[0]);
 346 }
 347
 348 HsPtr
 349 rts_getPtr (HaskellObj p)
 350 {
 351     // See comment above:
 352     // ASSERT(p->header.info == Ptr_con_info ||
 353     //        p->header.info == Ptr_static_info);
 354     return (Capability *)(p->payload[0]);
 355 }
 356
 357 HsFunPtr
 358 rts_getFunPtr (HaskellObj p)
 359 {
 360     // See comment above:
 361     // ASSERT(p->header.info == FunPtr_con_info ||
 362     //        p->header.info == FunPtr_static_info);
 363     return (void *)(p->payload[0]);
 364 }
 365
 366 HsBool
 367 rts_getBool (HaskellObj p)
 368 {
 369     StgInfoTable *info;
 370
 371     info = get_itbl((StgClosure *)p);
 372     if (info->srt_bitmap == 0) { // srt_bitmap is the constructor tag
 373         return 0;
 374     } else {
 375         return 1;
 376     }
 377 }
 378
 379 /* -----------------------------------------------------------------------------
 380    Creating threads
 381    -------------------------------------------------------------------------- */
 382
 383 INLINE_HEADER void pushClosure   (StgTSO *tso, StgWord c) {
 384   tso->sp--;
 385   tso->sp[0] = (W_) c;
 386 }
 387
 388 StgTSO *
 389 createGenThread (Capability *cap, nat stack_size,  StgClosure *closure)
 390 {
 391   StgTSO *t;
 392 #if defined(GRAN)
 393   t = createThread (cap, stack_size, NO_PRI);
 394 #else
 395   t = createThread (cap, stack_size);
 396 #endif
 397   pushClosure(t, (W_)closure);
 398   pushClosure(t, (W_)&stg_enter_info);
 399   return t;
 400 }
 401
 402 StgTSO *
 403 createIOThread (Capability *cap, nat stack_size,  StgClosure *closure)
 404 {
 405   StgTSO *t;
 406 #if defined(GRAN)
 407   t = createThread (cap, stack_size, NO_PRI);
 408 #else
 409   t = createThread (cap, stack_size);
 410 #endif
 411   pushClosure(t, (W_)&stg_noforceIO_info);
 412   pushClosure(t, (W_)&stg_ap_v_info);
 413   pushClosure(t, (W_)closure);
 414   pushClosure(t, (W_)&stg_enter_info);
 415   return t;
 416 }
 417
 418 /*
 419  * Same as above, but also evaluate the result of the IO action
 420  * to whnf while we're at it.
 421  */
 422
 423 StgTSO *
 424 createStrictIOThread(Capability *cap, nat stack_size,  StgClosure *closure)
 425 {
 426   StgTSO *t;
 427 #if defined(GRAN)
 428   t = createThread(cap, stack_size, NO_PRI);
 429 #else
 430   t = createThread(cap, stack_size);
 431 #endif
 432   pushClosure(t, (W_)&stg_forceIO_info);
 433   pushClosure(t, (W_)&stg_ap_v_info);
 434   pushClosure(t, (W_)closure);
 435   pushClosure(t, (W_)&stg_enter_info);
 436   return t;
 437 }
 438
 439 /* ----------------------------------------------------------------------------
 440    Evaluating Haskell expressions
 441    ------------------------------------------------------------------------- */
 442
 443 Capability *
 444 rts_eval (Capability *cap, HaskellObj p, /*out*/HaskellObj *ret)
 445 {
 446     StgTSO *tso;
 447
 448     tso = createGenThread(cap, RtsFlags.GcFlags.initialStkSize, p);
 449     return scheduleWaitThread(tso,ret,cap);
 450 }
 451
 452 Capability *
 453 rts_eval_ (Capability *cap, HaskellObj p, unsigned int stack_size,
 454            /*out*/HaskellObj *ret)
 455 {
 456     StgTSO *tso;
 457
 458     tso = createGenThread(cap, stack_size, p);
 459     return scheduleWaitThread(tso,ret,cap);
 460 }
 461
 462 /*
 463  * rts_evalIO() evaluates a value of the form (IO a), forcing the action's
 464  * result to WHNF before returning.
 465  */
 466 Capability *
 467 rts_evalIO (Capability *cap, HaskellObj p, /*out*/HaskellObj *ret)
 468 {
 469     StgTSO* tso;
 470
 471     tso = createStrictIOThread(cap, RtsFlags.GcFlags.initialStkSize, p);
 472     return scheduleWaitThread(tso,ret,cap);
 473 }
 474
 475 /*
 476  * rts_evalStableIO() is suitable for calling from Haskell.  It
 477  * evaluates a value of the form (StablePtr (IO a)), forcing the
 478  * action's result to WHNF before returning.  The result is returned
 479  * in a StablePtr.
 480  */
 481 Capability *
 482 rts_evalStableIO (Capability *cap, HsStablePtr s, /*out*/HsStablePtr *ret)
 483 {
 484     StgTSO* tso;
 485     StgClosure *p, *r;
 486     SchedulerStatus stat;
 487
 488     p = (StgClosure *)deRefStablePtr(s);
 489     tso = createStrictIOThread(cap, RtsFlags.GcFlags.initialStkSize, p);
 490     cap = scheduleWaitThread(tso,&r,cap);
 491     stat = rts_getSchedStatus(cap);
 492
 493     if (stat == Success && ret != NULL) {
 494         ASSERT(r != NULL);
 495         *ret = getStablePtr((StgPtr)r);
 496     }
 497
 498     return cap;
 499 }
 500
 501 /*
 502  * Like rts_evalIO(), but doesn't force the action's result.
 503  */
 504 Capability *
 505 rts_evalLazyIO (Capability *cap, HaskellObj p, /*out*/HaskellObj *ret)
 506 {
 507     StgTSO *tso;
 508
 509     tso = createIOThread(cap, RtsFlags.GcFlags.initialStkSize, p);
 510     return scheduleWaitThread(tso,ret,cap);
 511 }
 512
 513 Capability *
 514 rts_evalLazyIO_ (Capability *cap, HaskellObj p, unsigned int stack_size,
 515                  /*out*/HaskellObj *ret)
 516 {
 517     StgTSO *tso;
 518
 519     tso = createIOThread(cap, stack_size, p);
 520     return scheduleWaitThread(tso,ret,cap);
 521 }
 522
 523 /* Convenience function for decoding the returned status. */
 524
 525 void
 526 rts_checkSchedStatus (char* site, Capability *cap)
 527 {
 528     SchedulerStatus rc = cap->running_task->stat;
 529     switch (rc) {
 530     case Success:
 531         return;
 532     case Killed:
 533         errorBelch("%s: uncaught exception",site);
 534         stg_exit(EXIT_FAILURE);
 535     case Interrupted:
 536         errorBelch("%s: interrupted", site);
 537         stg_exit(EXIT_FAILURE);
 538     default:
 539         errorBelch("%s: Return code (%d) not ok",(site),(rc));
 540         stg_exit(EXIT_FAILURE);
 541     }
 542 }
 543
 544 SchedulerStatus
 545 rts_getSchedStatus (Capability *cap)
 546 {
 547     return cap->running_task->stat;
 548 }
 549
 550 Capability *
 551 rts_lock (void)
 552 {
 553     Capability *cap;
 554     Task *task;
 555
 556     // ToDo: get rid of this lock in the common case.  We could store
 557     // a free Task in thread-local storage, for example.  That would
 558     // leave just one lock on the path into the RTS: cap->lock when
 559     // acquiring the Capability.
 560     ACQUIRE_LOCK(&sched_mutex);
 561     task = newBoundTask();
 562     RELEASE_LOCK(&sched_mutex);
 563
 564     cap = NULL;
 565     waitForReturnCapability(&cap, task);
 566     return (Capability *)cap;
 567 }
 568
 569 // Exiting the RTS: we hold a Capability that is not necessarily the
 570 // same one that was originally returned by rts_lock(), because
 571 // rts_evalIO() etc. may return a new one.  Now that we have
 572 // investigated the return value, we can release the Capability,
 573 // and free the Task (in that order).
 574
 575 void
 576 rts_unlock (Capability *cap)
 577 {
 578     Task *task;
 579
 580     task = cap->running_task;
 581     ASSERT_FULL_CAPABILITY_INVARIANTS(cap,task);
 582
 583     // slightly delicate ordering of operations below, pay attention!
 584
 585     // We are no longer a bound task/thread.  This is important,
 586     // because the GC can run when we release the Capability below,
 587     // and we don't want it to treat this as a live TSO pointer.
 588     task->tso = NULL;
 589
 590     // Now release the Capability.  With the capability released, GC
 591     // may happen.  NB. does not try to put the current Task on the
 592     // worker queue.
 593     releaseCapability(cap);
 594
 595     // Finally, we can release the Task to the free list.
 596     boundTaskExiting(task);
 597 }