RtsAPI.c 9.27 KB
Newer Older
1
/* ----------------------------------------------------------------------------
2
 * $Id: RtsAPI.c,v 1.11 2000/03/13 10:53:56 simonmar Exp $
3 4
 *
 * (c) The GHC Team, 1998-1999
5 6 7 8 9 10 11 12
 *
 * API for invoking Haskell functions via the RTS
 *
 * --------------------------------------------------------------------------*/

#include "Rts.h"
#include "Storage.h"
#include "RtsAPI.h"
sof's avatar
sof committed
13
#include "SchedAPI.h"
14 15
#include "RtsFlags.h"
#include "RtsUtils.h"
16
#include "Prelude.h"
17 18 19 20 21 22 23 24

/* ----------------------------------------------------------------------------
   Building Haskell objects from C datatypes.
   ------------------------------------------------------------------------- */
HaskellObj
rts_mkChar (char c)
{
  StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
sof's avatar
sof committed
25
  p->header.info = (const StgInfoTable*)&Czh_con_info;
26 27 28 29 30 31 32 33
  p->payload[0]  = (StgClosure *)((StgInt)c);
  return p;
}

HaskellObj
rts_mkInt (int i)
{
  StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
sof's avatar
sof committed
34
  p->header.info = (const StgInfoTable*)&Izh_con_info;
35 36 37 38 39 40 41 42 43 44 45 46
  p->payload[0]  = (StgClosure *)(StgInt)i;
  return p;
}

HaskellObj
rts_mkInt8 (int i)
{
  StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
  /* This is a 'cheat', using the static info table for Ints,
     instead of the one for Int8, but the types have identical
     representation.
  */
sof's avatar
sof committed
47
  p->header.info = (const StgInfoTable*)&Izh_con_info;
48 49 50 51 52 53 54 55 56 57 58 59 60
  /* Make sure we mask out the bits above the lowest 8 */
  p->payload[0]  = (StgClosure *)(StgInt)((unsigned)i & 0xff);
  return p;
}

HaskellObj
rts_mkInt16 (int i)
{
  StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
  /* This is a 'cheat', using the static info table for Ints,
     instead of the one for Int8, but the types have identical
     representation.
  */
sof's avatar
sof committed
61
  p->header.info = (const StgInfoTable*)&Izh_con_info;
62 63 64 65 66 67 68 69 70 71
  /* Make sure we mask out the relevant bits */
  p->payload[0]  = (StgClosure *)(StgInt)((unsigned)i & 0xffff);
  return p;
}

HaskellObj
rts_mkInt32 (int i)
{
  StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
  /* see mk_Int8 comment */
sof's avatar
sof committed
72
  p->header.info = (const StgInfoTable*)&Izh_con_info;
73 74 75 76 77 78 79 80 81 82
  p->payload[0]  = (StgClosure *)(StgInt)i;
  return p;
}

HaskellObj
rts_mkInt64 (long long int i)
{
  long long *tmp;
  StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,2));
  /* see mk_Int8 comment */
sof's avatar
sof committed
83
  p->header.info = (const StgInfoTable*)&I64zh_con_info;
84 85 86 87 88 89 90 91 92
  tmp  = (long long*)&(p->payload[0]);
  *tmp = (StgInt64)i;
  return p;
}

HaskellObj
rts_mkWord (unsigned int i)
{
  StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
sof's avatar
sof committed
93
  p->header.info = (const StgInfoTable*)&Wzh_con_info;
94 95 96 97 98 99 100 101 102
  p->payload[0]  = (StgClosure *)(StgWord)i;
  return p;
}

HaskellObj
rts_mkWord8 (unsigned int w)
{
  /* see rts_mkInt* comments */
  StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
sof's avatar
sof committed
103
  p->header.info = (const StgInfoTable*)&Wzh_con_info;
104 105 106 107 108 109 110 111 112
  p->payload[0]  = (StgClosure *)(StgWord)(w & 0xff);
  return p;
}

HaskellObj
rts_mkWord16 (unsigned int w)
{
  /* see rts_mkInt* comments */
  StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
sof's avatar
sof committed
113
  p->header.info = (const StgInfoTable*)&Wzh_con_info;
114 115 116 117 118 119 120 121 122
  p->payload[0]  = (StgClosure *)(StgWord)(w & 0xffff);
  return p;
}

