ghc/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 "Storage.h"
  12 #include "RtsAPI.h"
  13 #include "SchedAPI.h"
  14 #include "RtsFlags.h"
  15 #include "RtsUtils.h"
  16 #include "Prelude.h"
  17 #include "OSThreads.h"
  18 #include "Schedule.h"
  19 #include "Capability.h"
  20
  21 #include <stdlib.h>
  22
  23 static Capability *rtsApiCapability = NULL;
  24
  25 /* ----------------------------------------------------------------------------
  26    Building Haskell objects from C datatypes.
  27    ------------------------------------------------------------------------- */
  28 HaskellObj
  29 rts_mkChar (HsChar c)
  30 {
  31   StgClosure *p = (StgClosure *)allocate(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 (HsInt i)
  39 {
  40   StgClosure *p = (StgClosure *)allocate(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 (HsInt8 i)
  48 {
  49   StgClosure *p = (StgClosure *)allocate(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)((unsigned)i & 0xff);
  53   return p;
  54 }
  55
  56 HaskellObj
  57 rts_mkInt16 (HsInt16 i)
  58 {
  59   StgClosure *p = (StgClosure *)allocate(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)((unsigned)i & 0xffff);
  63   return p;
  64 }
  65
  66 HaskellObj
  67 rts_mkInt32 (HsInt32 i)
  68 {
  69   StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
  70   SET_HDR(p, I32zh_con_info, CCS_SYSTEM);
  71   p->payload[0]  = (StgClosure *)(StgInt)((unsigned)i & 0xffffffff);
  72   return p;
  73 }
  74
  75 HaskellObj
  76 rts_mkInt64 (HsInt64 i)
  77 {
  78   llong *tmp;
  79   StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,2));
  80   SET_HDR(p, I64zh_con_info, CCS_SYSTEM);
  81   tmp  = (llong*)&(p->payload[0]);
  82   *tmp = (StgInt64)i;
  83   return p;
  84 }
  85
  86 HaskellObj
  87 rts_mkWord (HsWord i)
  88 {
  89   StgClosure *p = (StgClosure *)allocate(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 (HsWord8 w)
  97 {
  98   /* see rts_mkInt* comments */
  99   StgClosure *p = (StgClosure *)allocate(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 (HsWord16 w)
 107 {
 108   /* see rts_mkInt* comments */
 109   StgClosure *p = (StgClosure *)allocate(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 (HsWord32 w)
 117 {
 118   /* see rts_mkInt* comments */
 119   StgClosure *p = (StgClosure *)allocate(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 (HsWord64 w)
 127 {
 128   ullong *tmp;
 129
 130   StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,2));
 131   /* see mk_Int8 comment */
 132   SET_HDR(p, W64zh_con_info, CCS_SYSTEM);
 133   tmp  = (ullong*)&(p->payload[0]);
 134   *tmp = (StgWord64)w;
 135   return p;
 136 }
 137
 138 HaskellObj
 139 rts_mkFloat (HsFloat f)
 140 {
 141   StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
 142   SET_HDR(p, Fzh_con_info, CCS_SYSTEM);
 143   ASSIGN_FLT((P_)p->payload, (StgFloat)f);
 144   return p;
 145 }
 146
 147 HaskellObj
 148 rts_mkDouble (HsDouble d)
 149 {
 150   StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,sizeofW(StgDouble)));
 151   SET_HDR(p, Dzh_con_info, CCS_SYSTEM);
 152   ASSIGN_DBL((P_)p->payload, (StgDouble)d);
 153   return p;
 154 }
 155
 156 HaskellObj
 157 rts_mkStablePtr (HsStablePtr s)
 158 {
 159   StgClosure *p = (StgClosure *)allocate(sizeofW(StgHeader)+1);
 160   SET_HDR(p, StablePtr_con_info, CCS_SYSTEM);
 161   p->payload[0]  = (StgClosure *)s;
 162   return p;
 163 }
 164
 165 HaskellObj
 166 rts_mkPtr (HsPtr a)
 167 {
 168   StgClosure *p = (StgClosure *)allocate(sizeofW(StgHeader)+1);
 169   SET_HDR(p, Ptr_con_info, CCS_SYSTEM);
 170   p->payload[0]  = (StgClosure *)a;
 171   return p;
 172 }
 173
 174 HaskellObj
 175 rts_mkFunPtr (HsFunPtr a)
 176 {
 177   StgClosure *p = (StgClosure *)allocate(sizeofW(StgHeader)+1);
 178   SET_HDR(p, FunPtr_con_info, CCS_SYSTEM);
 179   p->payload[0]  = (StgClosure *)a;
 180   return p;
 181 }
 182
 183 HaskellObj
 184 rts_mkBool (HsBool b)
 185 {
 186   if (b) {
 187     return (StgClosure *)True_closure;
 188   } else {
 189     return (StgClosure *)False_closure;
 190   }
 191 }
 192
 193 HaskellObj
 194 rts_mkString (char *s)
 195 {
 196   return rts_apply((StgClosure *)unpackCString_closure, rts_mkPtr(s));
 197 }
 198
 199 HaskellObj
 200 rts_apply (HaskellObj f, HaskellObj arg)
 201 {
 202     StgClosure *ap;
 203
 204     ap = (StgClosure *)allocate(sizeofW(StgClosure) + 2);
 205     SET_HDR(ap, (StgInfoTable *)&stg_ap_2_upd_info, CCS_SYSTEM);
 206     ap->payload[0] = f;
 207     ap->payload[1] = arg;
 208     return (StgClosure *)ap;
 209 }
 210
 211 /* ----------------------------------------------------------------------------
 212    Deconstructing Haskell objects
 213
 214    We would like to assert that we have the right kind of object in
 215    each case, but this is problematic because in GHCi the info table
 216    for the D# constructor (say) might be dynamically loaded.  Hence we
 217    omit these assertions for now.
 218    ------------------------------------------------------------------------- */
 219
 220 HsChar
 221 rts_getChar (HaskellObj p)
 222 {
 223     // See comment above:
 224     // ASSERT(p->header.info == Czh_con_info ||
 225     //        p->header.info == Czh_static_info);
 226     return (StgChar)(StgWord)(p->payload[0]);
 227 }
 228
 229 HsInt
 230 rts_getInt (HaskellObj p)
 231 {
 232     // See comment above:
 233     // ASSERT(p->header.info == Izh_con_info ||
 234     //        p->header.info == Izh_static_info);
 235     return (HsInt)(p->payload[0]);
 236 }
 237
 238 HsInt8
 239 rts_getInt8 (HaskellObj p)
 240 {
 241     // See comment above:
 242     // ASSERT(p->header.info == I8zh_con_info ||
 243     //        p->header.info == I8zh_static_info);
 244     return (HsInt8)(HsInt)(p->payload[0]);
 245 }
 246
 247 HsInt16
 248 rts_getInt16 (HaskellObj p)
 249 {
 250     // See comment above:
 251     // ASSERT(p->header.info == I16zh_con_info ||
 252     //        p->header.info == I16zh_static_info);
 253     return (HsInt16)(HsInt)(p->payload[0]);
 254 }
 255
 256 HsInt32
 257 rts_getInt32 (HaskellObj p)
 258 {
 259     // See comment above:
 260     // ASSERT(p->header.info == I32zh_con_info ||
 261     //        p->header.info == I32zh_static_info);
 262     return (HsInt32)(HsInt)(p->payload[0]);
 263 }
 264
 265 HsInt64
 266 rts_getInt64 (HaskellObj p)
 267 {
 268     HsInt64* tmp;
 269     // See comment above:
 270     // ASSERT(p->header.info == I64zh_con_info ||
 271     //        p->header.info == I64zh_static_info);
 272     tmp = (HsInt64*)&(p->payload[0]);
 273     return *tmp;
 274 }
 275 HsWord
 276 rts_getWord (HaskellObj p)
 277 {
 278     // See comment above:
 279     // ASSERT(p->header.info == Wzh_con_info ||
 280     //        p->header.info == Wzh_static_info);
 281     return (HsWord)(p->payload[0]);
 282 }
 283
 284 HsWord8
 285 rts_getWord8 (HaskellObj p)
 286 {
 287     // See comment above:
 288     // ASSERT(p->header.info == W8zh_con_info ||
 289     //        p->header.info == W8zh_static_info);
 290     return (HsWord8)(HsWord)(p->payload[0]);
 291 }
 292
 293 HsWord16
 294 rts_getWord16 (HaskellObj p)
 295 {
 296     // See comment above:
 297     // ASSERT(p->header.info == W16zh_con_info ||
 298     //        p->header.info == W16zh_static_info);
 299     return (HsWord16)(HsWord)(p->payload[0]);
 300 }
 301
 302 HsWord32
 303 rts_getWord32 (HaskellObj p)
 304 {
 305     // See comment above:
 306     // ASSERT(p->header.info == W32zh_con_info ||
 307     //        p->header.info == W32zh_static_info);
 308     return (HsWord32)(HsWord)(p->payload[0]);
 309 }
 310
 311
 312 HsWord64
 313 rts_getWord64 (HaskellObj p)
 314 {
 315     HsWord64* tmp;
 316     // See comment above:
 317     // ASSERT(p->header.info == W64zh_con_info ||
 318     //        p->header.info == W64zh_static_info);
 319     tmp = (HsWord64*)&(p->payload[0]);
 320     return *tmp;
 321 }
 322
 323 HsFloat
 324 rts_getFloat (HaskellObj p)
 325 {
 326     // See comment above:
 327     // ASSERT(p->header.info == Fzh_con_info ||
 328     //        p->header.info == Fzh_static_info);
 329     return (float)(PK_FLT((P_)p->payload));
 330 }
 331
 332 HsDouble
 333 rts_getDouble (HaskellObj p)
 334 {
 335     // See comment above:
 336     // ASSERT(p->header.info == Dzh_con_info ||
 337     //        p->header.info == Dzh_static_info);
 338     return (double)(PK_DBL((P_)p->payload));
 339 }
 340
 341 HsStablePtr
 342 rts_getStablePtr (HaskellObj p)
 343 {
 344     // See comment above:
 345     // ASSERT(p->header.info == StablePtr_con_info ||
 346     //        p->header.info == StablePtr_static_info);
 347     return (StgStablePtr)(p->payload[0]);
 348 }
 349
 350 HsPtr
 351 rts_getPtr (HaskellObj p)
 352 {
 353     // See comment above:
 354     // ASSERT(p->header.info == Ptr_con_info ||
 355     //        p->header.info == Ptr_static_info);
 356     return (void *)(p->payload[0]);
 357 }
 358
 359 HsFunPtr
 360 rts_getFunPtr (HaskellObj p)
 361 {
 362     // See comment above:
 363     // ASSERT(p->header.info == FunPtr_con_info ||
 364     //        p->header.info == FunPtr_static_info);
 365     return (void *)(p->payload[0]);
 366 }
 367
 368 HsBool
 369 rts_getBool (HaskellObj p)
 370 {
 371     StgInfoTable *info;
 372
 373     info = get_itbl((StgClosure *)p);
 374     if (info->srt_bitmap == 0) { // srt_bitmap is the constructor tag
 375         return 0;
 376     } else {
 377         return 1;
 378     }
 379 }
 380
 381 /* ----------------------------------------------------------------------------
 382    Evaluating Haskell expressions
 383    ------------------------------------------------------------------------- */
 384 SchedulerStatus
 385 rts_eval (HaskellObj p, /*out*/HaskellObj *ret)
 386 {
 387     StgTSO *tso;
 388     Capability *cap = rtsApiCapability;
 389     rtsApiCapability = NULL;
 390
 391     tso = createGenThread(RtsFlags.GcFlags.initialStkSize, p);
 392     return scheduleWaitThread(tso,ret,cap);
 393 }
 394
 395 SchedulerStatus
 396 rts_eval_ (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
 397 {
 398     StgTSO *tso;
 399     Capability *cap = rtsApiCapability;
 400     rtsApiCapability = NULL;
 401
 402     tso = createGenThread(stack_size, p);
 403     return scheduleWaitThread(tso,ret,cap);
 404 }
 405
 406 /*
 407  * rts_evalIO() evaluates a value of the form (IO a), forcing the action's
 408  * result to WHNF before returning.
 409  */
 410 SchedulerStatus
 411 rts_evalIO (HaskellObj p, /*out*/HaskellObj *ret)
 412 {
 413     StgTSO* tso;
 414     Capability *cap = rtsApiCapability;
 415     rtsApiCapability = NULL;
 416
 417     tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
 418     return scheduleWaitThread(tso,ret,cap);
 419 }
 420
 421 /*
 422  * rts_evalStableIO() is suitable for calling from Haskell.  It
 423  * evaluates a value of the form (StablePtr (IO a)), forcing the
 424  * action's result to WHNF before returning.  The result is returned
 425  * in a StablePtr.
 426  */
 427 SchedulerStatus
 428 rts_evalStableIO (HsStablePtr s, /*out*/HsStablePtr *ret)
 429 {
 430     StgTSO* tso;
 431     StgClosure *p, *r;
 432     SchedulerStatus stat;
 433     Capability *cap = rtsApiCapability;
 434     rtsApiCapability = NULL;
 435
 436     p = (StgClosure *)deRefStablePtr(s);
 437     tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
 438     stat = scheduleWaitThread(tso,&r,cap);
 439
 440     if (stat == Success && ret != NULL) {
 441         ASSERT(r != NULL);
 442         *ret = getStablePtr((StgPtr)r);
 443     }
 444
 445     return stat;
 446 }
 447
 448 /*
 449  * Like rts_evalIO(), but doesn't force the action's result.
 450  */
 451 SchedulerStatus
 452 rts_evalLazyIO (HaskellObj p, /*out*/HaskellObj *ret)
 453 {
 454     StgTSO *tso;
 455     Capability *cap = rtsApiCapability;
 456     rtsApiCapability = NULL;
 457
 458     tso = createIOThread(RtsFlags.GcFlags.initialStkSize, p);
 459     return scheduleWaitThread(tso,ret,cap);
 460 }
 461
 462 SchedulerStatus
 463 rts_evalLazyIO_ (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
 464 {
 465     StgTSO *tso;
 466     Capability *cap = rtsApiCapability;
 467     rtsApiCapability = NULL;
 468
 469     tso = createIOThread(stack_size, p);
 470     return scheduleWaitThread(tso,ret,cap);
 471 }
 472
 473 /* Convenience function for decoding the returned status. */
 474
 475 void
 476 rts_checkSchedStatus ( char* site, SchedulerStatus rc )
 477 {
 478     switch (rc) {
 479     case Success:
 480         return;
 481     case Killed:
 482         errorBelch("%s: uncaught exception",site);
 483         stg_exit(EXIT_FAILURE);
 484     case Interrupted:
 485         errorBelch("%s: interrupted", site);
 486         stg_exit(EXIT_FAILURE);
 487     default:
 488         errorBelch("%s: Return code (%d) not ok",(site),(rc));
 489         stg_exit(EXIT_FAILURE);
 490     }
 491 }
 492
 493 void
 494 rts_lock()
 495 {
 496 #ifdef RTS_SUPPORTS_THREADS
 497     ACQUIRE_LOCK(&sched_mutex);
 498
 499     // we request to get the capability immediately, in order to
 500     // a) stop other threads from using allocate()
 501     // b) wake the current worker thread from awaitEvent()
 502     //       (so that a thread started by rts_eval* will start immediately)
 503     waitForReturnCapability(&sched_mutex,&rtsApiCapability);
 504 #endif
 505 }
 506
 507 void
 508 rts_unlock()
 509 {
 510 #ifdef RTS_SUPPORTS_THREADS
 511     if (rtsApiCapability) {
 512         releaseCapability(rtsApiCapability);
 513     }
 514     rtsApiCapability = NULL;
 515     RELEASE_LOCK(&sched_mutex);
 516 #endif
 517 }