ghc/rts/RtsAPI.c

   1 /* ----------------------------------------------------------------------------
   2  * $Id: RtsAPI.c,v 1.43 2003/03/18 10:28:15 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 #ifdef COMPILER /* GHC has em, Hugs doesn't */
 183 HaskellObj
 184 rts_mkBool (HsBool b)
 185 {
 186   if (b) {
 187     return (StgClosure *)True_closure;
 188   } else {
 189     return (StgClosure *)False_closure;
 190   }
 191 }
 192
 193 HaskellObj
 194 rts_mkString (char *s)
 195 {
 196   return rts_apply((StgClosure *)unpackCString_closure, rts_mkPtr(s));
 197 }
 198 #endif /* COMPILER */
 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)(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)(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 #ifdef COMPILER /* GHC has em, Hugs doesn't */
 370 HsBool
 371 rts_getBool (HaskellObj p)
 372 {
 373   if (p == True_closure) {
 374     return 1;
 375   } else if (p == False_closure) {
 376     return 0;
 377   } else {
 378     barf("rts_getBool: not a Bool");
 379   }
 380 }
 381 #endif /* COMPILER */
 382
 383 /* ----------------------------------------------------------------------------
 384    Evaluating Haskell expressions
 385    ------------------------------------------------------------------------- */
 386 SchedulerStatus
 387 rts_eval (HaskellObj p, /*out*/HaskellObj *ret)
 388 {
 389     StgTSO *tso;
 390
 391     tso = createGenThread(RtsFlags.GcFlags.initialStkSize, p);
 392     return scheduleWaitThread(tso,ret);
 393 }
 394
 395 SchedulerStatus
 396 rts_eval_ (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
 397 {
 398     StgTSO *tso;
 399
 400     tso = createGenThread(stack_size, p);
 401     return scheduleWaitThread(tso,ret);
 402 }
 403
 404 /*
 405  * rts_evalIO() evaluates a value of the form (IO a), forcing the action's
 406  * result to WHNF before returning.
 407  */
 408 SchedulerStatus
 409 rts_evalIO (HaskellObj p, /*out*/HaskellObj *ret)
 410 {
 411     StgTSO* tso;
 412
 413     tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
 414     return scheduleWaitThread(tso,ret);
 415 }
 416
 417 /*
 418  * Identical to rts_evalLazyIO(), but won't create a new task/OS thread
 419  * to evaluate the Haskell thread. Used by main() only. Hack.
 420  */
 421
 422 SchedulerStatus
 423 rts_mainLazyIO(HaskellObj p, /*out*/HaskellObj *ret)
 424 {
 425     StgTSO* tso;
 426
 427     tso = createIOThread(RtsFlags.GcFlags.initialStkSize, p);
 428     scheduleThread(tso);
 429     return waitThread(tso, ret);
 430 }
 431
 432 /*
 433  * rts_evalStableIO() is suitable for calling from Haskell.  It
 434  * evaluates a value of the form (StablePtr (IO a)), forcing the
 435  * action's result to WHNF before returning.  The result is returned
 436  * in a StablePtr.
 437  */
 438 SchedulerStatus
 439 rts_evalStableIO (HsStablePtr s, /*out*/HsStablePtr *ret)
 440 {
 441     StgTSO* tso;
 442     StgClosure *p, *r;
 443     SchedulerStatus stat;
 444
 445     p = (StgClosure *)deRefStablePtr(s);
 446     tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
 447     stat = scheduleWaitThread(tso,&r);
 448
 449     if (stat == Success) {
 450         ASSERT(r != NULL);
 451         *ret = getStablePtr((StgPtr)r);
 452     }
 453
 454     return stat;
 455 }
 456
 457 /*
 458  * Like rts_evalIO(), but doesn't force the action's result.
 459  */
 460 SchedulerStatus
 461 rts_evalLazyIO (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
 462 {
 463     StgTSO *tso;
 464
 465     tso = createIOThread(stack_size, p);
 466     return scheduleWaitThread(tso,ret);
 467 }
 468
 469 /* Convenience function for decoding the returned status. */
 470
 471 void
 472 rts_checkSchedStatus ( char* site, SchedulerStatus rc )
 473 {
 474     switch (rc) {
 475     case Success:
 476         return;
 477     case Killed:
 478         prog_belch("%s: uncaught exception",site);
 479         stg_exit(EXIT_FAILURE);
 480     case Interrupted:
 481         prog_belch("%s: interrupted", site);
 482         stg_exit(EXIT_FAILURE);
 483     default:
 484         prog_belch("%s: Return code (%d) not ok",(site),(rc));
 485         stg_exit(EXIT_FAILURE);
 486     }
 487 }
 488
 489 void
 490 rts_lock()
 491 {
 492 #ifdef RTS_SUPPORTS_THREADS
 493         Capability *cap;
 494         ACQUIRE_LOCK(&sched_mutex);
 495
 496                 // we request to get the capability immediately, in order to
 497                 // a) stop other threads from using allocate()
 498                 // b) wake the current worker thread from awaitEvent()
 499                 //       (so that a thread started by rts_eval* will start immediately)
 500         grabReturnCapability(&sched_mutex,&cap);
 501
 502                 // now that we have the capability, we don't need it anymore
 503                 // (other threads will continue to run as soon as we release the sched_mutex)
 504         releaseCapability(cap);
 505
 506                 // In the RTS hasn't been entered yet,
 507                 // start a RTS task.
 508                 // If there is already a task available (waiting for the work capability),
 509                 // this will do nothing.
 510         startSchedulerTask();
 511 #endif
 512 }
 513
 514 void
 515 rts_unlock()
 516 {
 517 #ifdef RTS_SUPPORTS_THREADS
 518         RELEASE_LOCK(&sched_mutex);
 519 #endif
 520 }