ghc/rts/RtsAPI.c

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