HaskellObj
rts_mkWord32 (unsigned int w)
{
  /* see rts_mkInt* comments */
  StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
sof's avatar
sof committed
123
  p->header.info = (const StgInfoTable*)&Wzh_con_info;
124 125 126 127 128 129 130 131 132 133 134
  p->payload[0]  = (StgClosure *)(StgWord)w;
  return p;
}

HaskellObj
rts_mkWord64 (unsigned long long w)
{
  unsigned long long *tmp;

  StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,2));
  /* see mk_Int8 comment */
sof's avatar
sof committed
135
  p->header.info = (const StgInfoTable*)&W64zh_con_info;
136
  tmp  = (unsigned long long*)&(p->payload[0]);
sof's avatar
sof committed
137
  *tmp = (StgWord64)w;
138 139 140 141 142 143 144
  return p;
}

HaskellObj
rts_mkFloat (float f)
{
  StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
sof's avatar
sof committed
145
  p->header.info = (const StgInfoTable*)&Fzh_con_info;
146 147 148 149 150 151 152 153
  ASSIGN_FLT((P_)p->payload, (StgFloat)f);
  return p;
}

HaskellObj
rts_mkDouble (double d)
{
  StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,sizeofW(StgDouble)));
sof's avatar
sof committed
154
  p->header.info = (const StgInfoTable*)&Dzh_con_info;
155 156 157 158 159 160 161 162
  ASSIGN_DBL((P_)p->payload, (StgDouble)d);
  return p;
}

HaskellObj
rts_mkStablePtr (StgStablePtr s)
{
  StgClosure *p = (StgClosure *)allocate(sizeofW(StgHeader)+1);
sof's avatar
sof committed
163
  p->header.info = (const StgInfoTable*)&StablePtr_con_info;
164 165 166 167 168 169 170 171
  p->payload[0]  = (StgClosure *)s;
  return p;
}

HaskellObj
rts_mkAddr (void *a)
{
  StgClosure *p = (StgClosure *)allocate(sizeofW(StgHeader)+1);
sof's avatar
sof committed
172
  p->header.info = (const StgInfoTable*)&Azh_con_info;
173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192
  p->payload[0]  = (StgClosure *)a;
  return p;
}

#ifdef COMPILER /* GHC has em, Hugs doesn't */
HaskellObj
rts_mkBool (int b)
{
  if (b) {
    return (StgClosure *)&True_closure;
  } else {
    return (StgClosure *)&False_closure;
  }
}

HaskellObj
rts_mkString (char *s)
{
  return rts_apply((StgClosure *)&unpackCString_closure, rts_mkAddr(s));
}
193
#endif /* COMPILER */
194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212

HaskellObj
rts_apply (HaskellObj f, HaskellObj arg)
{
  StgAP_UPD *ap = (StgAP_UPD *)allocate(AP_sizeW(1));
  ap->header.info = &AP_UPD_info;
  ap->n_args = 1;
  ap->fun    = f;
  ap->payload[0] = (P_)arg;
  return (StgClosure *)ap;
}

/* ----------------------------------------------------------------------------
   Deconstructing Haskell objects
   ------------------------------------------------------------------------- */

char
rts_getChar (HaskellObj p)
{
sof's avatar
sof committed
213 214
  if ( p->header.info == (const StgInfoTable*)&Czh_con_info || 
       p->header.info == (const StgInfoTable*)&Czh_static_info) {
215 216 217 218 219 220 221 222 223
    return (char)(StgWord)(p->payload[0]);
  } else {
    barf("getChar: not a Char");
  }
}

int
rts_getInt (HaskellObj p)
{
sof's avatar
sof committed
224 225 226 227 228 229 230 231 232 233 234 235 236
  if ( 1 ||
       p->header.info == (const StgInfoTable*)&Izh_con_info || 
       p->header.info == (const StgInfoTable*)&Izh_static_info ) {
    return (int)(p->payload[0]);
  } else {
    barf("getInt: not an Int");
  }
}

int
rts_getInt32 (HaskellObj p)
{
  if ( 1 ||
sof's avatar
sof committed
237 238
       p->header.info == (const StgInfoTable*)&Izh_con_info || 
       p->header.info == (const StgInfoTable*)&Izh_static_info ) {
239 240 241 242 243 244 245 246 247
    return (int)(p->payload[0]);
  } else {
    barf("getInt: not an Int");
  }
}

