ghc/rts/RtsAPI.c

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