RtsAPI.c 7.68 KB
Newer Older
1
/* ----------------------------------------------------------------------------
2
 * $Id: RtsAPI.c,v 1.3 1999/01/27 14:51:21 simonpj Exp $
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
 *
 * API for invoking Haskell functions via the RTS
 *
 * --------------------------------------------------------------------------*/

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

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

HaskellObj
rts_mkInt (int i)
{
  StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
30
  p->header.info = &Izh_con_info;
31
32
33
34
35
36
37
38
39
40
41
42
  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.
  */
43
  p->header.info = &Izh_con_info;
44
45
46
47
48
49
50
51
52
53
54
55
56
  /* 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.
  */
57
  p->header.info = &Izh_con_info;
58
59
60
61
62
63
64
65
66
67
  /* 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 */
68
  p->header.info = &Izh_con_info;
69
70
71
72
73
74
75
76
77
78
  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 */
79
  p->header.info = &I64zh_con_info;
80
81
82
83
84
85
86
87
88
  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));
89
  p->header.info = &Wzh_con_info;
90
91
92
93
94
95
96
97
98
  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));
99
  p->header.info = &Wzh_con_info;
100
101
102
103
104
105
106
107
108
  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));
109
  p->header.info = &Wzh_con_info;
110
111
112
113
114
115
116
117
118
  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));
119
  p->header.info = &Wzh_con_info;
120
121
122
123
124
125
126
127
  p->payload[0]  = (StgClosure *)(StgWord)w;
  return p;
}

HaskellObj
rts_mkWord64 (unsigned long long w)
{
  unsigned long long *tmp;
128
  extern StgInfoTable W64zh_con_info;
129
130
131

  StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,2));
  /* see mk_Int8 comment */
132
  p->header.info = &W64zh_con_info;
133
134
135
136
137
138
139
140
141
  tmp  = (unsigned long long*)&(p->payload[0]);
  *tmp = (StgNat64)w;
  return p;
}

HaskellObj
rts_mkFloat (float f)
{
  StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
142
  p->header.info = &Fzh_con_info;
143
144
145
146
147
148
149
150
  ASSIGN_FLT((P_)p->payload, (StgFloat)f);
  return p;
}

HaskellObj
rts_mkDouble (double d)
{
  StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,sizeofW(StgDouble)));
151
  p->header.info = &Dzh_con_info;
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
  ASSIGN_DBL((P_)p->payload, (StgDouble)d);
  return p;
}

HaskellObj
rts_mkStablePtr (StgStablePtr s)
{
  StgClosure *p = (StgClosure *)allocate(sizeofW(StgHeader)+1);
  p->header.info = &StablePtr_con_info;
  p->payload[0]  = (StgClosure *)s;
  return p;
}

HaskellObj
rts_mkAddr (void *a)
{
  StgClosure *p = (StgClosure *)allocate(sizeofW(StgHeader)+1);
169
  p->header.info = &Azh_con_info;
170
171
172
173
174
175
176
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
  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)
{
210
  if (p->header.info == &Czh_con_info || p->header.info == &Czh_static_info) {
211
212
213
214
215
216
217
218
219
    return (char)(StgWord)(p->payload[0]);
  } else {
    barf("getChar: not a Char");
  }
}

int
rts_getInt (HaskellObj p)
{
220
  if (p->header.info == &Izh_con_info || p->header.info == &Izh_static_info) {
221
222
223
224
225
226
227
228
229
    return (int)(p->payload[0]);
  } else {
    barf("getInt: not an Int");
  }
}

unsigned int
rts_getWord (HaskellObj p)
{
230
  if (p->header.info == &Wzh_con_info || p->header.info == &Wzh_static_info) {
231
232
233
234
235
236
237
238
239
    return (unsigned int)(p->payload[0]);
  } else {
    barf("getWord: not a Word");
  }
}

float
rts_getFloat (HaskellObj p)
{
240
  if (p->header.info == &Fzh_con_info || p->header.info == &Fzh_static_info) {
241
242
243
244
245
246
247
248
249
    return (float)(PK_FLT((P_)p->payload));
  } else {
    barf("getFloat: not a Float");
  }
}

double
rts_getDouble (HaskellObj p)
{
250
  if (p->header.info == &Dzh_con_info || p->header.info == &Dzh_static_info) {
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
    return (double)(PK_DBL((P_)p->payload));
  } else {
    barf("getDouble: not a Double");
  }
}

StgStablePtr
rts_getStablePtr (HaskellObj p)
{
  if (p->header.info == &StablePtr_con_info || 
      p->header.info == &StablePtr_static_info) {
    return (StgStablePtr)(p->payload[0]);
  } else {
    barf("getStablePtr: not a StablePtr");
  }
}

void *
rts_getAddr (HaskellObj p)
{
271
  if (p->header.info == &Azh_con_info || p->header.info == &Azh_static_info) {
272
273
274
275
276
277
278
279
280
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
306
307
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
    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);
  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));
  }
}