ghc/rts/RtsAPI.c

   1 /* ----------------------------------------------------------------------------
   2  * $Id: RtsAPI.c,v 1.51 2003/12/17 12:17:18 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 static Capability *rtsApiCapability = NULL;
  25
  26 /* ----------------------------------------------------------------------------
  27    Building Haskell objects from C datatypes.
  28    ------------------------------------------------------------------------- */
  29 HaskellObj
  30 rts_mkChar (HsChar c)
  31 {
  32   StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
  33   SET_HDR(p, Czh_con_info, CCS_SYSTEM);
  34   p->payload[0]  = (StgClosure *)(StgWord)(StgChar)c;
  35   return p;
  36 }
  37
  38 HaskellObj
  39 rts_mkInt (HsInt i)
  40 {
  41   StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
  42   SET_HDR(p, Izh_con_info, CCS_SYSTEM);
  43   p->payload[0]  = (StgClosure *)(StgInt)i;
  44   return p;
  45 }
  46
  47 HaskellObj
  48 rts_mkInt8 (HsInt8 i)
  49 {
  50   StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
  51   SET_HDR(p, I8zh_con_info, CCS_SYSTEM);
  52   /* Make sure we mask out the bits above the lowest 8 */
  53   p->payload[0]  = (StgClosure *)(StgInt)((unsigned)i & 0xff);
  54   return p;
  55 }
  56
  57 HaskellObj
  58 rts_mkInt16 (HsInt16 i)
  59 {
  60   StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
  61   SET_HDR(p, I16zh_con_info, CCS_SYSTEM);
  62   /* Make sure we mask out the relevant bits */
  63   p->payload[0]  = (StgClosure *)(StgInt)((unsigned)i & 0xffff);
  64   return p;
  65 }
  66
  67 HaskellObj
  68 rts_mkInt32 (HsInt32 i)
  69 {
  70   StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
  71   SET_HDR(p, I32zh_con_info, CCS_SYSTEM);
  72   p->payload[0]  = (StgClosure *)(StgInt)((unsigned)i & 0xffffffff);
  73   return p;
  74 }
  75
  76 HaskellObj
  77 rts_mkInt64 (HsInt64 i)
  78 {
  79   llong *tmp;
  80   StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,2));
  81   SET_HDR(p, I64zh_con_info, CCS_SYSTEM);
  82   tmp  = (llong*)&(p->payload[0]);
  83   *tmp = (StgInt64)i;
  84   return p;
  85 }
  86
  87 HaskellObj
  88 rts_mkWord (HsWord i)
  89 {
  90   StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
  91   SET_HDR(p, Wzh_con_info, CCS_SYSTEM);
  92   p->payload[0]  = (StgClosure *)(StgWord)i;
  93   return p;
  94 }
  95
  96 HaskellObj
  97 rts_mkWord8 (HsWord8 w)
  98 {
  99   /* see rts_mkInt* comments */
 100   StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
 101   SET_HDR(p, W8zh_con_info, CCS_SYSTEM);
 102   p->payload[0]  = (StgClosure *)(StgWord)(w & 0xff);
 103   return p;
 104 }
 105
 106 HaskellObj
 107 rts_mkWord16 (HsWord16 w)
 108 {
 109   /* see rts_mkInt* comments */
 110   StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
 111   SET_HDR(p, W16zh_con_info, CCS_SYSTEM);
 112   p->payload[0]  = (StgClosure *)(StgWord)(w & 0xffff);
 113   return p;
 114 }
 115
 116 HaskellObj
 117 rts_mkWord32 (HsWord32 w)
 118 {
 119   /* see rts_mkInt* comments */
 120   StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
 121   SET_HDR(p, W32zh_con_info, CCS_SYSTEM);
 122   p->payload[0]  = (StgClosure *)(StgWord)(w & 0xffffffff);
 123   return p;
 124 }
 125
 126 HaskellObj
 127 rts_mkWord64 (HsWord64 w)
 128 {
 129   ullong *tmp;
 130
 131   StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,2));
 132   /* see mk_Int8 comment */
 133   SET_HDR(p, W64zh_con_info, CCS_SYSTEM);
 134   tmp  = (ullong*)&(p->payload[0]);
 135   *tmp = (StgWord64)w;
 136   return p;
 137 }
 138
 139 HaskellObj
 140 rts_mkFloat (HsFloat f)
 141 {
 142   StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
 143   SET_HDR(p, Fzh_con_info, CCS_SYSTEM);
 144   ASSIGN_FLT((P_)p->payload, (StgFloat)f);
 145   return p;
 146 }
 147
 148 HaskellObj
 149 rts_mkDouble (HsDouble d)
 150 {
 151   StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,sizeofW(StgDouble)));
 152   SET_HDR(p, Dzh_con_info, CCS_SYSTEM);
 153   ASSIGN_DBL((P_)p->payload, (StgDouble)d);
 154   return p;
 155 }
 156
 157 HaskellObj
 158 rts_mkStablePtr (HsStablePtr s)
 159 {
 160   StgClosure *p = (StgClosure *)allocate(sizeofW(StgHeader)+1);
 161   SET_HDR(p, StablePtr_con_info, CCS_SYSTEM);
 162   p->payload[0]  = (StgClosure *)s;
 163   return p;
 164 }
 165
 166 HaskellObj
 167 rts_mkPtr (HsPtr a)
 168 {
 169   StgClosure *p = (StgClosure *)allocate(sizeofW(StgHeader)+1);
 170   SET_HDR(p, Ptr_con_info, CCS_SYSTEM);
 171   p->payload[0]  = (StgClosure *)a;
 172   return p;
 173 }
 174
 175 HaskellObj
 176 rts_mkFunPtr (HsFunPtr a)
 177 {
 178   StgClosure *p = (StgClosure *)allocate(sizeofW(StgHeader)+1);
 179   SET_HDR(p, FunPtr_con_info, CCS_SYSTEM);
 180   p->payload[0]  = (StgClosure *)a;
 181   return p;
 182 }
 183
 184 HaskellObj
 185 rts_mkBool (HsBool b)
 186 {
 187   if (b) {
 188     return (StgClosure *)True_closure;
 189   } else {
 190     return (StgClosure *)False_closure;
 191   }
 192 }
 193
 194 HaskellObj
 195 rts_mkString (char *s)
 196 {
 197   return rts_apply((StgClosure *)unpackCString_closure, rts_mkPtr(s));
 198 }
 199
 200 HaskellObj
 201 rts_apply (HaskellObj f, HaskellObj arg)
 202 {
 203     StgClosure *ap;
 204
 205     ap = (StgClosure *)allocate(sizeofW(StgClosure) + 2);
 206     SET_HDR(ap, (StgInfoTable *)&stg_ap_2_upd_info, CCS_SYSTEM);
 207     ap->payload[0] = f;
 208     ap->payload[1] = arg;
 209     return (StgClosure *)ap;
 210 }
 211
 212 /* ----------------------------------------------------------------------------
 213    Deconstructing Haskell objects
 214
 215    We would like to assert that we have the right kind of object in
 216    each case, but this is problematic because in GHCi the info table
 217    for the D# constructor (say) might be dynamically loaded.  Hence we
 218    omit these assertions for now.
 219    ------------------------------------------------------------------------- */
 220
 221 HsChar
 222 rts_getChar (HaskellObj p)
 223 {
 224     // See comment above:
 225     // ASSERT(p->header.info == Czh_con_info ||
 226     //        p->header.info == Czh_static_info);
 227     return (StgChar)(StgWord)(p->payload[0]);
 228 }
 229
 230 HsInt
 231 rts_getInt (HaskellObj p)
 232 {
 233     // See comment above:
 234     // ASSERT(p->header.info == Izh_con_info ||
 235     //        p->header.info == Izh_static_info);
 236     return (HsInt)(p->payload[0]);
 237 }
 238
 239 HsInt8
 240 rts_getInt8 (HaskellObj p)
 241 {
 242     // See comment above:
 243     // ASSERT(p->header.info == I8zh_con_info ||
 244     //        p->header.info == I8zh_static_info);
 245     return (HsInt8)(HsInt)(p->payload[0]);
 246 }
 247
 248 HsInt16
 249 rts_getInt16 (HaskellObj p)
 250 {
 251     // See comment above:
 252     // ASSERT(p->header.info == I16zh_con_info ||
 253     //        p->header.info == I16zh_static_info);
 254     return (HsInt16)(HsInt)(p->payload[0]);
 255 }
 256
 257 HsInt32
 258 rts_getInt32 (HaskellObj p)
 259 {
 260     // See comment above:
 261     // ASSERT(p->header.info == I32zh_con_info ||
 262     //        p->header.info == I32zh_static_info);
 263     return (HsInt32)(HsInt)(p->payload[0]);
 264 }
 265
 266 HsInt64
 267 rts_getInt64 (HaskellObj p)
 268 {
 269     HsInt64* tmp;
 270     // See comment above:
 271     // ASSERT(p->header.info == I64zh_con_info ||
 272     //        p->header.info == I64zh_static_info);
 273     tmp = (HsInt64*)&(p->payload[0]);
 274     return *tmp;
 275 }
 276 HsWord
 277 rts_getWord (HaskellObj p)
 278 {
 279     // See comment above:
 280     // ASSERT(p->header.info == Wzh_con_info ||
 281     //        p->header.info == Wzh_static_info);
 282     return (HsWord)(p->payload[0]);
 283 }
 284
 285 HsWord8
 286 rts_getWord8 (HaskellObj p)
 287 {
 288     // See comment above:
 289     // ASSERT(p->header.info == W8zh_con_info ||
 290     //        p->header.info == W8zh_static_info);
 291     return (HsWord8)(HsWord)(p->payload[0]);
 292 }
 293
 294 HsWord16
 295 rts_getWord16 (HaskellObj p)
 296 {
 297     // See comment above:
 298     // ASSERT(p->header.info == W16zh_con_info ||
 299     //        p->header.info == W16zh_static_info);
 300     return (HsWord16)(HsWord)(p->payload[0]);
 301 }
 302
 303 HsWord32
 304 rts_getWord32 (HaskellObj p)
 305 {
 306     // See comment above:
 307     // ASSERT(p->header.info == W32zh_con_info ||
 308     //        p->header.info == W32zh_static_info);
 309     return (HsWord32)(HsWord)(p->payload[0]);
 310 }
 311
 312
 313 HsWord64
 314 rts_getWord64 (HaskellObj p)
 315 {
 316     HsWord64* tmp;
 317     // See comment above:
 318     // ASSERT(p->header.info == W64zh_con_info ||
 319     //        p->header.info == W64zh_static_info);
 320     tmp = (HsWord64*)&(p->payload[0]);
 321     return *tmp;
 322 }
 323
 324 HsFloat
 325 rts_getFloat (HaskellObj p)
 326 {
 327     // See comment above:
 328     // ASSERT(p->header.info == Fzh_con_info ||
 329     //        p->header.info == Fzh_static_info);
 330     return (float)(PK_FLT((P_)p->payload));
 331 }
 332
 333 HsDouble
 334 rts_getDouble (HaskellObj p)
 335 {
 336     // See comment above:
 337     // ASSERT(p->header.info == Dzh_con_info ||
 338     //        p->header.info == Dzh_static_info);
 339     return (double)(PK_DBL((P_)p->payload));
 340 }
 341
 342 HsStablePtr
 343 rts_getStablePtr (HaskellObj p)
 344 {
 345     // See comment above:
 346     // ASSERT(p->header.info == StablePtr_con_info ||
 347     //        p->header.info == StablePtr_static_info);
 348     return (StgStablePtr)(p->payload[0]);
 349 }
 350
 351 HsPtr
 352 rts_getPtr (HaskellObj p)
 353 {
 354     // See comment above:
 355     // ASSERT(p->header.info == Ptr_con_info ||
 356     //        p->header.info == Ptr_static_info);
 357     return (void *)(p->payload[0]);
 358 }
 359
 360 HsFunPtr
 361 rts_getFunPtr (HaskellObj p)
 362 {
 363     // See comment above:
 364     // ASSERT(p->header.info == FunPtr_con_info ||
 365     //        p->header.info == FunPtr_static_info);
 366     return (void *)(p->payload[0]);
 367 }
 368
 369 HsBool
 370 rts_getBool (HaskellObj p)
 371 {
 372     StgInfoTable *info;
 373
 374     info = get_itbl((StgClosure *)p);
 375     if (info->srt_bitmap == 0) { // srt_bitmap is the constructor tag
 376         return 0;
 377     } else {
 378         return 1;
 379     }
 380 }
 381
 382 /* ----------------------------------------------------------------------------
 383    Evaluating Haskell expressions
 384    ------------------------------------------------------------------------- */
 385 SchedulerStatus
 386 rts_eval (HaskellObj p, /*out*/HaskellObj *ret)
 387 {
 388     StgTSO *tso;
 389     Capability *cap = rtsApiCapability;
 390     rtsApiCapability = NULL;
 391
 392     tso = createGenThread(RtsFlags.GcFlags.initialStkSize, p);
 393     return scheduleWaitThread(tso,ret,cap);
 394 }
 395
 396 SchedulerStatus
 397 rts_eval_ (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
 398 {
 399     StgTSO *tso;
 400     Capability *cap = rtsApiCapability;
 401     rtsApiCapability = NULL;
 402
 403     tso = createGenThread(stack_size, p);
 404     return scheduleWaitThread(tso,ret,cap);
 405 }
 406
 407 /*
 408  * rts_evalIO() evaluates a value of the form (IO a), forcing the action's
 409  * result to WHNF before returning.
 410  */
 411 SchedulerStatus
 412 rts_evalIO (HaskellObj p, /*out*/HaskellObj *ret)
 413 {
 414     StgTSO* tso;
 415     Capability *cap = rtsApiCapability;
 416     rtsApiCapability = NULL;
 417
 418     tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
 419     return scheduleWaitThread(tso,ret,cap);
 420 }
 421
 422 /*
 423  * rts_evalStableIO() is suitable for calling from Haskell.  It
 424  * evaluates a value of the form (StablePtr (IO a)), forcing the
 425  * action's result to WHNF before returning.  The result is returned
 426  * in a StablePtr.
 427  */
 428 SchedulerStatus
 429 rts_evalStableIO (HsStablePtr s, /*out*/HsStablePtr *ret)
 430 {
 431     StgTSO* tso;
 432     StgClosure *p, *r;
 433     SchedulerStatus stat;
 434
 435     p = (StgClosure *)deRefStablePtr(s);
 436     tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
 437     stat = scheduleWaitThread(tso,&r,rtsApiCapability);
 438     rtsApiCapability = NULL;
 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         prog_belch("%s: uncaught exception",site);
 483         stg_exit(EXIT_FAILURE);
 484     case Interrupted:
 485         prog_belch("%s: interrupted", site);
 486         stg_exit(EXIT_FAILURE);
 487     default:
 488         prog_belch("%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 }