RtsAPI.c 9.61 KB
Newer Older
1
/* ----------------------------------------------------------------------------
sof's avatar
sof committed
2
 * $Id: RtsAPI.c,v 1.6 1999/05/04 10:19:18 sof Exp $
3
4
 *
 * (c) The GHC Team, 1998-1999
5
6
7
8
9
10
11
12
13
14
15
 *
 * API for invoking Haskell functions via the RTS
 *
 * --------------------------------------------------------------------------*/

#include "Rts.h"
#include "Storage.h"
#include "RtsAPI.h"
#include "RtsFlags.h"
#include "RtsUtils.h"

sof's avatar
sof committed
16
17
18
/* This is a temporary fudge until the scheduler guarantees
   that the result returned from an evalIO() is fully evaluated.
*/
sof's avatar
sof committed
19
#define CHASE_OUT_INDIRECTIONS(p) \
sof's avatar
sof committed
20
   while ((p)->header.info == &IND_info || (p)->header.info == &IND_STATIC_info || (p)->header.info == &IND_OLDGEN_info || (p)->header.info == &IND_PERM_info || (p)->header.info == &IND_OLDGEN_PERM_info) { p=((StgInd*)p)->indirectee; }
sof's avatar
sof committed
21

22
23
24
25
26
27
28
/* ----------------------------------------------------------------------------
   Building Haskell objects from C datatypes.
   ------------------------------------------------------------------------- */
