ghc/rts/RtsAPI.c

   1 /* ----------------------------------------------------------------------------
   2  * $Id: RtsAPI.c,v 1.36 2002/08/16 14:30:21 simonmar Exp $
   3  *
   4  * (c) The GHC Team, 1998-2001
   5  *
   6  * API for invoking Haskell functions via the RTS
   7  *
   8  * --------------------------------------------------------------------------*/
   9
  10 #include "PosixSource.h"
  11 #include "Rts.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 "OSThreads.h"
  19 #include "Schedule.h"
  20
  21 #if defined(RTS_SUPPORTS_THREADS)
  22 /* Cheesy locking scheme while waiting for the
  23  * RTS API to change.
  24  */
  25 static Mutex     alloc_mutex = INIT_MUTEX_VAR;
  26 static Condition alloc_cond  = INIT_COND_VAR;
  27 #define INVALID_THREAD_ID ((OSThreadId)(-1))
  28
  29 /* Thread currently owning the allocator */
  30 static OSThreadId c_id = INVALID_THREAD_ID;
  31
  32 static StgPtr alloc(nat n)
  33 {
  34   OSThreadId tid = osThreadId();
  35   ACQUIRE_LOCK(&alloc_mutex);
  36   if (tid == c_id) {
  37     /* I've got the lock, just allocate() */
  38     ;
  39   } else if (c_id == INVALID_THREAD_ID) {
  40     c_id = tid;
  41   } else {
  42     waitCondition(&alloc_cond, &alloc_mutex);
  43     c_id = tid;
  44   }
  45   RELEASE_LOCK(&alloc_mutex);
  46   return allocate(n);
  47 }
  48
  49 static void releaseAllocLock(void)
  50 {
  51   ACQUIRE_LOCK(&alloc_mutex);
  52   /* Reset the allocator owner */
  53   c_id = INVALID_THREAD_ID;
  54   RELEASE_LOCK(&alloc_mutex);
  55
  56   /* Free up an OS thread waiting to get in */
  57   signalCondition(&alloc_cond);
  58 }
  59 #else
  60 # define alloc(n) allocate(n)
  61 # define releaseAllocLock() /* nothing */
  62 #endif
  63
  64
  65 /* ----------------------------------------------------------------------------
  66    Building Haskell objects from C datatypes.
  67    ------------------------------------------------------------------------- */
  68 HaskellObj
  69 rts_mkChar (HsChar c)
  70 {
  71   StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
  72   SET_HDR(p, Czh_con_info, CCS_SYSTEM);
  73   p->payload[0]  = (StgClosure *)(StgChar)c;
  74   return p;
  75 }
  76
  77 HaskellObj
  78 rts_mkInt (HsInt i)
  79 {
  80   StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
  81   SET_HDR(p, Izh_con_info, CCS_SYSTEM);
  82   p->payload[0]  = (StgClosure *)(StgInt)i;
  83   return p;
  84 }
  85
  86 HaskellObj
  87 rts_mkInt8 (HsInt8 i)
  88 {
  89   StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
  90   SET_HDR(p, I8zh_con_info, CCS_SYSTEM);
  91   /* Make sure we mask out the bits above the lowest 8 */
  92   p->payload[0]  = (StgClosure *)(StgInt)((unsigned)i & 0xff);
  93   return p;
  94 }
  95
  96 HaskellObj
  97 rts_mkInt16 (HsInt16 i)
  98 {
  99   StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
 100   SET_HDR(p, I16zh_con_info, CCS_SYSTEM);
 101   /* Make sure we mask out the relevant bits */
 102   p->payload[0]  = (StgClosure *)(StgInt)((unsigned)i & 0xffff);
 103   return p;
 104 }
 105
 106 HaskellObj
 107 rts_mkInt32 (HsInt32 i)
 108 {
 109   StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
 110   SET_HDR(p, I32zh_con_info, CCS_SYSTEM);
 111   p->payload[0]  = (StgClosure *)(StgInt)((unsigned)i & 0xffffffff);
 112   return p;
 113 }
 114
 115 HaskellObj
 116 rts_mkInt64 (HsInt64 i)
 117 {
 118   long long *tmp;
 119   StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,2));
 120   SET_HDR(p, I64zh_con_info, CCS_SYSTEM);
 121   tmp  = (long long*)&(p->payload[0]);
 122   *tmp = (StgInt64)i;
 123   return p;
 124 }
 125
 126 HaskellObj
 127 rts_mkWord (HsWord i)
 128 {
 129   StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
 130   SET_HDR(p, Wzh_con_info, CCS_SYSTEM);
 131   p->payload[0]  = (StgClosure *)(StgWord)i;
 132   return p;
 133 }
 134
 135 HaskellObj
 136 rts_mkWord8 (HsWord8 w)
 137 {
 138   /* see rts_mkInt* comments */
 139   StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
 140   SET_HDR(p, W8zh_con_info, CCS_SYSTEM);
 141   p->payload[0]  = (StgClosure *)(StgWord)(w & 0xff);
 142   return p;
 143 }
 144
 145 HaskellObj
 146 rts_mkWord16 (HsWord16 w)
 147 {
 148   /* see rts_mkInt* comments */
 149   StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
 150   SET_HDR(p, W16zh_con_info, CCS_SYSTEM);
 151   p->payload[0]  = (StgClosure *)(StgWord)(w & 0xffff);
 152   return p;
 153 }
 154
 155 HaskellObj
 156 rts_mkWord32 (HsWord32 w)
 157 {
 158   /* see rts_mkInt* comments */
 159   StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
 160   SET_HDR(p, W32zh_con_info, CCS_SYSTEM);
 161   p->payload[0]  = (StgClosure *)(StgWord)(w & 0xffffffff);
 162   return p;
 163 }
 164
 165 HaskellObj
 166 rts_mkWord64 (HsWord64 w)
 167 {
 168   unsigned long long *tmp;
 169
 170   StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,2));
 171   /* see mk_Int8 comment */
 172   SET_HDR(p, W64zh_con_info, CCS_SYSTEM);
 173   tmp  = (unsigned long long*)&(p->payload[0]);
 174   *tmp = (StgWord64)w;
 175   return p;
 176 }
 177
 178 HaskellObj
 179 rts_mkFloat (HsFloat f)
 180 {
 181   StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
 182   SET_HDR(p, Fzh_con_info, CCS_SYSTEM);
 183   ASSIGN_FLT((P_)p->payload, (StgFloat)f);
 184   return p;
 185 }
 186
 187 HaskellObj
 188 rts_mkDouble (HsDouble d)
 189 {
 190   StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,sizeofW(StgDouble)));
 191   SET_HDR(p, Dzh_con_info, CCS_SYSTEM);
 192   ASSIGN_DBL((P_)p->payload, (StgDouble)d);
 193   return p;
 194 }
 195
 196 HaskellObj
 197 rts_mkStablePtr (HsStablePtr s)
 198 {
 199   StgClosure *p = (StgClosure *)alloc(sizeofW(StgHeader)+1);
 200   SET_HDR(p, StablePtr_con_info, CCS_SYSTEM);
 201   p->payload[0]  = (StgClosure *)s;
 202   return p;
 203 }
 204
 205 HaskellObj
 206 rts_mkPtr (HsPtr a)
 207 {
 208   StgClosure *p = (StgClosure *)alloc(sizeofW(StgHeader)+1);
 209   SET_HDR(p, Ptr_con_info, CCS_SYSTEM);
 210   p->payload[0]  = (StgClosure *)a;
 211   return p;
 212 }
 213
 214 #ifdef COMPILER /* GHC has em, Hugs doesn't */
 215 HaskellObj
 216 rts_mkBool (HsBool b)
 217 {
 218   if (b) {
 219     return (StgClosure *)True_closure;
 220   } else {
 221     return (StgClosure *)False_closure;
 222   }
 223 }
 224
 225 HaskellObj
 226 rts_mkString (char *s)
 227 {
 228   return rts_apply((StgClosure *)unpackCString_closure, rts_mkPtr(s));
 229 }
 230 #endif /* COMPILER */
 231
 232 HaskellObj
 233 rts_apply (HaskellObj f, HaskellObj arg)
 234 {
 235     StgClosure *ap;
 236
 237     ap = (StgClosure *)alloc(sizeofW(StgClosure) + 2);
 238     SET_HDR(ap, (StgInfoTable *)&stg_ap_2_upd_info, CCS_SYSTEM);
 239     ap->payload[0] = f;
 240     ap->payload[1] = arg;
 241     return (StgClosure *)ap;
 242 }
 243
 244 /* ----------------------------------------------------------------------------
 245    Deconstructing Haskell objects
 246    ------------------------------------------------------------------------- */
 247
 248 HsChar
 249 rts_getChar (HaskellObj p)
 250 {
 251   if ( p->header.info == Czh_con_info ||
 252        p->header.info == Czh_static_info) {
 253     return (StgChar)(StgWord)(p->payload[0]);
 254   } else {
 255     barf("rts_getChar: not a Char");
 256   }
 257 }
 258
 259 HsInt
 260 rts_getInt (HaskellObj p)
 261 {
 262   if ( 1 ||
 263        p->header.info == Izh_con_info ||
 264        p->header.info == Izh_static_info ) {
 265     return (HsInt)(p->payload[0]);
 266   } else {
 267     barf("rts_getInt: not an Int");
 268   }
 269 }
 270
 271 HsInt8
 272 rts_getInt8 (HaskellObj p)
 273 {
 274   if ( 1 ||
 275        p->header.info == I8zh_con_info ||
 276        p->header.info == I8zh_static_info ) {
 277     return (HsInt8)(HsInt)(p->payload[0]);
 278   } else {
 279     barf("rts_getInt8: not an Int8");
 280   }
 281 }
 282
 283 HsInt16
 284 rts_getInt16 (HaskellObj p)
 285 {
 286   if ( 1 ||
 287        p->header.info == I16zh_con_info ||
 288        p->header.info == I16zh_static_info ) {
 289     return (HsInt16)(HsInt)(p->payload[0]);
 290   } else {
 291     barf("rts_getInt16: not an Int16");
 292   }
 293 }
 294
 295 HsInt32
 296 rts_getInt32 (HaskellObj p)
 297 {
 298   if ( 1 ||
 299        p->header.info == I32zh_con_info ||
 300        p->header.info == I32zh_static_info ) {
 301     return (HsInt32)(p->payload[0]);
 302   } else {
 303     barf("rts_getInt32: not an Int32");
 304   }
 305 }
 306
 307 HsInt64
 308 rts_getInt64 (HaskellObj p)
 309 {
 310   HsInt64* tmp;
 311   if ( 1 ||
 312        p->header.info == I64zh_con_info ||
 313        p->header.info == I64zh_static_info ) {
 314     tmp = (HsInt64*)&(p->payload[0]);
 315     return *tmp;
 316   } else {
 317     barf("rts_getInt64: not an Int64");
 318   }
 319 }
 320 HsWord
 321 rts_getWord (HaskellObj p)
 322 {
 323   if ( 1 || /* see above comment */
 324        p->header.info == Wzh_con_info ||
 325        p->header.info == Wzh_static_info ) {
 326     return (HsWord)(p->payload[0]);
 327   } else {
 328     barf("rts_getWord: not a Word");
 329   }
 330 }
 331
 332 HsWord8
 333 rts_getWord8 (HaskellObj p)
 334 {
 335   if ( 1 || /* see above comment */
 336        p->header.info == W8zh_con_info ||
 337        p->header.info == W8zh_static_info ) {
 338     return (HsWord8)(HsWord)(p->payload[0]);
 339   } else {
 340     barf("rts_getWord8: not a Word8");
 341   }
 342 }
 343
 344 HsWord16
 345 rts_getWord16 (HaskellObj p)
 346 {
 347   if ( 1 || /* see above comment */
 348        p->header.info == W16zh_con_info ||
 349        p->header.info == W16zh_static_info ) {
 350     return (HsWord16)(HsWord)(p->payload[0]);
 351   } else {
 352     barf("rts_getWord16: not a Word16");
 353   }
 354 }
 355
 356 HsWord32
 357 rts_getWord32 (HaskellObj p)
 358 {
 359   if ( 1 || /* see above comment */
 360        p->header.info == W32zh_con_info ||
 361        p->header.info == W32zh_static_info ) {
 362     return (unsigned int)(p->payload[0]);
 363   } else {
 364     barf("rts_getWord: not a Word");
 365   }
 366 }
 367
 368
 369 HsWord64
 370 rts_getWord64 (HaskellObj p)
 371 {
 372   HsWord64* tmp;
 373   if ( 1 || /* see above comment */
 374        p->header.info == W64zh_con_info ||
 375        p->header.info == W64zh_static_info ) {
 376     tmp = (HsWord64*)&(p->payload[0]);
 377     return *tmp;
 378   } else {
 379     barf("rts_getWord64: not a Word64");
 380   }
 381 }
 382
 383 HsFloat
 384 rts_getFloat (HaskellObj p)
 385 {
 386   if ( p->header.info == Fzh_con_info ||
 387        p->header.info == Fzh_static_info ) {
 388     return (float)(PK_FLT((P_)p->payload));
 389   } else {
 390     barf("rts_getFloat: not a Float");
 391   }
 392 }
 393
 394 HsDouble
 395 rts_getDouble (HaskellObj p)
 396 {
 397   if ( p->header.info == Dzh_con_info ||
 398        p->header.info == Dzh_static_info ) {
 399     return (double)(PK_DBL((P_)p->payload));
 400   } else {
 401     barf("rts_getDouble: not a Double");
 402   }
 403 }
 404
 405 HsStablePtr
 406 rts_getStablePtr (HaskellObj p)
 407 {
 408   if ( p->header.info == StablePtr_con_info ||
 409        p->header.info == StablePtr_static_info ) {
 410     return (StgStablePtr)(p->payload[0]);
 411   } else {
 412     barf("rts_getStablePtr: not a StablePtr");
 413   }
 414 }
 415
 416 HsPtr
 417 rts_getPtr (HaskellObj p)
 418 {
 419   if ( p->header.info == Ptr_con_info ||
 420        p->header.info == Ptr_static_info ) {
 421     return (void *)(p->payload[0]);
 422   } else {
 423     barf("rts_getPtr: not an Ptr");
 424   }
 425 }
 426
 427 #ifdef COMPILER /* GHC has em, Hugs doesn't */
 428 HsBool
 429 rts_getBool (HaskellObj p)
 430 {
 431   if (p == True_closure) {
 432     return 1;
 433   } else if (p == False_closure) {
 434     return 0;
 435   } else {
 436     barf("rts_getBool: not a Bool");
 437   }
 438 }
 439 #endif /* COMPILER */
 440
 441 /* ----------------------------------------------------------------------------
 442    Evaluating Haskell expressions
 443    ------------------------------------------------------------------------- */
 444 SchedulerStatus
 445 rts_eval (HaskellObj p, /*out*/HaskellObj *ret)
 446 {
 447     StgTSO *tso;
 448
 449     tso = createGenThread(RtsFlags.GcFlags.initialStkSize, p);
 450     releaseAllocLock();
 451     return scheduleWaitThread(tso,ret);
 452 }
 453
 454 SchedulerStatus
 455 rts_eval_ (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
 456 {
 457     StgTSO *tso;
 458
 459     tso = createGenThread(stack_size, p);
 460     releaseAllocLock();
 461     return scheduleWaitThread(tso,ret);
 462 }
 463
 464 /*
 465  * rts_evalIO() evaluates a value of the form (IO a), forcing the action's
 466  * result to WHNF before returning.
 467  */
 468 SchedulerStatus
 469 rts_evalIO (HaskellObj p, /*out*/HaskellObj *ret)
 470 {
 471     StgTSO* tso;
 472
 473     tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
 474     releaseAllocLock();
 475     return scheduleWaitThread(tso,ret);
 476 }
 477
 478 /*
 479  * Identical to rts_evalIO(), but won't create a new task/OS thread
 480  * to evaluate the Haskell thread. Used by main() only. Hack.
 481  */
 482 SchedulerStatus
 483 rts_mainEvalIO(HaskellObj p, /*out*/HaskellObj *ret)
 484 {
 485     StgTSO* tso;
 486
 487     tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
 488     releaseAllocLock();
 489     scheduleThread(tso);
 490     return waitThread(tso, ret);
 491 }
 492
 493 /*
 494  * rts_evalStableIO() is suitable for calling from Haskell.  It
 495  * evaluates a value of the form (StablePtr (IO a)), forcing the
 496  * action's result to WHNF before returning.  The result is returned
 497  * in a StablePtr.
 498  */
 499 SchedulerStatus
 500 rts_evalStableIO (HsStablePtr s, /*out*/HsStablePtr *ret)
 501 {
 502     StgTSO* tso;
 503     StgClosure *p, *r;
 504     SchedulerStatus stat;
 505
 506     p = (StgClosure *)deRefStablePtr(s);
 507     tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
 508     releaseAllocLock();
 509     stat = scheduleWaitThread(tso,&r);
 510
 511     if (stat == Success) {
 512         ASSERT(r != NULL);
 513         *ret = getStablePtr((StgPtr)r);
 514     }
 515
 516     return stat;
 517 }
 518
 519 /*
 520  * Like rts_evalIO(), but doesn't force the action's result.
 521  */
 522 SchedulerStatus
 523 rts_evalLazyIO (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
 524 {
 525     StgTSO *tso;
 526
 527     tso = createIOThread(stack_size, p);
 528     releaseAllocLock();
 529     return scheduleWaitThread(tso,ret);
 530 }
 531
 532 /* Convenience function for decoding the returned status. */
 533
 534 void
 535 rts_checkSchedStatus ( char* site, SchedulerStatus rc )
 536 {
 537     switch (rc) {
 538     case Success:
 539         return;
 540     case Killed:
 541         barf("%s: uncaught exception",site);
 542     case Interrupted:
 543         barf("%s: interrupted", site);
 544     default:
 545         barf("%s: Return code (%d) not ok",(site),(rc));
 546     }
 547 }