RtsAPI.c 10.9 KB
Newer Older
1
/* ----------------------------------------------------------------------------
2
 * $Id: RtsAPI.c,v 1.30 2001/10/23 11:30:07 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
  }
}
#endif /* COMPILER */

/* ----------------------------------------------------------------------------
   Evaluating Haskell expressions
   ------------------------------------------------------------------------- */
SchedulerStatus
rts_eval (HaskellObj p, /*out*/HaskellObj *ret)
{
400
401
402
403
404
    StgTSO *tso;

    tso = createGenThread(RtsFlags.GcFlags.initialStkSize, p);
    scheduleThread(tso);
    return waitThread(tso, ret);
405
406
407
408
409
}

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

sof's avatar
sof committed
417
418
419
420
/*
 * rts_evalIO() evaluates a value of the form (IO a), forcing the action's
 * result to WHNF before returning.
 */
421
422
423
SchedulerStatus
rts_evalIO (HaskellObj p, /*out*/HaskellObj *ret)
{
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
    StgTSO* tso; 
    
    tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
    scheduleThread(tso);
    return waitThread(tso, ret);
}

/*
 * rts_evalStableIO() is suitable for calling from Haskell.  It
 * evaluates a value of the form (StablePtr (IO a)), forcing the
 * action's result to WHNF before returning.  The result is returned
 * in a StablePtr.
 */
SchedulerStatus
rts_evalStableIO (HsStablePtr s, /*out*/HsStablePtr *ret)
{
    StgTSO* tso;
    StgClosure *p, *r;
    SchedulerStatus stat;
    
    p = (StgClosure *)deRefStablePtr(s);
    tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
    scheduleThread(tso);
    stat = waitThread(tso, &r);

    if (stat == Success) {
	ASSERT(r != NULL);
	*ret = getStablePtr((StgPtr)r);
    }

    return stat;
455
456
}

sof's avatar
sof committed
457
458
459
/*
 * Like rts_evalIO(), but doesn't force the action's result.
 */
460
SchedulerStatus
sof's avatar
sof committed
461
rts_evalLazyIO (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
462
{
463
464
465
466
467
    StgTSO *tso;

    tso = createIOThread(stack_size, p);
    scheduleThread(tso);
    return waitThread(tso, ret);
468
469
470
471
}

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

472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
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));	
    }
487
}