ghc/rts/RtsAPI.c

   1 /* ----------------------------------------------------------------------------
   2  * $Id: RtsAPI.c,v 1.44 2003/05/23 08:28:48 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 #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 HaskellObj
 174 rts_mkFunPtr (HsFunPtr a)
 175 {
 176   StgClosure *p = (StgClosure *)allocate(sizeofW(StgHeader)+1);
 177   SET_HDR(p, FunPtr_con_info, CCS_SYSTEM);
 178   p->payload[0]  = (StgClosure *)a;
 179   return p;
 180 }
 181
 182 HaskellObj
 183 rts_mkBool (HsBool b)
 184 {
 185   if (b) {
 186     return (StgClosure *)True_closure;
 187   } else {
 188     return (StgClosure *)False_closure;
 189   }
 190 }
 191
 192 HaskellObj
 193 rts_mkString (char *s)
 194 {
 195   return rts_apply((StgClosure *)unpackCString_closure, rts_mkPtr(s));
 196 }
 197
 198 HaskellObj
 199 rts_apply (HaskellObj f, HaskellObj arg)
 200 {
 201     StgClosure *ap;
 202
 203     ap = (StgClosure *)allocate(sizeofW(StgClosure) + 2);
 204     SET_HDR(ap, (StgInfoTable *)&stg_ap_2_upd_info, CCS_SYSTEM);
 205     ap->payload[0] = f;
 206     ap->payload[1] = arg;
 207     return (StgClosure *)ap;
 208 }
 209
 210 /* ----------------------------------------------------------------------------
 211    Deconstructing Haskell objects
 212
 213    We would like to assert that we have the right kind of object in
 214    each case, but this is problematic because in GHCi the info table
 215    for the D# constructor (say) might be dynamically loaded.  Hence we
 216    omit these assertions for now.
 217    ------------------------------------------------------------------------- */
 218
 219 HsChar
 220 rts_getChar (HaskellObj p)
 221 {
 222     // See comment above:
 223     // ASSERT(p->header.info == Czh_con_info ||
 224     //        p->header.info == Czh_static_info);
 225     return (StgChar)(StgWord)(p->payload[0]);
 226 }
 227
 228 HsInt
 229 rts_getInt (HaskellObj p)
 230 {
 231     // See comment above:
 232     // ASSERT(p->header.info == Izh_con_info ||
 233     //        p->header.info == Izh_static_info);
 234     return (HsInt)(p->payload[0]);
 235 }
 236
 237 HsInt8
 238 rts_getInt8 (HaskellObj p)
 239 {
 240     // See comment above:
 241     // ASSERT(p->header.info == I8zh_con_info ||
 242     //        p->header.info == I8zh_static_info);
 243     return (HsInt8)(HsInt)(p->payload[0]);
 244 }
 245
 246 HsInt16
 247 rts_getInt16 (HaskellObj p)
 248 {
 249     // See comment above:
 250     // ASSERT(p->header.info == I16zh_con_info ||
 251     //        p->header.info == I16zh_static_info);
 252     return (HsInt16)(HsInt)(p->payload[0]);
 253 }
 254
 255 HsInt32
 256 rts_getInt32 (HaskellObj p)
 257 {
 258     // See comment above:
 259     // ASSERT(p->header.info == I32zh_con_info ||
 260     //        p->header.info == I32zh_static_info);
 261     return (HsInt32)(p->payload[0]);
 262 }
 263
 264 HsInt64
 265 rts_getInt64 (HaskellObj p)
 266 {
 267     HsInt64* tmp;
 268     // See comment above:
 269     // ASSERT(p->header.info == I64zh_con_info ||
 270     //        p->header.info == I64zh_static_info);
 271     tmp = (HsInt64*)&(p->payload[0]);
 272     return *tmp;
 273 }
 274 HsWord
 275 rts_getWord (HaskellObj p)
 276 {
 277     // See comment above:
 278     // ASSERT(p->header.info == Wzh_con_info ||
 279     //        p->header.info == Wzh_static_info);
 280     return (HsWord)(p->payload[0]);
 281 }
 282
 283 HsWord8
 284 rts_getWord8 (HaskellObj p)
 285 {
 286     // See comment above:
 287     // ASSERT(p->header.info == W8zh_con_info ||
 288     //        p->header.info == W8zh_static_info);
 289     return (HsWord8)(HsWord)(p->payload[0]);
 290 }
 291
 292 HsWord16
 293 rts_getWord16 (HaskellObj p)
 294 {
 295     // See comment above:
 296     // ASSERT(p->header.info == W16zh_con_info ||
 297     //        p->header.info == W16zh_static_info);
 298     return (HsWord16)(HsWord)(p->payload[0]);
 299 }
 300
 301 HsWord32
 302 rts_getWord32 (HaskellObj p)
 303 {
 304     // See comment above:
 305     // ASSERT(p->header.info == W32zh_con_info ||
 306     //        p->header.info == W32zh_static_info);
 307     return (HsWord32)(p->payload[0]);
 308 }
 309
 310
 311 HsWord64
 312 rts_getWord64 (HaskellObj p)
 313 {
 314     HsWord64* tmp;
 315     // See comment above:
 316     // ASSERT(p->header.info == W64zh_con_info ||
 317     //        p->header.info == W64zh_static_info);
 318     tmp = (HsWord64*)&(p->payload[0]);
 319     return *tmp;
 320 }
 321
 322 HsFloat
 323 rts_getFloat (HaskellObj p)
 324 {
 325     // See comment above:
 326     // ASSERT(p->header.info == Fzh_con_info ||
 327     //        p->header.info == Fzh_static_info);
 328     return (float)(PK_FLT((P_)p->payload));
 329 }
 330
 331 HsDouble
 332 rts_getDouble (HaskellObj p)
 333 {
 334     // See comment above:
 335     // ASSERT(p->header.info == Dzh_con_info ||
 336     //        p->header.info == Dzh_static_info);
 337     return (double)(PK_DBL((P_)p->payload));
 338 }
 339
 340 HsStablePtr
 341 rts_getStablePtr (HaskellObj p)
 342 {
 343     // See comment above:
 344     // ASSERT(p->header.info == StablePtr_con_info ||
 345     //        p->header.info == StablePtr_static_info);
 346     return (StgStablePtr)(p->payload[0]);
 347 }
 348
 349 HsPtr
 350 rts_getPtr (HaskellObj p)
 351 {
 352     // See comment above:
 353     // ASSERT(p->header.info == Ptr_con_info ||
 354     //        p->header.info == Ptr_static_info);
 355     return (void *)(p->payload[0]);
 356 }
 357
 358 HsFunPtr
 359 rts_getFunPtr (HaskellObj p)
 360 {
 361     // See comment above:
 362     // ASSERT(p->header.info == FunPtr_con_info ||
 363     //        p->header.info == FunPtr_static_info);
 364     return (void *)(p->payload[0]);
 365 }
 366
 367 HsBool
 368 rts_getBool (HaskellObj p)
 369 {
 370   if (p == True_closure) {
 371     return 1;
 372   } else if (p == False_closure) {
 373     return 0;
 374   } else {
 375     barf("rts_getBool: not a Bool");
 376   }
 377 }
 378
 379 /* ----------------------------------------------------------------------------
 380    Evaluating Haskell expressions
 381    ------------------------------------------------------------------------- */
 382 SchedulerStatus
 383 rts_eval (HaskellObj p, /*out*/HaskellObj *ret)
 384 {
 385     StgTSO *tso;
 386
 387     tso = createGenThread(RtsFlags.GcFlags.initialStkSize, p);
 388     return scheduleWaitThread(tso,ret);
 389 }
 390
 391 SchedulerStatus
 392 rts_eval_ (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
 393 {
 394     StgTSO *tso;
 395
 396     tso = createGenThread(stack_size, p);
 397     return scheduleWaitThread(tso,ret);
 398 }
 399
 400 /*
 401  * rts_evalIO() evaluates a value of the form (IO a), forcing the action's
 402  * result to WHNF before returning.
 403  */
 404 SchedulerStatus
 405 rts_evalIO (HaskellObj p, /*out*/HaskellObj *ret)
 406 {
 407     StgTSO* tso;
 408
 409     tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
 410     return scheduleWaitThread(tso,ret);
 411 }
 412
 413 /*
 414  * Identical to rts_evalLazyIO(), but won't create a new task/OS thread
 415  * to evaluate the Haskell thread. Used by main() only. Hack.
 416  */
 417
 418 SchedulerStatus
 419 rts_mainLazyIO(HaskellObj p, /*out*/HaskellObj *ret)
 420 {
 421     StgTSO* tso;
 422
 423     tso = createIOThread(RtsFlags.GcFlags.initialStkSize, p);
 424     scheduleThread(tso);
 425     return waitThread(tso, ret);
 426 }
 427
 428 /*
 429  * rts_evalStableIO() is suitable for calling from Haskell.  It
 430  * evaluates a value of the form (StablePtr (IO a)), forcing the
 431  * action's result to WHNF before returning.  The result is returned
 432  * in a StablePtr.
 433  */
 434 SchedulerStatus
 435 rts_evalStableIO (HsStablePtr s, /*out*/HsStablePtr *ret)
 436 {
 437     StgTSO* tso;
 438     StgClosure *p, *r;
 439     SchedulerStatus stat;
 440
 441     p = (StgClosure *)deRefStablePtr(s);
 442     tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
 443     stat = scheduleWaitThread(tso,&r);
 444
 445     if (stat == Success) {
 446         ASSERT(r != NULL);
 447         *ret = getStablePtr((StgPtr)r);
 448     }
 449
 450     return stat;
 451 }
 452
 453 /*
 454  * Like rts_evalIO(), but doesn't force the action's result.
 455  */
 456 SchedulerStatus
 457 rts_evalLazyIO (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
 458 {
 459     StgTSO *tso;
 460
 461     tso = createIOThread(stack_size, p);
 462     return scheduleWaitThread(tso,ret);
 463 }
 464
 465 /* Convenience function for decoding the returned status. */
 466
 467 void
 468 rts_checkSchedStatus ( char* site, SchedulerStatus rc )
 469 {
 470     switch (rc) {
 471     case Success:
 472         return;
 473     case Killed:
 474         prog_belch("%s: uncaught exception",site);
 475         stg_exit(EXIT_FAILURE);
 476     case Interrupted:
 477         prog_belch("%s: interrupted", site);
 478         stg_exit(EXIT_FAILURE);
 479     default:
 480         prog_belch("%s: Return code (%d) not ok",(site),(rc));
 481         stg_exit(EXIT_FAILURE);
 482     }
 483 }
 484
 485 void
 486 rts_lock()
 487 {
 488 #ifdef RTS_SUPPORTS_THREADS
 489         Capability *cap;
 490         ACQUIRE_LOCK(&sched_mutex);
 491
 492                 // we request to get the capability immediately, in order to
 493                 // a) stop other threads from using allocate()
 494                 // b) wake the current worker thread from awaitEvent()
 495                 //       (so that a thread started by rts_eval* will start immediately)
 496         grabReturnCapability(&sched_mutex,&cap);
 497
 498                 // now that we have the capability, we don't need it anymore
 499                 // (other threads will continue to run as soon as we release the sched_mutex)
 500         releaseCapability(cap);
 501
 502                 // In the RTS hasn't been entered yet,
 503                 // start a RTS task.
 504                 // If there is already a task available (waiting for the work capability),
 505                 // this will do nothing.
 506         startSchedulerTask();
 507 #endif
 508 }
 509
 510 void
 511 rts_unlock()
 512 {
 513 #ifdef RTS_SUPPORTS_THREADS
 514         RELEASE_LOCK(&sched_mutex);
 515 #endif
 516 }