ghc/rts/RtsAPI.c

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