ghc/rts/RtsAPI.c

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