ghc/rts/RtsAPI.c

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