ghc/rts/RtsAPI.c

   1 /* ----------------------------------------------------------------------------
   2  * $Id: RtsAPI.c,v 1.46 2003/09/21 22:20:56 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 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   long long *tmp;
  80   StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,2));
  81   SET_HDR(p, I64zh_con_info, CCS_SYSTEM);
  82   tmp  = (long long*)&(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   unsigned long long *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  = (unsigned long long*)&(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   if (p == True_closure) {
 373     return 1;
 374   } else if (p == False_closure) {
 375     return 0;
 376   } else {
 377     barf("rts_getBool: not a Bool");
 378   }
 379 }
 380
 381 /* ----------------------------------------------------------------------------
 382    Evaluating Haskell expressions
 383    ------------------------------------------------------------------------- */
 384 SchedulerStatus
 385 rts_eval (HaskellObj p, /*out*/HaskellObj *ret)
 386 {
 387     StgTSO *tso;
 388
 389     tso = createGenThread(RtsFlags.GcFlags.initialStkSize, p);
 390     return scheduleWaitThread(tso,ret,rtsApiCapability);
 391 }
 392
 393 SchedulerStatus
 394 rts_eval_ (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
 395 {
 396     StgTSO *tso;
 397
 398     tso = createGenThread(stack_size, p);
 399     return scheduleWaitThread(tso,ret,rtsApiCapability);
 400 }
 401
 402 /*
 403  * rts_evalIO() evaluates a value of the form (IO a), forcing the action's
 404  * result to WHNF before returning.
 405  */
 406 SchedulerStatus
 407 rts_evalIO (HaskellObj p, /*out*/HaskellObj *ret)
 408 {
 409     StgTSO* tso;
 410
 411     tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
 412     return scheduleWaitThread(tso,ret,rtsApiCapability);
 413 }
 414
 415 /*
 416  * rts_evalStableIO() is suitable for calling from Haskell.  It
 417  * evaluates a value of the form (StablePtr (IO a)), forcing the
 418  * action's result to WHNF before returning.  The result is returned
 419  * in a StablePtr.
 420  */
 421 SchedulerStatus
 422 rts_evalStableIO (HsStablePtr s, /*out*/HsStablePtr *ret)
 423 {
 424     StgTSO* tso;
 425     StgClosure *p, *r;
 426     SchedulerStatus stat;
 427
 428     p = (StgClosure *)deRefStablePtr(s);
 429     tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
 430     stat = scheduleWaitThread(tso,&r,rtsApiCapability);
 431
 432     if (stat == Success && ret != NULL) {
 433         ASSERT(r != NULL);
 434         *ret = getStablePtr((StgPtr)r);
 435     }
 436
 437     return stat;
 438 }
 439
 440 /*
 441  * Like rts_evalIO(), but doesn't force the action's result.
 442  */
 443 SchedulerStatus
 444 rts_evalLazyIO (HaskellObj p, /*out*/HaskellObj *ret)
 445 {
 446     StgTSO *tso;
 447
 448     tso = createIOThread(RtsFlags.GcFlags.initialStkSize, p);
 449     return scheduleWaitThread(tso,ret,rtsApiCapability);
 450 }
 451
 452 SchedulerStatus
 453 rts_evalLazyIO_ (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
 454 {
 455     StgTSO *tso;
 456
 457     tso = createIOThread(stack_size, p);
 458     return scheduleWaitThread(tso,ret,rtsApiCapability);
 459 }
 460
 461 /* Convenience function for decoding the returned status. */
 462
 463 void
 464 rts_checkSchedStatus ( char* site, SchedulerStatus rc )
 465 {
 466     switch (rc) {
 467     case Success:
 468         return;
 469     case Killed:
 470         prog_belch("%s: uncaught exception",site);
 471         stg_exit(EXIT_FAILURE);
 472     case Interrupted:
 473         prog_belch("%s: interrupted", site);
 474         stg_exit(EXIT_FAILURE);
 475     default:
 476         prog_belch("%s: Return code (%d) not ok",(site),(rc));
 477         stg_exit(EXIT_FAILURE);
 478     }
 479 }
 480
 481 void
 482 rts_lock()
 483 {
 484 #ifdef RTS_SUPPORTS_THREADS
 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,&rtsApiCapability);
 492
 493                 // In the RTS hasn't been entered yet,
 494                 // start a RTS task.
 495                 // If there is already a task available (waiting for the work capability),
 496                 // this will do nothing.
 497         startSchedulerTask();
 498 #endif
 499 }
 500
 501 void
 502 rts_unlock()
 503 {
 504 #ifdef RTS_SUPPORTS_THREADS
 505         rtsApiCapability = NULL;
 506         RELEASE_LOCK(&sched_mutex);
 507 #endif
 508 }