RtsAPI.c 8.74 KB
Newer Older
1
/* ----------------------------------------------------------------------------
2
 * $Id: RtsAPI.c,v 1.25 2001/02/08 14:36:21 simonmar Exp $
3
 *
4
 * (c) The GHC Team, 1998-2001
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

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

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

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

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

HaskellObj
60
rts_mkInt32 (HsInt32 i)
61
62
{
  StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
63
  p->header.info = I32zh_con_info;
64
65
66
67
68
  p->payload[0]  = (StgClosure *)(StgInt)i;
  return p;
}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

211
HsInt
212
213
rts_getInt (HaskellObj p)
{
sof's avatar
sof committed
214
  if ( 1 ||
215
216
       p->header.info == Izh_con_info || 
       p->header.info == Izh_static_info ) {
sof's avatar
sof committed
217
218
219
220
221
222
    return (int)(p->payload[0]);
  } else {
    barf("getInt: not an Int");
  }
}

223
HsInt32
sof's avatar
sof committed
224
225
226
rts_getInt32 (HaskellObj p)
{
  if ( 1 ||
227
228
       p->header.info == I32zh_con_info || 
       p->header.info == I32zh_static_info ) {
229
230
231
232
233
234
    return (int)(p->payload[0]);
  } else {
    barf("getInt: not an Int");
  }
}

235
HsWord
236
237
rts_getWord (HaskellObj p)
{
sof's avatar
sof committed
238
  if ( 1 || /* see above comment */
239
240
       p->header.info == Wzh_con_info ||
       p->header.info == Wzh_static_info ) {
241
242
243
244
245
246
    return (unsigned int)(p->payload[0]);
  } else {
    barf("getWord: not a Word");
  }
}

247
HsWord32
sof's avatar
sof committed
248
249
250
rts_getWord32 (HaskellObj p)
{
  if ( 1 || /* see above comment */
251
252
       p->header.info == W32zh_con_info ||
       p->header.info == W32zh_static_info ) {
sof's avatar
sof committed
253
254
255
256
257
258
    return (unsigned int)(p->payload[0]);
  } else {
    barf("getWord: not a Word");
  }
}

259
HsFloat
260
261
rts_getFloat (HaskellObj p)
{
262
263
  if ( p->header.info == Fzh_con_info || 
       p->header.info == Fzh_static_info ) {
264
265
266
267
268
269
    return (float)(PK_FLT((P_)p->payload));
  } else {
    barf("getFloat: not a Float");
  }
}

270
HsDouble
271
272
rts_getDouble (HaskellObj p)
{
273
274
  if ( p->header.info == Dzh_con_info || 
       p->header.info == Dzh_static_info ) {
275
276
277
278
279
280
    return (double)(PK_DBL((P_)p->payload));
  } else {
    barf("getDouble: not a Double");
  }
}

281
HsStablePtr
282
283
rts_getStablePtr (HaskellObj p)
{
284
285
  if ( p->header.info == StablePtr_con_info || 
       p->header.info == StablePtr_static_info ) {
286
287
288
289
290
291
    return (StgStablePtr)(p->payload[0]);
  } else {
    barf("getStablePtr: not a StablePtr");
  }
}

292
293
HsPtr
rts_getPtr (HaskellObj p)
294
{
295
296
  if ( p->header.info == Ptr_con_info || 
       p->header.info == Ptr_static_info ) {
297
298
    return (void *)(p->payload[0]);
  } else {
299
    barf("getPtr: not an Ptr");
300
301
302
303
  }
}

#ifdef COMPILER /* GHC has em, Hugs doesn't */
304
HsBool
305
306
rts_getBool (HaskellObj p)
{
307
  if (p == True_closure) {
308
    return 1;
309
  } else if (p == False_closure) {
310
    return 0;
311
312
313
314
315
316
317
318
319
320
321
322
323
  } 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);
324
325
  scheduleThread(tso);
  return waitThread(tso, ret);
326
327
328
329
330
331
}

SchedulerStatus
rts_eval_ (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
{
  StgTSO *tso = createGenThread(stack_size, p);
332
333
  scheduleThread(tso);
  return waitThread(tso, ret);
334
335
}

sof's avatar
sof committed
336
337
338
339
/*
 * rts_evalIO() evaluates a value of the form (IO a), forcing the action's
 * result to WHNF before returning.
 */
340
341
342
SchedulerStatus
rts_evalIO (HaskellObj p, /*out*/HaskellObj *ret)
{
sof's avatar
sof committed
343
  StgTSO* tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
344
345
  scheduleThread(tso);
  return waitThread(tso, ret);
346
347
}

sof's avatar
sof committed
348
349
350
/*
 * Like rts_evalIO(), but doesn't force the action's result.
 */
351
SchedulerStatus
sof's avatar
sof committed
352
rts_evalLazyIO (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
353
354
{
  StgTSO *tso = createIOThread(stack_size, p);
355
356
  scheduleThread(tso);
  return waitThread(tso, ret);
357
358
}

359
#if defined(PAR)
360
361
362
363
364
365
366
367
368
369
370
371
372
373
/*
  Needed in the parallel world for non-Main PEs, which do not get a piece
  of work to start with --- they have to humbly ask for it
*/

SchedulerStatus
rts_evalNothing(unsigned int stack_size)
{
  /* ToDo: propagate real SchedulerStatus back to caller */
  scheduleThread(END_TSO_QUEUE);
  return Success;
}
#endif

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

376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
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));	
    }
391
}