ghc/rts/RtsAPI.c

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