Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/runtime/c-libs/smlnj-ccalls/c-calls-fns.c
ViewVC logotype

Annotation of /sml/trunk/src/runtime/c-libs/smlnj-ccalls/c-calls-fns.c

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2 - (view) (download) (as text)

1 : monnier 2 /* c-calls-fns.c
2 :     *
3 :     * COPYRIGHT (c) 1995 by AT&T Bell Laboratories.
4 :     *
5 :     */
6 :    
7 :     #include <stdio.h>
8 :     #include <stdlib.h>
9 :     #include <stdarg.h>
10 :     #include "ml-base.h"
11 :     #include "ml-values.h"
12 :     #include "ml-state.h"
13 :     #include "tags.h"
14 :     #include "ml-objects.h"
15 :     #include "ml-globals.h"
16 :     #include "cache-flush.h"
17 :    
18 :     #include "c-calls.h"
19 :    
20 :     /* layout of a code_header must match offsets in c-entry.asm */
21 :     typedef struct code_header {
22 :     ml_val_t the_fn;
23 :     char *argtypes[N_ARGS];
24 :     char *rettype;
25 :     int nargs;
26 :     } code_header_t;
27 :    
28 :     extern Addr_t grabPC();
29 :     extern Addr_t grabPCend();
30 :    
31 :     Word_t *last_entry; /* points to the beginning of the last c-entry */
32 :     /* executed set by grabPC in c-entry.asm */
33 :     PVT code_header_t *last_code_hdr = NULL; /* last code hdr used */
34 :    
35 :     #define CODE_HDR_START(p) \
36 :     ((code_header_t *)((Byte_t *)(p)-sizeof(code_header_t)))
37 :    
38 :    
39 :     /* code for maintaining ML objects (currently only functions) potentially
40 :     * only reachable from C. Currently, we use a list. Objects on this
41 :     * list persist until the program completes; this is a known space leak...
42 :     */
43 :    
44 :     ml_val_t CInterfaceRootList = LIST_nil;/* see gc/call-gc.c and gc/major-gc.c */
45 :    
46 :     PVT void recordFnAsRoot(ml_state_t *msp,ml_val_t *rp)
47 :     {
48 :     LIST_cons(msp,CInterfaceRootList,(ml_val_t) rp,CInterfaceRootList);
49 :     #ifdef DEBUG_C_CALLS
50 :     printf("recordFnAsRoot: added %x\n", rp);
51 :     #endif
52 :     }
53 :    
54 :     PVT ml_val_t saveState(ml_state_t *msp,ml_val_t cont)
55 :     {
56 :     int n, i, j;
57 :     Word_t mask;
58 :    
59 :     /* compute space for save record */
60 :     n = 0;
61 :     /* link, closure, arg, cont, and misc regs are in mask ... */
62 :     mask = msp->ml_liveRegMask; /* should also be mask from REQ_CALLC */
63 :     for (i = 0; mask != 0; i++, mask >>= 1) {
64 :     if ((mask & 1) != 0)
65 :     n++;
66 :     }
67 :     /* ... but pc, exnCont, varreg, and basereg (if defined) aren't */
68 :     n += 3;
69 :     #ifdef BASE_INDX
70 :     n++;
71 :     #endif
72 :     /* also need to save the liveRegMask. we'll do this first */
73 :     /* others?? */
74 :     n++;
75 :     #if defined(SOFT_POLL)
76 :     #error
77 :     #endif
78 :     #ifdef DEBUG_C_CALLS
79 :     printf("saveState: size %d\n", n);
80 :     #endif
81 :     if (cont == (ml_val_t) NULL) {
82 :     ML_AllocWrite (msp, 0, MAKE_DESC(n, DTAG_record));
83 :     j = 1;
84 :     } else {
85 :     n++;
86 :     ML_AllocWrite (msp, 0, MAKE_DESC(n, DTAG_record));
87 :     ML_AllocWrite (msp, 1, cont);
88 :     j = 2;
89 :     }
90 :     ML_AllocWrite (msp, j++, INT_CtoML(msp->ml_liveRegMask));
91 :     ML_AllocWrite (msp, j++, msp->ml_pc);
92 :     ML_AllocWrite (msp, j++, msp->ml_exnCont);
93 :     ML_AllocWrite (msp, j++, msp->ml_varReg);
94 :     #ifdef BASE_INDX
95 :     ML_AllocWrite (msp, j++, msp->ml_baseReg);
96 :     #endif
97 :     mask = msp->ml_liveRegMask;
98 :     for (i = 0; mask != 0; i++, mask >>= 1) {
99 :     if ((mask & 1) != 0)
100 :     ML_AllocWrite (msp, j++, msp->ml_roots[ArgRegMap[i]]);
101 :     }
102 :     ASSERT(j-1 == n);
103 :     return ML_Alloc(msp, n);
104 :     }
105 :    
106 :     PVT void restoreState(ml_state_t *msp,ml_val_t state,int holds_cont)
107 :     {
108 :     int n, i, j;
109 :     Word_t mask;
110 :    
111 :     n = OBJ_LEN(state);
112 :     #ifdef DEBUG_C_CALLS
113 :     printf("restoreState: state size %d\n", n);
114 :     #endif
115 :     /* link, closure, arg, cont, and misc regs are in mask ... */
116 :     /* ... but pc, exnCont, varreg, and basereg (if defined) aren't */
117 :     /* and also need the liveRegMask. get this first */
118 :     /* others?? */
119 :     if (!holds_cont) {
120 :     j = 0;
121 :     } else {
122 :     /* skip function ptr */
123 :     j = 1;
124 :     }
125 :     msp->ml_liveRegMask = REC_SELINT(state,j++);
126 :     msp->ml_pc = REC_SEL(state,j++);
127 :     msp->ml_exnCont = REC_SEL(state,j++);
128 :     msp->ml_varReg = REC_SEL(state,j++);
129 :     #ifdef BASE_INDX
130 :     msp->ml_baseReg = REC_SEL(state,j++);
131 :     #endif
132 :     mask = msp->ml_liveRegMask;
133 :     for (i = 0; mask != 0; i++, mask >>= 1) {
134 :     if ((mask & 1) != 0)
135 :     msp->ml_roots[ArgRegMap[i]] = REC_SEL(state,j++);
136 :     }
137 :     ASSERT(j == n);
138 :     }
139 :    
140 :     PVT void setup_msp(ml_state_t *msp,ml_val_t f, ml_val_t arg)
141 :     {
142 :     #if (CALLEESAVE == 0)
143 :     extern ml_val_t return_a[];
144 :     #endif
145 :    
146 :     /* save necessary state from current msp in calleesave register */
147 :     #if (CALLEESAVE > 0)
148 :     msp->ml_calleeSave(1) = saveState(msp,NULL);
149 :     msp->ml_cont = PTR_CtoML(return_c);
150 :     #else
151 :     msp->ml_cont = saveState(msp,PTR_CtoML(return_a));
152 :     #endif
153 :    
154 :     /* inherit exnCont (?) */
155 :     /* leave msp->ml_exnCon as is */
156 :     msp->ml_varReg = ML_unit;
157 :     msp->ml_arg = arg;
158 :     msp->ml_closure = f;
159 :     msp->ml_pc =
160 :     msp->ml_linkReg = GET_CODE_ADDR(f);
161 :     }
162 :    
163 :     PVT void restore_msp(ml_state_t *msp)
164 :     {
165 :     /* restore previous msp */
166 :     #if (CALLEESAVE > 0)
167 :     restoreState(visible_msp,visible_msp->ml_calleeSave(1),FALSE);
168 :     #else
169 :     restoreState(visible_msp,visible_msp->ml_cont,TRUE);
170 :     #endif
171 :     }
172 :    
173 :     /* convert result to C */
174 :     PVT Word_t convert_result(ml_state_t *msp,code_header_t *chp,ml_val_t val)
175 :     {
176 :     Word_t p, *q = &p;
177 :     char *t = chp->rettype;
178 :     int err;
179 :    
180 :     /* front-end of interface guarantees that ret is a valid
181 :     * return value for a C function: Word_t or some pointer
182 :     */
183 :     err = datumMLtoC(msp,&t,&q,val);
184 :     if (err)
185 :     /* need better error reporting here ... */
186 :     Die("convert_result: error converting return value to C");
187 :     /* return C result*/
188 :     return p;
189 :     }
190 :    
191 :    
192 :     /* entry points; must be visible to c-entry.asm
193 :     */
194 :    
195 :     int no_args_entry()
196 :     {
197 :     ml_val_t ret;
198 :    
199 :     #ifdef DEBUG_C_CALLS
200 :     printf("no_args_entry: entered\n");
201 :     #endif
202 :     last_code_hdr = CODE_HDR_START(last_entry);
203 :     #ifdef DEBUG_C_CALLS
204 :     printf("no_args_entry: nargs in header is %d\n", last_code_hdr->nargs);
205 :     #endif
206 :    
207 :     /* setup msp for RunML evaluation of (f LIST_nil) */
208 :     setup_msp(visible_msp, last_code_hdr->the_fn, LIST_nil);
209 :    
210 :     /* call ML fn, returns an ml_val_t (which is cdata) */
211 :     #ifdef DEBUG_C_CALLS
212 :     printf("no_arg_entry: calling ML from C\n");
213 :     #endif
214 :     RunML (visible_msp);
215 :    
216 :    
217 :     #ifdef DEBUG_C_CALLS
218 :     printf("no_args_entry: return value is %d\n", visible_msp->ml_arg);
219 :     #endif
220 :    
221 :     ret = visible_msp->ml_arg;
222 :    
223 :     restore_msp(visible_msp);
224 :    
225 :     return convert_result(visible_msp,last_code_hdr,ret);
226 :     }
227 :    
228 :     int some_args_entry(Word_t first,...)
229 :     {
230 :     va_list ap;
231 :     ml_val_t lp = LIST_nil, ret;
232 :     Word_t next;
233 :     int i;
234 :     ml_val_t args[N_ARGS];
235 :    
236 :     #ifdef DEBUG_C_CALLS
237 :     printf("some_args_entry: entered\n");
238 :     #endif
239 :     last_code_hdr = CODE_HDR_START(last_entry);
240 :     #ifdef DEBUG_C_CALLS
241 :     printf("some_args_entry: nargs in header is %d\n", last_code_hdr->nargs);
242 :     printf("arg 0: %x\n",first);
243 :     #endif
244 :     ret = datumCtoML(visible_msp,last_code_hdr->argtypes[0],first,&lp);
245 :     LIST_cons(visible_msp,lp,ret,lp);
246 :     va_start(ap,first);
247 :     for (i = 1; i < last_code_hdr->nargs; i++) {
248 :     next = va_arg(ap,Word_t);
249 :     #ifdef DEBUG_C_CALLS
250 :     printf("arg %d: %x\n",i,next);
251 :     #endif
252 :     ret = datumCtoML(visible_msp,last_code_hdr->argtypes[i],next,&lp);
253 :     LIST_cons(visible_msp,lp,ret,lp);
254 :     }
255 :     va_end(ap);
256 :    
257 :     /* lp is backwards */
258 :     lp = revMLList(lp,LIST_nil);
259 :    
260 :     /* setup msp for RunML evaluation of (f lp) */
261 :     setup_msp(visible_msp, last_code_hdr->the_fn, lp);
262 :    
263 :     /* call ML fn, returns an ml_val_t (which is cdata) */
264 :     #ifdef DEBUG_C_CALLS
265 :     printf("some_arg_entry: calling ML from C\n");
266 :     #endif
267 :     RunML (visible_msp);
268 :    
269 :    
270 :     #ifdef DEBUG_C_CALLS
271 :     printf("some_args_entry: return value is %d\n", visible_msp->ml_arg);
272 :     #endif
273 :    
274 :     ret = visible_msp->ml_arg;
275 :    
276 :     restore_msp(visible_msp);
277 :    
278 :     return convert_result(visible_msp,last_code_hdr,ret);
279 :     }
280 :    
281 :     PVT void *build_entry(ml_state_t *msp,code_header_t h)
282 :     {
283 :     int szb = ((Byte_t *)grabPCend) - ((Byte_t *)grabPC);
284 :     Byte_t *p;
285 :    
286 :    
287 :     #ifdef DEBUG_C_CALLS
288 :     printf ("grabPC=%lx, grabPCend=%lx, code size is %d\n",
289 :     grabPC, grabPCend, szb);
290 :     printf ("code_header size is %d\n", sizeof(code_header_t));
291 :     #endif
292 :     ASSERT((sizeof(code_header_t) & 0x3) == 0);
293 :     p = (Byte_t *) memalign(sizeof(Word_t),szb+sizeof(code_header_t));
294 :     *(code_header_t *)p = h;
295 :     recordFnAsRoot(msp,&(((code_header_t *)p)->the_fn));
296 :     /* NB: to free this thing, we'll have to subtract sizeof(code_header_t) */
297 :     p += sizeof(code_header_t);
298 :     #ifdef DEBUG_C_CALLS
299 :     printf ("new code starts at %x and ends at %x\n", p, p+szb);
300 :     #endif
301 :     memcpy (p, (void *)grabPC, szb);
302 :     FlushICache(p,szb);
303 :     return p;
304 :     }
305 :    
306 :     Word_t mk_C_function(ml_state_t *msp,
307 :     ml_val_t f,int nargs,char *argtypes[],char *rettype)
308 :     {
309 :     code_header_t ch;
310 :     int i;
311 :    
312 :     /* create a code header; this will be copied by build entry */
313 :     ch.the_fn = f;
314 :     ch.nargs = nargs;
315 :     for (i = 0; i < nargs; i++)
316 :     ch.argtypes[i] = argtypes[i]; /* argtypes[i] is a copy we can have */
317 :     ch.rettype = rettype; /* rettype is a copy we can have */
318 :    
319 :     /* build and return a C entry for f */
320 :     return (Word_t) build_entry(msp,ch);
321 :     }
322 :    
323 :     /* end of c-calls-fns.c */

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0