HaskellObj
rts_mkChar (char c)
{
  StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
sof's avatar
sof committed
29
  p->header.info = (const StgInfoTable*)&Czh_con_info;
30
31
32
33
34
35
36
37
  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
38
  p->header.info = (const StgInfoTable*)&Izh_con_info;
39
40
41
42
43
44
45
46
47
48
49
50
  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
51
  p->header.info = (const StgInfoTable*)&Izh_con_info;
52
53
54
55
56
57
58
59
60
61
62
63
64
  /* 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
65
  p->header.info = (const StgInfoTable*)&Izh_con_info;
66
67
68
69
70
71
72
73
74
75
  /* 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
76
  p->header.info = (const StgInfoTable*)&Izh_con_info;
77
78
79
80
81
82
83
84
85
86
  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
87
  p->header.info = (const StgInfoTable*)&I64zh_con_info;
88
89
90
91
92
93
94
95
96
  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
97
  p->header.info = (const StgInfoTable*)&Wzh_con_info;
98
99
100
101
102
103
104
105
106
  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
107
  p->header.info = (const StgInfoTable*)&Wzh_con_info;
108
109
110
111
112
113
114
115
116
  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
117
  p->header.info = (const StgInfoTable*)&Wzh_con_info;
118
119
120
121
122
123
124
125
126
  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
127
  p->header.info = (const StgInfoTable*)&Wzh_con_info;
128
129
130
131
132
133
134
135
136
137
138
  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
139
  p->header.info = (const StgInfoTable*)&W64zh_con_info;
140
  tmp  = (unsigned long long*)&(p->payload[0]);
sof's avatar
sof committed
141
  *tmp = (StgWord64)w;
142
143
144
145
146
147
148
  return p;
}

HaskellObj
rts_mkFloat (float f)
{
  StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
sof's avatar
sof committed
149
  p->header.info = (const StgInfoTable*)&Fzh_con_info;
150
151
152
153
154
155
156
157
  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
158
  p->header.info = (const StgInfoTable*)&Dzh_con_info;
159
160
161
162
163
164
165
166
  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
167
  p->header.info = (const StgInfoTable*)&StablePtr_con_info;
168
169
170
171
172
173
174
175
  p->payload[0]  = (StgClosure *)s;
  return p;
}

HaskellObj
rts_mkAddr (void *a)
{
  StgClosure *p = (StgClosure *)allocate(sizeofW(StgHeader)+1);
sof's avatar
sof committed
176
  p->header.info = (const StgInfoTable*)&Azh_con_info;
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
  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));
}

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;
}
#endif /* COMPILER */

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

char
rts_getChar (HaskellObj p)
{
sof's avatar
sof committed
217
218
219
220
  CHASE_OUT_INDIRECTIONS(p);

  if ( p->header.info == (const StgInfoTable*)&Czh_con_info || 
       p->header.info == (const StgInfoTable*)&Czh_static_info) {
221
222
223
224
225
226
227
228
229
    return (char)(StgWord)(p->payload[0]);
  } else {
    barf("getChar: not a Char");
  }
}

int
rts_getInt (HaskellObj p)
{
sof's avatar
sof committed
230
231
  CHASE_OUT_INDIRECTIONS(p);

sof's avatar
sof committed
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
  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)
{
  CHASE_OUT_INDIRECTIONS(p);

  if ( 1 ||
sof's avatar
sof committed
247
248
       p->header.info == (const StgInfoTable*)&Izh_con_info || 
       p->header.info == (const StgInfoTable*)&Izh_static_info ) {
249
250
251
252
253
254
255
256
257
    return (int)(p->payload[0]);
  } else {
    barf("getInt: not an Int");
  }
}

unsigned int
rts_getWord (HaskellObj p)
{
sof's avatar
sof committed
258
259
260
261
262
  CHASE_OUT_INDIRECTIONS(p);

  if ( 1 || /* see above comment */
       p->header.info == (const StgInfoTable*)&Wzh_con_info ||
       p->header.info == (const StgInfoTable*)&Wzh_static_info ) {
263
264
265
266
267
268
    return (unsigned int)(p->payload[0]);
  } else {
    barf("getWord: not a Word");
  }
}

sof's avatar
sof committed
269
270
271
272
273
274
275
276
277
278
279
280
281
282
unsigned int
rts_getWord32 (HaskellObj p)
{
  CHASE_OUT_INDIRECTIONS(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");
  }
}

283
284
285
float
rts_getFloat (HaskellObj p)
{
sof's avatar
sof committed
286
287
288
289
  CHASE_OUT_INDIRECTIONS(p);

  if ( p->header.info == (const StgInfoTable*)&Fzh_con_info || 
       p->header.info == (const StgInfoTable*)&Fzh_static_info ) {
290
291
292
293
294
295
296
297
298
    return (float)(PK_FLT((P_)p->payload));
  } else {
    barf("getFloat: not a Float");
  }
}

double
rts_getDouble (HaskellObj p)
{
sof's avatar
sof committed
299
300
301
302
  CHASE_OUT_INDIRECTIONS(p);

  if ( p->header.info == (const StgInfoTable*)&Dzh_con_info || 
       p->header.info == (const StgInfoTable*)&Dzh_static_info ) {
303
304
305
306
307
308
309
310
311
    return (double)(PK_DBL((P_)p->payload));
  } else {
    barf("getDouble: not a Double");
  }
}

StgStablePtr
rts_getStablePtr (HaskellObj p)
{
sof's avatar
sof committed
312
313
314
315
  CHASE_OUT_INDIRECTIONS(p);

  if ( p->header.info == (const StgInfoTable*)&StablePtr_con_info || 
       p->header.info == (const StgInfoTable*)&StablePtr_static_info ) {
316
317
318
319
320
321
322
323
324
    return (StgStablePtr)(p->payload[0]);
  } else {
    barf("getStablePtr: not a StablePtr");
  }
}

void *
rts_getAddr (HaskellObj p)
{
sof's avatar
sof committed
325
326
327
328
329
  CHASE_OUT_INDIRECTIONS(p);

  if ( p->header.info == (const StgInfoTable*)&Azh_con_info || 
       p->header.info == (const StgInfoTable*)&Azh_static_info ) {
  
330
331
332
333
334
335
336
337
338
339
    return (void *)(p->payload[0]);
  } else {
    barf("getAddr: not an Addr");
  }
}

#ifdef COMPILER /* GHC has em, Hugs doesn't */
int
rts_getBool (HaskellObj p)
{
sof's avatar
sof committed
340
341
  CHASE_OUT_INDIRECTIONS(p);

342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
  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);
  return schedule(tso, ret);
}

SchedulerStatus
rts_eval_ (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
{
  StgTSO *tso = createGenThread(stack_size, p);
  return schedule(tso, ret);
}

SchedulerStatus
rts_evalIO (HaskellObj p, /*out*/HaskellObj *ret)
{
  StgTSO *tso = createIOThread(RtsFlags.GcFlags.initialStkSize, p);
  return schedule(tso, ret);
}

SchedulerStatus
rts_evalIO_ (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
{
  StgTSO *tso = createIOThread(stack_size, p);
  return schedule(tso, ret);
}

/* 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));
  }
}