RtsAPI.c 10.2 KB
Newer Older
1
/* ----------------------------------------------------------------------------
2
 * $Id: RtsAPI.c,v 1.29 2001/08/29 11:20:40 simonmar Exp $
3
 *
4
 * (c) The GHC Team, 1998-2001
5
6
7
8
9
 *
 * API for invoking Haskell functions via the RTS
 *
 * --------------------------------------------------------------------------*/

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

/* ----------------------------------------------------------------------------
   Building Haskell objects from C datatypes.
   ------------------------------------------------------------------------- */
HaskellObj
23
rts_mkChar (HsChar c)
24
25
{
  StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
26
  SET_HDR(p, Czh_con_info, CCS_SYSTEM);
27
  p->payload[0]  = (StgClosure *)(StgChar)c;
28
29
30
31
  return p;
}

HaskellObj
32
rts_mkInt (HsInt i)
33
34
{
  StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
35
  SET_HDR(p, Izh_con_info, CCS_SYSTEM);
36
37
38
39
40
  p->payload[0]  = (StgClosure *)(StgInt)i;
  return p;
}

HaskellObj
41
rts_mkInt8 (HsInt8 i)
42
43
{
  StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
44
  SET_HDR(p, I8zh_con_info, CCS_SYSTEM);
45
46
47
48
49
50
  /* Make sure we mask out the bits above the lowest 8 */
  p->payload[0]  = (StgClosure *)(StgInt)((unsigned)i & 0xff);
  return p;
}

HaskellObj
51
rts_mkInt16 (HsInt16 i)
52
53
{
  StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
54
  SET_HDR(p, I16zh_con_info, CCS_SYSTEM);
55
56
57
58
59
60
  /* Make sure we mask out the relevant bits */
  p->payload[0]  = (StgClosure *)(StgInt)((unsigned)i & 0xffff);
  return p;
}

HaskellObj
61
rts_mkInt32 (HsInt32 i)
62
63
{
  StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
64
65
  SET_HDR(p, I32zh_con_info, CCS_SYSTEM);
  p->payload[0]  = (StgClosure *)(StgInt)((unsigned)i & 0xffffffff);
66
67
68
69
  return p;
}

HaskellObj
70
rts_mkInt64 (HsInt64 i)
71
72
73
{
  long long *tmp;
  StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,2));
74
  SET_HDR(p, I64zh_con_info, CCS_SYSTEM);
75
76
77
78
79
80
  tmp  = (long long*)&(p->payload[0]);
  *tmp = (StgInt64)i;
  return p;
}

HaskellObj
81
rts_mkWord (HsWord i)
82
83
{
  StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
84
  SET_HDR(p, Wzh_con_info, CCS_SYSTEM);
85
86
87
88
89
  p->payload[0]  = (StgClosure *)(StgWord)i;
  return p;
}

HaskellObj
90
rts_mkWord8 (HsWord8 w)
91
92
93
{
  /* see rts_mkInt* comments */
  StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
94
  SET_HDR(p, W8zh_con_info, CCS_SYSTEM);
95
96
97
98
99
  p->payload[0]  = (StgClosure *)(StgWord)(w & 0xff);
  return p;
}

HaskellObj
100
rts_mkWord16 (HsWord16 w)
101
102
103
{
  /* see rts_mkInt* comments */
  StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
104
  SET_HDR(p, W16zh_con_info, CCS_SYSTEM);
105
106
107
108
109
  p->payload[0]  = (StgClosure *)(StgWord)(w & 0xffff);
  return p;
}

HaskellObj
110
rts_mkWord32 (HsWord32 w)
111
112
113
{
  /* see rts_mkInt* comments */
  StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
114
115
  SET_HDR(p, W32zh_con_info, CCS_SYSTEM);
  p->payload[0]  = (StgClosure *)(StgWord)(w & 0xffffffff);
116
117
118
119
  return p;
}

HaskellObj
120
rts_mkWord64 (HsWord64 w)
121
122
123
124
125
{
  unsigned long long *tmp;

  StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,2));
  /* see mk_Int8 comment */
126
  SET_HDR(p, W64zh_con_info, CCS_SYSTEM);
127
  tmp  = (unsigned long long*)&(p->payload[0]);
sof's avatar
sof committed
128
  *tmp = (StgWord64)w;
129
130
131
132
  return p;
}

HaskellObj
133
rts_mkFloat (HsFloat f)
134
135
{
  StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
136
  SET_HDR(p, Fzh_con_info, CCS_SYSTEM);
137
138
139
140
141
  ASSIGN_FLT((P_)p->payload, (StgFloat)f);
  return p;
}

HaskellObj
142
rts_mkDouble (HsDouble d)
143
144
{
  StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,sizeofW(StgDouble)));
145
  SET_HDR(p, Dzh_con_info, CCS_SYSTEM);
146
147
148
149
150
  ASSIGN_DBL((P_)p->payload, (StgDouble)d);
  return p;
}

