ghc/rts/RtsAPI.c

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