ghc/rts/RtsAPI.c

   1 /* ----------------------------------------------------------------------------
   2  * $Id: RtsAPI.c,v 1.13 2000/03/31 03:09:36 hwloidl Exp $
   3  *
   4  * (c) The GHC Team, 1998-2000
   5  *
   6  * API for invoking Haskell functions via the RTS
   7  *
   8  * --------------------------------------------------------------------------*/
   9
  10 #include "Rts.h"
  11 #include "Storage.h"
  12 #include "RtsAPI.h"
  13 #include "SchedAPI.h"
  14 #include "RtsFlags.h"
  15 #include "RtsUtils.h"
  16 #include "Prelude.h"
  17
  18 /* ----------------------------------------------------------------------------
  19    Building Haskell objects from C datatypes.
  20    ------------------------------------------------------------------------- */
  21 HaskellObj
  22 rts_mkChar (char c)
  23 {
  24   StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
  25   p->header.info = Czh_con_info;
  26   p->payload[0]  = (StgClosure *)((StgInt)c);
  27   return p;
  28 }
  29
  30 HaskellObj
  31 rts_mkInt (int i)
  32 {
  33   StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
  34   p->header.info = Izh_con_info;
  35   p->payload[0]  = (StgClosure *)(StgInt)i;
  36   return p;
  37 }
  38
  39 HaskellObj
  40 rts_mkInt8 (int i)
  41 {
  42   StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
  43   /* This is a 'cheat', using the static info table for Ints,
  44      instead of the one for Int8, but the types have identical
  45      representation.
  46   */
  47   p->header.info = Izh_con_info;
  48   /* Make sure we mask out the bits above the lowest 8 */
  49   p->payload[0]  = (StgClosure *)(StgInt)((unsigned)i & 0xff);
  50   return p;
  51 }
  52
  53 HaskellObj
  54 rts_mkInt16 (int i)
  55 {
  56   StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
  57   /* This is a 'cheat', using the static info table for Ints,
  58      instead of the one for Int8, but the types have identical
  59      representation.
  60   */
  61   p->header.info = Izh_con_info;
  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 (int i)
  69 {
  70   StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
  71   /* see mk_Int8 comment */
  72   p->header.info = Izh_con_info;
  73   p->payload[0]  = (StgClosure *)(StgInt)i;
  74   return p;
  75 }
  76
  77 HaskellObj
  78 rts_mkInt64 (long long int i)
  79 {
  80   long long *tmp;
  81   StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,2));
  82   /* see mk_Int8 comment */
  83   p->header.info = I64zh_con_info;
  84   tmp  = (long long*)&(p->payload[0]);
  85   *tmp = (StgInt64)i;
  86   return p;
  87 }
  88
  89 HaskellObj
  90 rts_mkWord (unsigned int i)
  91 {
  92   StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
  93   p->header.info = Wzh_con_info;
  94   p->payload[0]  = (StgClosure *)(StgWord)i;
  95   return p;
  96 }
  97
  98 HaskellObj
  99 rts_mkWord8 (unsigned int w)
 100 {
 101   /* see rts_mkInt* comments */
 102   StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
 103   p->header.info = Wzh_con_info;
 104   p->payload[0]  = (StgClosure *)(StgWord)(w & 0xff);
 105   return p;
 106 }
 107
 108 HaskellObj
 109 rts_mkWord16 (unsigned int w)
 110 {
 111   /* see rts_mkInt* comments */
 112   StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
 113   p->header.info = Wzh_con_info;
 114   p->payload[0]  = (StgClosure *)(StgWord)(w & 0xffff);
 115   return p;
 116 }
 117
 118 HaskellObj
 119 rts_mkWord32 (unsigned int w)
 120 {
 121   /* see rts_mkInt* comments */
 122   StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
 123   p->header.info = Wzh_con_info;
 124   p->payload[0]  = (StgClosure *)(StgWord)w;
 125   return p;
 126 }
 127
 128 HaskellObj
 129 rts_mkWord64 (unsigned long long w)
 130 {
 131   unsigned long long *tmp;
 132
 133   StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,2));
 134   /* see mk_Int8 comment */
 135   p->header.info = W64zh_con_info;
 136   tmp  = (unsigned long long*)&(p->payload[0]);
 137   *tmp = (StgWord64)w;
 138   return p;
 139 }
 140
 141 HaskellObj
 142 rts_mkFloat (float f)
 143 {
 144   StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
 145   p->header.info = Fzh_con_info;
 146   ASSIGN_FLT((P_)p->payload, (StgFloat)f);
 147   return p;
 148 }
 149
 150 HaskellObj
 151 rts_mkDouble (double d)
 152 {
 153   StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,sizeofW(StgDouble)));
 154   p->header.info = Dzh_con_info;
 155   ASSIGN_DBL((P_)p->payload, (StgDouble)d);
 156   return p;
 157 }
 158
 159 HaskellObj
 160 rts_mkStablePtr (StgStablePtr s)
 161 {
 162   StgClosure *p = (StgClosure *)allocate(sizeofW(StgHeader)+1);
 163   p->header.info = StablePtr_con_info;
 164   p->payload[0]  = (StgClosure *)s;
 165   return p;
 166 }
 167
 168 HaskellObj
 169 rts_mkAddr (void *a)
 170 {
 171   StgClosure *p = (StgClosure *)allocate(sizeofW(StgHeader)+1);
 172   p->header.info = Azh_con_info;
 173   p->payload[0]  = (StgClosure *)a;
 174   return p;
 175 }
 176
 177 #ifdef COMPILER /* GHC has em, Hugs doesn't */
 178 HaskellObj
 179 rts_mkBool (int b)
 180 {
 181   if (b) {
 182     return (StgClosure *)True_closure;
 183   } else {
 184     return (StgClosure *)False_closure;
 185   }
 186 }
 187
 188 HaskellObj
 189 rts_mkString (char *s)
 190 {
 191   return rts_apply((StgClosure *)unpackCString_closure, rts_mkAddr(s));
 192 }
 193 #endif /* COMPILER */
 194
 195 HaskellObj
 196 rts_apply (HaskellObj f, HaskellObj arg)
 197 {
 198   StgAP_UPD *ap = (StgAP_UPD *)allocate(AP_sizeW(1));
 199   ap->header.info = &AP_UPD_info;
 200   ap->n_args = 1;
 201   ap->fun    = f;
 202   ap->payload[0] = (P_)arg;
 203   return (StgClosure *)ap;
 204 }
 205
 206 /* ----------------------------------------------------------------------------
 207    Deconstructing Haskell objects
 208    ------------------------------------------------------------------------- */
 209
 210 char
 211 rts_getChar (HaskellObj p)
 212 {
 213   if ( p->header.info == Czh_con_info ||
 214        p->header.info == Czh_static_info) {
 215     return (char)(StgWord)(p->payload[0]);
 216   } else {
 217     barf("getChar: not a Char");
 218   }
 219 }
 220
 221 int
 222 rts_getInt (HaskellObj p)
 223 {
 224   if ( 1 ||
 225        p->header.info == Izh_con_info ||
 226        p->header.info == Izh_static_info ) {
 227     return (int)(p->payload[0]);
 228   } else {
 229     barf("getInt: not an Int");
 230   }
 231 }
 232
 233 int
 234 rts_getInt32 (HaskellObj p)
 235 {
 236   if ( 1 ||
 237        p->header.info == Izh_con_info ||
 238        p->header.info == Izh_static_info ) {
 239     return (int)(p->payload[0]);
 240   } else {
 241     barf("getInt: not an Int");
 242   }
 243 }
 244
 245 unsigned int
 246 rts_getWord (HaskellObj p)
 247 {
 248   if ( 1 || /* see above comment */
 249        p->header.info == Wzh_con_info ||
 250        p->header.info == Wzh_static_info ) {
 251     return (unsigned int)(p->payload[0]);
 252   } else {
 253     barf("getWord: not a Word");
 254   }
 255 }
 256
 257 unsigned int
 258 rts_getWord32 (HaskellObj p)
 259 {
 260   if ( 1 || /* see above comment */
 261        p->header.info == Wzh_con_info ||
 262        p->header.info == Wzh_static_info ) {
 263     return (unsigned int)(p->payload[0]);
 264   } else {
 265     barf("getWord: not a Word");
 266   }
 267 }
 268
 269 float
 270 rts_getFloat (HaskellObj p)
 271 {
 272   if ( p->header.info == Fzh_con_info ||
 273        p->header.info == Fzh_static_info ) {
 274     return (float)(PK_FLT((P_)p->payload));
 275   } else {
 276     barf("getFloat: not a Float");
 277   }
 278 }
 279
 280 double
 281 rts_getDouble (HaskellObj p)
 282 {
 283   if ( p->header.info == Dzh_con_info ||
 284        p->header.info == Dzh_static_info ) {
 285     return (double)(PK_DBL((P_)p->payload));
 286   } else {
 287     barf("getDouble: not a Double");
 288   }
 289 }
 290
 291 StgStablePtr
 292 rts_getStablePtr (HaskellObj p)
 293 {
 294   if ( p->header.info == StablePtr_con_info ||
 295        p->header.info == StablePtr_static_info ) {
 296     return (StgStablePtr)(p->payload[0]);
 297   } else {
 298     barf("getStablePtr: not a StablePtr");
 299   }
 300 }
 301
 302 void *
 303 rts_getAddr (HaskellObj p)
 304 {
 305   if ( p->header.info == Azh_con_info ||
 306        p->header.info == Azh_static_info ) {
 307
 308     return (void *)(p->payload[0]);
 309   } else {
 310     barf("getAddr: not an Addr");
 311   }
 312 }
 313
 314 #ifdef COMPILER /* GHC has em, Hugs doesn't */
 315 int
 316 rts_getBool (HaskellObj p)
 317 {
 318   if (p == True_closure) {
 319     return 1;
 320   } else if (p == False_closure) {
 321     return 0;
 322   } else {
 323     barf("getBool: not a Bool");
 324   }
 325 }
 326 #endif /* COMPILER */
 327
 328 /* ----------------------------------------------------------------------------
 329    Evaluating Haskell expressions
 330    ------------------------------------------------------------------------- */
 331 SchedulerStatus
 332 rts_eval (HaskellObj p, /*out*/HaskellObj *ret)
 333 {
 334   StgTSO *tso = createGenThread(RtsFlags.GcFlags.initialStkSize, p);
 335   scheduleThread(tso);
 336   return waitThread(tso, ret);
 337 }
 338
 339 SchedulerStatus
 340 rts_eval_ (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
 341 {
 342   StgTSO *tso = createGenThread(stack_size, p);
 343   scheduleThread(tso);
 344   return waitThread(tso, ret);
 345 }
 346
 347 /*
 348  * rts_evalIO() evaluates a value of the form (IO a), forcing the action's
 349  * result to WHNF before returning.
 350  */
 351 SchedulerStatus
 352 rts_evalIO (HaskellObj p, /*out*/HaskellObj *ret)
 353 {
 354   StgTSO* tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
 355   scheduleThread(tso);
 356   return waitThread(tso, ret);
 357 }
 358
 359 /*
 360  * Like rts_evalIO(), but doesn't force the action's result.
 361  */
 362 SchedulerStatus
 363 rts_evalLazyIO (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
 364 {
 365   StgTSO *tso = createIOThread(stack_size, p);
 366   scheduleThread(tso);
 367   return waitThread(tso, ret);
 368 }
 369
 370 #if defined(PAR) || defined(SMP)
 371 /*
 372   Needed in the parallel world for non-Main PEs, which do not get a piece
 373   of work to start with --- they have to humbly ask for it
 374 */
 375
 376 SchedulerStatus
 377 rts_evalNothing(unsigned int stack_size)
 378 {
 379   /* ToDo: propagate real SchedulerStatus back to caller */
 380   scheduleThread(END_TSO_QUEUE);
 381   return Success;
 382 }
 383 #endif
 384
 385 /* Convenience function for decoding the returned status. */
 386
 387 void rts_checkSchedStatus ( char* site, SchedulerStatus rc )
 388 {
 389   if ( rc == Success ) {
 390      return;
 391   } else {
 392      barf("%s: Return code (%d) not ok",(site),(rc));
 393   }
 394 }