ghc/rts/RtsAPI.c

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