ghc/rts/RtsAPI.c

   1 /* ----------------------------------------------------------------------------
   2  * $Id: RtsAPI.c,v 1.4 1999/02/05 16:02:49 simonm 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 = &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 = &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 = &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 = &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 = &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 = &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 = &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 = &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 = &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 = &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   extern StgInfoTable W64zh_con_info;
 131
 132   StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,2));
 133   /* see mk_Int8 comment */
 134   p->header.info = &W64zh_con_info;
 135   tmp  = (unsigned long long*)&(p->payload[0]);
 136   *tmp = (StgNat64)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 = &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 = &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 = &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 = &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 == &Czh_con_info || p->header.info == &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 (p->header.info == &Izh_con_info || p->header.info == &Izh_static_info) {
 223     return (int)(p->payload[0]);
 224   } else {
 225     barf("getInt: not an Int");
 226   }
 227 }
 228
 229 unsigned int
 230 rts_getWord (HaskellObj p)
 231 {
 232   if (p->header.info == &Wzh_con_info || p->header.info == &Wzh_static_info) {
 233     return (unsigned int)(p->payload[0]);
 234   } else {
 235     barf("getWord: not a Word");
 236   }
 237 }
 238
 239 float
 240 rts_getFloat (HaskellObj p)
 241 {
 242   if (p->header.info == &Fzh_con_info || p->header.info == &Fzh_static_info) {
 243     return (float)(PK_FLT((P_)p->payload));
 244   } else {
 245     barf("getFloat: not a Float");
 246   }
 247 }
 248
 249 double
 250 rts_getDouble (HaskellObj p)
 251 {
 252   if (p->header.info == &Dzh_con_info || p->header.info == &Dzh_static_info) {
 253     return (double)(PK_DBL((P_)p->payload));
 254   } else {
 255     barf("getDouble: not a Double");
 256   }
 257 }
 258
 259 StgStablePtr
 260 rts_getStablePtr (HaskellObj p)
 261 {
 262   if (p->header.info == &StablePtr_con_info ||
 263       p->header.info == &StablePtr_static_info) {
 264     return (StgStablePtr)(p->payload[0]);
 265   } else {
 266     barf("getStablePtr: not a StablePtr");
 267   }
 268 }
 269
 270 void *
 271 rts_getAddr (HaskellObj p)
 272 {
 273   if (p->header.info == &Azh_con_info || p->header.info == &Azh_static_info) {
 274     return (void *)(p->payload[0]);
 275   } else {
 276     barf("getAddr: not an Addr");
 277   }
 278 }
 279
 280 #ifdef COMPILER /* GHC has em, Hugs doesn't */
 281 int
 282 rts_getBool (HaskellObj p)
 283 {
 284   if (p == &True_closure) {
 285     return 1;
 286   } else if (p == &False_closure) {
 287     return 0;
 288   } else {
 289     barf("getBool: not a Bool");
 290   }
 291 }
 292 #endif /* COMPILER */
 293
 294 /* ----------------------------------------------------------------------------
 295    Evaluating Haskell expressions
 296    ------------------------------------------------------------------------- */
 297 SchedulerStatus
 298 rts_eval (HaskellObj p, /*out*/HaskellObj *ret)
 299 {
 300   StgTSO *tso = createGenThread(RtsFlags.GcFlags.initialStkSize, p);
 301   return schedule(tso, ret);
 302 }
 303
 304 SchedulerStatus
 305 rts_eval_ (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
 306 {
 307   StgTSO *tso = createGenThread(stack_size, p);
 308   return schedule(tso, ret);
 309 }
 310
 311 SchedulerStatus
 312 rts_evalIO (HaskellObj p, /*out*/HaskellObj *ret)
 313 {
 314   StgTSO *tso = createIOThread(RtsFlags.GcFlags.initialStkSize, p);
 315   return schedule(tso, ret);
 316 }
 317
 318 SchedulerStatus
 319 rts_evalIO_ (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
 320 {
 321   StgTSO *tso = createIOThread(stack_size, p);
 322   return schedule(tso, ret);
 323 }
 324
 325 /* Convenience function for decoding the returned status. */
 326
 327 void rts_checkSchedStatus ( char* site, SchedulerStatus rc )
 328 {
 329   if ( rc == Success ) {
 330      return;
 331   } else {
 332      barf("%s: Return code (%d) not ok",(site),(rc));
 333   }
 334 }