1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
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
|
/***********************************************************************/
/* */
/* Objective Caml */
/* */
/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
/* */
/* Copyright 1996 Institut National de Recherche en Informatique et */
/* en Automatique. All rights reserved. This file is distributed */
/* under the terms of the GNU Library General Public License. */
/* */
/***********************************************************************/
/* $Id$ */
/* Callbacks from C to Caml */
#include <string.h>
#include "callback.h"
#include "fail.h"
#include "memory.h"
#include "mlvalues.h"
#ifndef NATIVE_CODE
/* Bytecode callbacks */
#include "interp.h"
#include "instruct.h"
#include "fix_code.h"
#include "stacks.h"
int callback_depth = 0;
static opcode_t callback_code[] = { ACC, 0, APPLY, 0, POP, 1, STOP };
#ifdef THREADED_CODE
static int callback_code_threaded = 0;
static void thread_callback(void)
{
thread_code(callback_code, sizeof(callback_code));
callback_code_threaded = 1;
}
#define Init_callback() if (!callback_code_threaded) thread_callback()
#else
#define Init_callback()
#endif
value callbackN_exn(value closure, int narg, value args[])
{
int i;
Assert(narg + 4 <= 256);
Init_callback();
extern_sp -= narg + 4;
for (i = 0; i < narg; i++) extern_sp[i] = args[i]; /* arguments */
extern_sp[narg] = (value) (callback_code + 4); /* return address */
extern_sp[narg + 1] = Val_unit; /* environment */
extern_sp[narg + 2] = Val_long(0); /* extra args */
extern_sp[narg + 3] = closure;
callback_code[1] = narg + 3;
callback_code[3] = narg;
return interprete(callback_code, sizeof(callback_code));
}
value callback_exn(value closure, value arg1)
{
value arg[1];
arg[0] = arg1;
return callbackN_exn(closure, 1, arg);
}
value callback2_exn(value closure, value arg1, value arg2)
{
value arg[2];
arg[0] = arg1;
arg[1] = arg2;
return callbackN_exn(closure, 2, arg);
}
value callback3_exn(value closure, value arg1, value arg2, value arg3)
{
value arg[3];
arg[0] = arg1;
arg[1] = arg2;
arg[2] = arg3;
return callbackN_exn(closure, 3, arg);
}
#else
/* Native-code callbacks. callback_exn[123] are implemented in asm. */
value callbackN_exn(value closure, int narg, value args[])
{
value res;
int i;
res = closure;
Begin_roots1(res)
Begin_roots_block(args, narg)
for (i = 0; i < narg; /*nothing*/) {
/* Pass as many arguments as possible */
switch (narg - i) {
case 1:
res = callback_exn(res, args[i]);
if (Is_exception_result(res)) return res;
i += 1;
break;
case 2:
res = callback2(res, args[i], args[i + 1]);
if (Is_exception_result(res)) return res;
i += 2;
break;
default:
res = callback3(res, args[i], args[i + 1], args[i + 2]);
if (Is_exception_result(res)) return res;
i += 3;
break;
}
}
End_roots();
End_roots();
return res;
}
#endif
/* Exception-propagating variants of the above */
value callback (value closure, value arg)
{
value res = callback_exn(closure, arg);
if (Is_exception_result(res)) mlraise(Extract_exception(res));
return res;
}
value callback2 (value closure, value arg1, value arg2)
{
value res = callback2_exn(closure, arg1, arg2);
if (Is_exception_result(res)) mlraise(Extract_exception(res));
return res;
}
value callback3 (value closure, value arg1, value arg2, value arg3)
{
value res = callback3_exn(closure, arg1, arg2, arg3);
if (Is_exception_result(res)) mlraise(Extract_exception(res));
return res;
}
value callbackN (value closure, int narg, value args[])
{
value res = callbackN_exn(closure, narg, args);
if (Is_exception_result(res)) mlraise(Extract_exception(res));
return res;
}
/* Naming of Caml values */
struct named_value {
value val;
struct named_value * next;
char name[1];
};
#define Named_value_size 13
static struct named_value * named_value_table[Named_value_size] = { NULL, };
static unsigned int hash_value_name(char *name)
{
unsigned int h;
for (h = 0; *name != 0; name++) h = h * 19 + *name;
return h % Named_value_size;
}
value register_named_value(value vname, value val) /* ML */
{
struct named_value * nv;
char * name = String_val(vname);
unsigned int h = hash_value_name(name);
nv = (struct named_value *)
stat_alloc(sizeof(struct named_value) + strlen(name));
strcpy(nv->name, name);
nv->val = val;
nv->next = named_value_table[h];
named_value_table[h] = nv;
register_global_root(&nv->val);
return Val_unit;
}
value * caml_named_value(char *name)
{
struct named_value * nv;
for (nv = named_value_table[hash_value_name(name)];
nv != NULL;
nv = nv->next) {
if (strcmp(name, nv->name) == 0) return &nv->val;
}
return NULL;
}
|