HaskellObj
151
rts_mkStablePtr (HsStablePtr s)
152
153
{
  StgClosure *p = (StgClosure *)allocate(sizeofW(StgHeader)+1);
154
  SET_HDR(p, StablePtr_con_info, CCS_SYSTEM);
155
156
157
158
159
  p->payload[0]  = (StgClosure *)s;
  return p;
}

HaskellObj
160
rts_mkPtr (HsPtr a)
161
162
{
  StgClosure *p = (StgClosure *)allocate(sizeofW(StgHeader)+1);
163
  SET_HDR(p, Ptr_con_info, CCS_SYSTEM);
164
165
166
167
168
169
  p->payload[0]  = (StgClosure *)a;
  return p;
}

#ifdef COMPILER /* GHC has em, Hugs doesn't */
HaskellObj
170
rts_mkBool (HsBool b)
171
172
{
  if (b) {
173
    return (StgClosure *)True_closure;
174
  } else {
175
    return (StgClosure *)False_closure;
176
177
178
179
180
181
  }
}

HaskellObj
rts_mkString (char *s)
{
182
  return rts_apply((StgClosure *)unpackCString_closure, rts_mkPtr(s));
183
}
184
#endif /* COMPILER */
185
186
187
188
189

HaskellObj
rts_apply (HaskellObj f, HaskellObj arg)
{
  StgAP_UPD *ap = (StgAP_UPD *)allocate(AP_sizeW(1));
190
  SET_HDR(ap, &stg_AP_UPD_info, CCS_SYSTEM);
191
192
  ap->n_args = 1;
  ap->fun    = f;
193
  ap->payload[0] = arg;
194
195
196
197
198
199
200
  return (StgClosure *)ap;
}

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

201
HsChar
202
203
rts_getChar (HaskellObj p)
{
204
205
  if ( p->header.info == Czh_con_info || 
       p->header.info == Czh_static_info) {
206
    return (StgChar)(StgWord)(p->payload[0]);
207
  } else {
sof's avatar
sof committed
208
    barf("rts_getChar: not a Char");
209
210
211
  }
}

212
HsInt
213
214
rts_getInt (HaskellObj p)
{
sof's avatar
sof committed
215
  if ( 1 ||
216
217
       p->header.info == Izh_con_info || 
       p->header.info == Izh_static_info ) {
sof's avatar
sof committed
218
    return (HsInt)(p->payload[0]);
sof's avatar
sof committed
219
  } else {
sof's avatar
sof committed
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
    barf("rts_getInt: not an Int");
  }
}

HsInt8
rts_getInt8 (HaskellObj p)
{
  if ( 1 ||
       p->header.info == I8zh_con_info || 
       p->header.info == I8zh_static_info ) {
    return (HsInt8)(HsInt)(p->payload[0]);
  } else {
    barf("rts_getInt8: not an Int8");
  }
}

HsInt16
rts_getInt16 (HaskellObj p)
{
  if ( 1 ||
       p->header.info == I16zh_con_info || 
       p->header.info == I16zh_static_info ) {
    return (HsInt16)(HsInt)(p->payload[0]);
  } else {
    barf("rts_getInt16: not an Int16");
sof's avatar
sof committed
245
246
247
  }
}

248
HsInt32
sof's avatar
sof committed
249
250
251
rts_getInt32 (HaskellObj p)
{
  if ( 1 ||
252
253
       p->header.info == I32zh_con_info || 
       p->header.info == I32zh_static_info ) {
sof's avatar
sof committed
254
    return (HsInt32)(p->payload[0]);
255
  } else {
sof's avatar
sof committed
256
    barf("rts_getInt32: not an Int32");
257
258
259
  }
}

sof's avatar
sof committed
260
261
262
263
264
265
266
267
268
269
270
271
272
HsInt64
rts_getInt64 (HaskellObj p)
{
  HsInt64* tmp;
  if ( 1 ||
       p->header.info == I64zh_con_info || 
       p->header.info == I64zh_static_info ) {
    tmp = (HsInt64*)&(p->payload[0]);
    return *tmp;
  } else {
    barf("rts_getInt64: not an Int64");
  }
}
273
HsWord
274
275
rts_getWord (HaskellObj p)
{
sof's avatar
sof committed
276
  if ( 1 || /* see above comment */
277
278
       p->header.info == Wzh_con_info ||
       p->header.info == Wzh_static_info ) {
sof's avatar
sof committed
279
    return (HsWord)(p->payload[0]);
280
  } else {
sof's avatar
sof committed
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
    barf("rts_getWord: not a Word");
  }
}

HsWord8
rts_getWord8 (HaskellObj p)
{
  if ( 1 || /* see above comment */
       p->header.info == W8zh_con_info ||
       p->header.info == W8zh_static_info ) {
    return (HsWord8)(HsWord)(p->payload[0]);
  } else {
    barf("rts_getWord8: not a Word8");
  }
}