unsigned int
rts_getWord (HaskellObj p)
{
sof's avatar
sof committed
248 249 250
  if ( 1 || /* see above comment */
       p->header.info == (const StgInfoTable*)&Wzh_con_info ||
       p->header.info == (const StgInfoTable*)&Wzh_static_info ) {
251 252 253 254 255 256
    return (unsigned int)(p->payload[0]);
  } else {
    barf("getWord: not a Word");
  }
}

sof's avatar
sof committed
257 258 259 260 261 262 263 264 265 266 267 268
unsigned int
rts_getWord32 (HaskellObj p)
{
  if ( 1 || /* see above comment */
       p->header.info == (const StgInfoTable*)&Wzh_con_info ||
       p->header.info == (const StgInfoTable*)&Wzh_static_info ) {
    return (unsigned int)(p->payload[0]);
  } else {
    barf("getWord: not a Word");
  }
}

269 270 271
float
rts_getFloat (HaskellObj p)
{
sof's avatar
sof committed
272 273
  if ( p->header.info == (const StgInfoTable*)&Fzh_con_info || 
       p->header.info == (const StgInfoTable*)&Fzh_static_info ) {
274 275 276 277 278 279 280 281 282
    return (float)(PK_FLT((P_)p->payload));
  } else {
    barf("getFloat: not a Float");
  }
}

double
rts_getDouble (HaskellObj p)
{
sof's avatar
sof committed
283 284
  if ( p->header.info == (const StgInfoTable*)&Dzh_con_info || 
       p->header.info == (const StgInfoTable*)&Dzh_static_info ) {
285 286 287 288 289 290 291 292 293
    return (double)(PK_DBL((P_)p->payload));
  } else {
    barf("getDouble: not a Double");
  }
}

StgStablePtr
rts_getStablePtr (HaskellObj p)
{
sof's avatar
sof committed
294 295
  if ( p->header.info == (const StgInfoTable*)&StablePtr_con_info || 
       p->header.info == (const StgInfoTable*)&StablePtr_static_info ) {
296 297 298 299 300 301 302 303 304
    return (StgStablePtr)(p->payload[0]);
  } else {
    barf("getStablePtr: not a StablePtr");
  }
}

void *
rts_getAddr (HaskellObj p)
{
sof's avatar
sof committed
305 306 307
  if ( p->header.info == (const StgInfoTable*)&Azh_con_info || 
       p->header.info == (const StgInfoTable*)&Azh_static_info ) {
  
308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334
    return (void *)(p->payload[0]);
  } else {
    barf("getAddr: not an Addr");
  }
}

#ifdef COMPILER /* GHC has em, Hugs doesn't */
int
rts_getBool (HaskellObj p)
{
  if (p == &True_closure) {
    return 1;
  } else if (p == &False_closure) {
    return 0;
  } else {
    barf("getBool: not a Bool");
  }
}
#endif /* COMPILER */

/* ----------------------------------------------------------------------------
   Evaluating Haskell expressions
   ------------------------------------------------------------------------- */
SchedulerStatus
rts_eval (HaskellObj p, /*out*/HaskellObj *ret)
{
  StgTSO *tso = createGenThread(RtsFlags.GcFlags.initialStkSize, p);
335 336
  scheduleThread(tso);
  return waitThread(tso, ret);
337 338 339 340 341 342
}

SchedulerStatus
rts_eval_ (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
{
  StgTSO *tso = createGenThread(stack_size, p);
343 344
  scheduleThread(tso);
  return waitThread(tso, ret);
345 346
}

sof's avatar
sof committed
347 348 349 350
/*
 * rts_evalIO() evaluates a value of the form (IO a), forcing the action's
 * result to WHNF before returning.
 */
351 352 353
SchedulerStatus
rts_evalIO (HaskellObj p, /*out*/HaskellObj *ret)
{
sof's avatar
sof committed
354
  StgTSO* tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
355 356
  scheduleThread(tso);
  return waitThread(tso, ret);
357 358
}

sof's avatar
sof committed
359 360 361
/*
 * Like rts_evalIO(), but doesn't force the action's result.
 */
362
SchedulerStatus
sof's avatar
sof committed
363
rts_evalLazyIO (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
364 365
{
  StgTSO *tso = createIOThread(stack_size, p);
366 367
  scheduleThread(tso);
  return waitThread(tso, ret);
368 369 370 371 372 373 374 375 376 377 378 379
}

/* Convenience function for decoding the returned status. */

void rts_checkSchedStatus ( char* site, SchedulerStatus rc )
{
  if ( rc == Success ) {
     return;
  } else {
     barf("%s: Return code (%d) not ok",(site),(rc));
  }
}