HsWord16
rts_getWord16 (HaskellObj p)
{
  if ( 1 || /* see above comment */
       p->header.info == W16zh_con_info ||
       p->header.info == W16zh_static_info ) {
    return (HsWord16)(HsWord)(p->payload[0]);
  } else {
    barf("rts_getWord16: not a Word16");
306
307
308
  }
}

309
HsWord32
sof's avatar
sof committed
310
311
312
rts_getWord32 (HaskellObj p)
{
  if ( 1 || /* see above comment */
313
314
       p->header.info == W32zh_con_info ||
       p->header.info == W32zh_static_info ) {
sof's avatar
sof committed
315
316
    return (unsigned int)(p->payload[0]);
  } else {
sof's avatar
sof committed
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
    barf("rts_getWord: not a Word");
  }
}


HsWord64
rts_getWord64 (HaskellObj p)
{
  HsWord64* tmp;
  if ( 1 || /* see above comment */
       p->header.info == W64zh_con_info ||
       p->header.info == W64zh_static_info ) {
    tmp = (HsWord64*)&(p->payload[0]);
    return *tmp;
  } else {
    barf("rts_getWord64: not a Word64");
sof's avatar
sof committed
333
334
335
  }
}

336
HsFloat
337
338
rts_getFloat (HaskellObj p)
{
339
340
  if ( p->header.info == Fzh_con_info || 
       p->header.info == Fzh_static_info ) {
341
342
    return (float)(PK_FLT((P_)p->payload));
  } else {
sof's avatar
sof committed
343
    barf("rts_getFloat: not a Float");
344
345
346
  }
}

347
HsDouble
348
349
rts_getDouble (HaskellObj p)
{
350
351
  if ( p->header.info == Dzh_con_info || 
       p->header.info == Dzh_static_info ) {
352
353
    return (double)(PK_DBL((P_)p->payload));
  } else {
sof's avatar
sof committed
354
    barf("rts_getDouble: not a Double");
355
356
357
  }
}

358
HsStablePtr
359
360
rts_getStablePtr (HaskellObj p)
{
361
362
  if ( p->header.info == StablePtr_con_info || 
       p->header.info == StablePtr_static_info ) {
363
364
    return (StgStablePtr)(p->payload[0]);
  } else {
sof's avatar
sof committed
365
    barf("rts_getStablePtr: not a StablePtr");
366
367
368
  }
}

369
370
HsPtr
rts_getPtr (HaskellObj p)
371
{
372
373
  if ( p->header.info == Ptr_con_info || 
       p->header.info == Ptr_static_info ) {
374
375
    return (void *)(p->payload[0]);
  } else {
sof's avatar
sof committed
376
    barf("rts_getPtr: not an Ptr");
377
378
379
380
  }
}

#ifdef COMPILER /* GHC has em, Hugs doesn't */
381
HsBool
382
383
rts_getBool (HaskellObj p)
{
384
  if (p == True_closure) {
385
    return 1;
386
  } else if (p == False_closure) {
387
    return 0;
388
  } else {
sof's avatar
sof committed
389
    barf("rts_getBool: not a Bool");
390
391
392
393
394
395
396
397
398
399
400
  }
}
#endif /* COMPILER */

/* ----------------------------------------------------------------------------
   Evaluating Haskell expressions
   ------------------------------------------------------------------------- */
SchedulerStatus
rts_eval (HaskellObj p, /*out*/HaskellObj *ret)
{
  StgTSO *tso = createGenThread(RtsFlags.GcFlags.initialStkSize, p);
401
402
  scheduleThread(tso);
  return waitThread(tso, ret);
403
404
405
406
407
408
}

SchedulerStatus
rts_eval_ (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
{
  StgTSO *tso = createGenThread(stack_size, p);
409
410
  scheduleThread(tso);
  return waitThread(tso, ret);
411
412
}

sof's avatar
sof committed
413
414
415
416
/*
 * rts_evalIO() evaluates a value of the form (IO a), forcing the action's
 * result to WHNF before returning.
 */
417
418
419
SchedulerStatus
rts_evalIO (HaskellObj p, /*out*/HaskellObj *ret)
{
sof's avatar
sof committed
420
  StgTSO* tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
421
422
  scheduleThread(tso);
  return waitThread(tso, ret);
423
424
}

sof's avatar
sof committed
425
426
427
/*
 * Like rts_evalIO(), but doesn't force the action's result.
 */
428
SchedulerStatus
sof's avatar
sof committed
429
rts_evalLazyIO (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
430
431
{
  StgTSO *tso = createIOThread(stack_size, p);
432
433
  scheduleThread(tso);
  return waitThread(tso, ret);
434
435
436
437
}

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

438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
void
rts_checkSchedStatus ( char* site, SchedulerStatus rc )
{
    switch (rc) {
    case Success:
	return;
    case Killed:
	barf("%s: uncaught exception",site);
    case Interrupted:
	barf("%s: interrupted", site);
    case Deadlock:
	barf("%s: no threads to run:  infinite loop or deadlock?", site);
    default:
	barf("%s: Return code (%d) not ok",(site),(rc));	
    }
453
}