1 /*
2 * Part of Scheme 48 1.9. See file COPYING for notices and license.
3 *
4 * Authors: Marcus Crestani, Harald Glab-Phlak
5 */
6
7 /* Modelled on Jim Blandy's foreign function interface that he put in
8 his Scheme implementation called Minor. */
9
10 #include <stdlib.h>
11 #include <stdio.h>
12 #include <string.h>
13
14 #include "scheme48.h"
15 #include "scheme48vm.h"
16 #include "scheme48heap.h"
17 #include "ffi.h"
18
19 /* structs */
20
21 struct ref_group;
22
23 struct s48_ref_s
24 {
25 s48_value obj;
26 struct ref_group *group;
27 };
28
29 struct ref;
30
31 struct ref
32 {
33 struct s48_ref_s x;
34 struct ref *next, *prev;
35 };
36
37 #define NUM_REFS_PER_CLUMP 85
38
39 struct ref_clump;
40
41 struct ref_clump
42 {
43 struct ref_clump *next;
44 struct ref refs[NUM_REFS_PER_CLUMP];
45 };
46
47 struct ref_group
48 {
49 struct ref_clump *clumps;
50 struct ref *free;
51 struct ref *last_free;
52 short first_never_used;
53 struct ref allocated;
54 };
55
56 struct buf_group;
57
58 struct buf_group
59 {
60 void *buffer;
61 struct buf_group *next, *prev;
62 };
63
64 enum BV_MODE { READWRITE, READONLY };
65
66 struct bv_group;
67
68 struct bv_group
69 {
70 char *buffer;
71 s48_ref_t byte_vector;
72 enum BV_MODE mode;
73 struct bv_group *next, *prev;
74 };
75
76 struct s48_call_s
77 {
78 s48_call_t older_call;
79 s48_call_t subcall_parent;
80 s48_call_t child;
81 s48_call_t next_subcall, prev_subcall;
82 struct ref_group *local_refs;
83 struct buf_group *local_bufs;
84 struct bv_group *local_bvs;
85 };
86
87
88 /* global states */
89 static s48_call_t current_call = NULL;
90 static struct ref_group *global_ref_group = NULL;
91
92 #define GLOBAL_REF_P(ref) (ref->group == global_ref_group)
93
94 /* REFS */
95
96 static struct ref_group *
make_ref_group(void)97 make_ref_group (void)
98 {
99 struct ref_group *g = (struct ref_group *) malloc (sizeof (struct ref_group));
100 if (g == NULL)
101 s48_out_of_memory_error();
102 memset (g, 0, sizeof (*g));
103
104 g->clumps = 0;
105 g->free = 0;
106 g->allocated.next = &g->allocated;
107 g->allocated.prev = &g->allocated;
108 return g;
109 }
110
111 static void
free_ref_group(struct ref_group * g)112 free_ref_group (struct ref_group *g)
113 {
114 struct ref_clump *c, *next;
115 for (c = g->clumps; c; c = next) {
116 next = c->next;
117 free (c);
118 }
119 free (g);
120 }
121
122 static s48_ref_t
make_ref(struct ref_group * g,s48_value obj)123 make_ref (struct ref_group *g, s48_value obj)
124 {
125 struct ref *r;
126
127 if (g->clumps && (g->first_never_used < NUM_REFS_PER_CLUMP))
128 r = &g->clumps->refs[g->first_never_used++];
129 else if (g->free) {
130 r = g->free;
131 g->free = r->next;
132 } else {
133 struct ref_clump *new =
134 (struct ref_clump *) malloc (sizeof (struct ref_clump));
135 if (new == NULL)
136 s48_out_of_memory_error();
137
138 new->next = g->clumps;
139 g->clumps = new;
140 r = &new->refs[0];
141 g->first_never_used = 1;
142 }
143
144 r->next = g->allocated.next;
145 r->prev = &g->allocated;
146 r->next->prev = r;
147 r->prev->next = r;
148 r->x.group = g;
149 r->x.obj = obj;
150
151 return &r->x;
152 }
153
154 static void
free_ref(s48_ref_t x)155 free_ref (s48_ref_t x)
156 {
157 #ifdef DEBUG_FFI
158 fprintf (stderr, "free ref with scheme value %x\n", s48_deref(x));
159 #endif
160 struct ref *r = (struct ref *) x;
161 struct ref_group *g = r->x.group;
162
163 r->next->prev = r->prev;
164 r->prev->next = r->next;
165 r->next = 0;
166 if (g->free) {
167 g->last_free->next = r;
168 g->last_free = r;
169 } else
170 g->free = g->last_free = r;
171 r->x.obj = S48_FALSE;
172 }
173
174 static void
walk_ref_group(struct ref_group * g,void (* func)(s48_ref_t ref,void * closure),void * closure)175 walk_ref_group (struct ref_group *g,
176 void (*func) (s48_ref_t ref, void *closure),
177 void *closure)
178 {
179 struct ref *r;
180 struct ref *head = &g->allocated;
181 for (r = head->next; r != head; r = r->next)
182 func (&r->x, closure);
183 }
184
185
186 /* LOCAL REFS */
187
188 s48_ref_t
s48_make_local_ref(s48_call_t call,s48_value obj)189 s48_make_local_ref (s48_call_t call, s48_value obj)
190 {
191 #ifdef DEBUG_FFI
192 fprintf (stderr, "make local ref from scheme value %x\n", obj);
193 #endif
194 return make_ref (call->local_refs, obj);
195 }
196
197 s48_ref_t
s48_copy_local_ref(s48_call_t call,s48_ref_t ref)198 s48_copy_local_ref (s48_call_t call, s48_ref_t ref)
199 {
200 s48_ref_t r = s48_make_local_ref (call, s48_deref(ref));
201 return r;
202 }
203
204 void
s48_free_local_ref(s48_call_t call,s48_ref_t ref)205 s48_free_local_ref (s48_call_t call, s48_ref_t ref)
206 {
207 #ifdef DEBUG_FFI
208 fprintf (stderr, "free local ref with scheme value %x\n", s48_deref(ref));
209 #endif
210 if (!GLOBAL_REF_P (ref))
211 free_ref (ref);
212 else
213 s48_assertion_violation ("s48_free_localref", "ref is not local", 0);
214 }
215
216 void
s48_free_local_ref_array(s48_call_t call,s48_ref_t * refs,size_t len)217 s48_free_local_ref_array (s48_call_t call, s48_ref_t *refs, size_t len)
218 {
219 size_t i;
220 for (i = 0; i < len; i++)
221 s48_free_local_ref (call, refs[i]);
222 }
223
224
225 /* GLOBAL REFS */
226
227 s48_ref_t
s48_make_global_ref(s48_value obj)228 s48_make_global_ref (s48_value obj)
229 {
230 #ifdef DEBUG_FFI
231 fprintf (stderr, "make global ref from scheme value %x\n", obj);
232 #endif
233 return make_ref (global_ref_group, obj);
234 }
235
236 void
s48_free_global_ref(s48_ref_t ref)237 s48_free_global_ref (s48_ref_t ref)
238 {
239 #ifdef DEBUG_FFI
240 fprintf (stderr, "free global ref from scheme value %x\n", s48_deref(ref));
241 #endif
242 if (GLOBAL_REF_P (ref))
243 free_ref (ref);
244 else
245 s48_assertion_violation ("s48_free_global_ref", "ref is not global", 0);
246 }
247
248 s48_ref_t
s48_local_to_global_ref(s48_ref_t ref)249 s48_local_to_global_ref(s48_ref_t ref)
250 {
251 s48_value temp = s48_deref(ref);
252 #ifdef DEBUG_FFI
253 fprintf (stderr, "local to global ref from scheme value %x\n", s48_deref(ref));
254 #endif
255 free_ref (ref);
256 return s48_make_global_ref(temp);
257 }
258
259 static void
walk_global_refs(void (* func)(s48_ref_t ref,void * closure),void * closure)260 walk_global_refs (void (*func) (s48_ref_t ref, void *closure),
261 void *closure)
262 {
263 walk_ref_group (global_ref_group, func, closure);
264 }
265
266
267 /* BUFS */
268
269 struct buf_group *
make_buf_group(void)270 make_buf_group (void)
271 {
272 struct buf_group *g = (struct buf_group *) malloc (sizeof (struct buf_group));
273 if (g == NULL)
274 s48_out_of_memory_error();
275 #ifdef DEBUG_FFI
276 fprintf (stderr, "make buf group %x\n", g);
277 #endif
278 return g;
279 }
280
281 void
free_buf(struct buf_group * b)282 free_buf (struct buf_group *b)
283 {
284 #ifdef DEBUG_FFI
285 fprintf (stderr, "free buf %x\n", b);
286 #endif
287 free (b->buffer);
288 free (b);
289 }
290
291 void
free_buf_group(struct buf_group * g)292 free_buf_group (struct buf_group *g)
293 {
294 struct buf_group *b, *next;
295 #ifdef DEBUG_FFI
296 fprintf (stderr, "free buf group %x\n", g);
297 #endif
298 for (b = g; b; b = next) {
299 next = b->next;
300 free_buf (b);
301 }
302 }
303
304 void *
s48_make_local_buf(s48_call_t call,size_t s)305 s48_make_local_buf (s48_call_t call, size_t s)
306 {
307 struct buf_group *g = make_buf_group ();
308 #ifdef DEBUG_FFI
309 fprintf (stderr, "make buf with size %x\n", s);
310 #endif
311 g->buffer = (void *) calloc (1, s);
312 if (g->buffer == NULL)
313 s48_out_of_memory_error();
314 g->prev = NULL;
315 g->next = call->local_bufs;
316 if (g->next)
317 g->next->prev = g;
318 call->local_bufs = g;
319 return g->buffer;
320 }
321
322 void
s48_free_local_buf(s48_call_t call,void * buffer)323 s48_free_local_buf (s48_call_t call, void *buffer)
324 {
325 struct buf_group *prev, *b, *next;
326
327 if (! call->local_bufs)
328 return;
329
330 #ifdef DEBUG_FFI
331 fprintf (stderr, "free buf %x\n", buffer);
332 #endif
333
334 if (buffer == call->local_bufs->buffer) {
335 b = call->local_bufs;
336 call->local_bufs = call->local_bufs->next;
337 if (call->local_bufs)
338 call->local_bufs->prev = NULL;
339 free_buf (b);
340 return;
341 }
342
343 prev = call->local_bufs;
344 b = call->local_bufs->next;
345 while (b) {
346 if (buffer == b->buffer) {
347 next = b->next;
348 prev = b->prev;
349 prev->next = next;
350 if (next)
351 next->prev = prev;
352 free_buf (b);
353 b = NULL;
354 } else {
355 b = b->next;
356 }
357 }
358 }
359
360
361 /* BYTE VECTORS */
362
363 struct bv_group *
make_bv_group(void)364 make_bv_group (void)
365 {
366 struct bv_group *g = (struct bv_group *) malloc (sizeof (struct bv_group));
367 if (g == NULL)
368 s48_out_of_memory_error();
369 #ifdef DEBUG_FFI
370 fprintf (stderr, "make bv group %x\n", g);
371 #endif
372 return g;
373 }
374
375
376 static void
copy_to_bv(s48_call_t call,struct bv_group * bv,void * closure)377 copy_to_bv (s48_call_t call, struct bv_group *bv, void *closure)
378 {
379 if (bv->mode != READONLY)
380 s48_copy_to_byte_vector_2(call, bv->byte_vector, bv->buffer);
381 }
382
383 static void
copy_from_bv(s48_call_t call,struct bv_group * bv,void * closure)384 copy_from_bv (s48_call_t call, struct bv_group *bv, void *closure)
385 {
386 s48_copy_from_byte_vector_2(call, bv->byte_vector, bv->buffer);
387 }
388
389 void
free_bv(s48_call_t call,struct bv_group * b)390 free_bv (s48_call_t call, struct bv_group *b)
391 {
392 #ifdef DEBUG_FFI
393 fprintf (stderr, "free bv %x\n", b);
394 #endif
395 copy_to_bv (call, b, NULL);
396 free (b->buffer);
397 free (b);
398 }
399
400 void
free_bv_group(s48_call_t call,struct bv_group * g)401 free_bv_group (s48_call_t call, struct bv_group *g)
402 {
403 struct bv_group *b, *next;
404 #ifdef DEBUG_FFI
405 fprintf (stderr, "free bv group %x\n", g);
406 #endif
407 for (b = g; b; b = next) {
408 next = b->next;
409 free_bv (call, b);
410 }
411 }
412
413 struct bv_group *
s48_find_local_bv(s48_call_t call,s48_ref_t byte_vector,long s)414 s48_find_local_bv (s48_call_t call, s48_ref_t byte_vector, long s)
415 {
416 struct bv_group *b;
417
418 if (! call->local_bvs)
419 return NULL;
420
421 if (s48_eq_p_2 (call, byte_vector, call->local_bvs->byte_vector)) {
422 return call->local_bvs;
423 }
424
425 b = call->local_bvs->next;
426 while (b) {
427 if (s48_eq_p_2 (call, byte_vector, b->byte_vector)) {
428 return b;
429 } else {
430 b = b->next;
431 }
432 }
433
434 return NULL;
435 }
436
437 char *
s48_really_make_local_bv(s48_call_t call,s48_ref_t byte_vector,long s,enum BV_MODE mode)438 s48_really_make_local_bv (s48_call_t call, s48_ref_t byte_vector, long s, enum BV_MODE mode)
439 {
440 struct bv_group *g = make_bv_group ();
441 #ifdef DEBUG_FFI
442 fprintf (stderr, "make bv with size %x\n", s);
443 #endif
444 g->buffer = (char *) calloc (1, s);
445 if (g->buffer == NULL)
446 s48_out_of_memory_error();
447 g->byte_vector = byte_vector;
448 g->mode = mode;
449 g->prev = NULL;
450 g->next = call->local_bvs;
451 if (g->next)
452 g->next->prev = g;
453 call->local_bvs = g;
454 return g->buffer;
455 }
456
457 psbool s48_unmovable_p (s48_call_t, s48_ref_t);
458
459 char *
s48_maybe_make_local_bv(s48_call_t call,s48_ref_t byte_vector,long s,enum BV_MODE mode)460 s48_maybe_make_local_bv (s48_call_t call, s48_ref_t byte_vector, long s, enum BV_MODE mode)
461 {
462 char *buf;
463 struct bv_group *b;
464
465 if (s48_unmovable_p(call, byte_vector))
466 {
467 return s48_extract_unmovable_byte_vector_2(call, byte_vector);
468 }
469
470 b = s48_find_local_bv (call, byte_vector, s);
471 if (b)
472 {
473 b->mode = mode;
474 return b->buffer;
475 }
476 else
477 {
478 buf = s48_really_make_local_bv (call, byte_vector, s, mode);
479 s48_extract_byte_vector_region_2(call, byte_vector, 0, s, buf);
480 return buf;
481 }
482 }
483
484 char *
s48_make_local_bv(s48_call_t call,s48_ref_t byte_vector,long s)485 s48_make_local_bv (s48_call_t call, s48_ref_t byte_vector, long s)
486 {
487 return s48_maybe_make_local_bv(call, byte_vector, s, READWRITE);
488 }
489
490 char *
s48_make_local_bv_readonly(s48_call_t call,s48_ref_t byte_vector,long s)491 s48_make_local_bv_readonly (s48_call_t call, s48_ref_t byte_vector, long s)
492 {
493 return s48_maybe_make_local_bv(call, byte_vector, s, READONLY);
494 }
495
496 void
s48_free_local_bv(s48_call_t call,char * buffer)497 s48_free_local_bv (s48_call_t call, char *buffer)
498 {
499 struct bv_group *prev, *b, *next;
500
501 if (! call->local_bvs)
502 return;
503
504 #ifdef DEBUG_FFI
505 fprintf (stderr, "free bv %x\n", buffer);
506 #endif
507
508 if (buffer == call->local_bvs->buffer) {
509 b = call->local_bvs;
510 call->local_bvs = call->local_bvs->next;
511 if (call->local_bvs)
512 call->local_bvs->prev = NULL;
513 free_bv (call, b);
514 return;
515 }
516
517 prev = call->local_bvs;
518 b = call->local_bvs->next;
519 while (b) {
520 if (buffer == b->buffer) {
521 next = b->next;
522 prev = b->prev;
523 prev->next = next;
524 if (next)
525 next->prev = prev;
526 free_bv (call, b);
527 b = NULL;
528 } else {
529 b = b->next;
530 }
531 }
532 }
533
534 static void
walk_local_bvs(s48_call_t call,void (* func)(s48_call_t call,struct bv_group * bv,void * closure),void * closure)535 walk_local_bvs (s48_call_t call,
536 void (*func) (s48_call_t call, struct bv_group *bv, void *closure),
537 void *closure)
538 {
539 struct bv_group *b;
540
541 for (b = call->local_bvs; b; b = b->next)
542 func (call, b, closure);
543 }
544
545 void
s48_copy_local_bvs_to_scheme(s48_call_t call)546 s48_copy_local_bvs_to_scheme (s48_call_t call)
547 {
548 walk_local_bvs (call, copy_to_bv, NULL);
549 }
550
551 void
s48_copy_local_bvs_from_scheme(s48_call_t call)552 s48_copy_local_bvs_from_scheme (s48_call_t call)
553 {
554 walk_local_bvs (call, copy_from_bv, NULL);
555 }
556
557
558 /* CALLS */
559
560 static s48_call_t
really_make_call(s48_call_t older_call)561 really_make_call (s48_call_t older_call)
562 {
563 s48_call_t new = (s48_call_t ) malloc (sizeof (struct s48_call_s));
564 if (new == NULL)
565 s48_out_of_memory_error();
566 memset (new, 0, sizeof (*new));
567 new->local_refs = make_ref_group ();
568 new->older_call = older_call;
569 new->subcall_parent = NULL;
570 new->child = NULL;
571 new->local_bufs = NULL;
572 new->local_bvs = NULL;
573 return new;
574 }
575
576 s48_call_t
s48_push_call(s48_call_t call)577 s48_push_call (s48_call_t call)
578 {
579 #ifdef DEBUG_FFI
580 fprintf (stderr, "push\n");
581 #endif
582 current_call = really_make_call (call);
583 return current_call;
584 }
585
586 static void
free_call(s48_call_t call)587 free_call (s48_call_t call)
588 {
589 if (call->child) {
590 s48_call_t c = call->child;
591
592 do {
593 s48_call_t temp = c;
594 c = c->next_subcall;
595 free_call (temp);
596 } while (c != call->child);
597 }
598 free_bv_group (call, call->local_bvs);
599 free_ref_group (call->local_refs);
600 free_buf_group (call->local_bufs);
601 #ifdef DEBUG_FFI
602 fprintf (stderr, "free_call\n");
603 fprintf(stderr, " count calls: %d, localrefs: %d, globalrefs: %d\n",
604 count_calls(), count_local_refs (), count_global_refs());
605 #endif
606 free (call);
607 }
608
609 void
s48_pop_to(s48_call_t call)610 s48_pop_to (s48_call_t call)
611 {
612 while (current_call != call) {
613 s48_call_t here = current_call;
614 if (!here)
615 s48_assertion_violation ("s48_pop_to", "current_call is null", 0);
616 current_call = here->older_call;
617 free_call (here);
618 #ifdef DEBUG_FFI
619 fprintf (stderr, "pop\n");
620 #endif
621 }
622 }
623
624
625 /* SUBCALLS */
626
627 s48_call_t
s48_make_subcall(s48_call_t call)628 s48_make_subcall (s48_call_t call)
629 {
630 s48_call_t new = (s48_call_t ) malloc (sizeof (struct s48_call_s));
631 if (new == NULL)
632 s48_out_of_memory_error();
633 memset (new, 0, sizeof (*new));
634 new->local_refs = make_ref_group ();
635 new->older_call = NULL;
636 new->subcall_parent = call;
637 new->child = NULL;
638
639 if (call->child) {
640 new->next_subcall = call->child->next_subcall;
641 new->prev_subcall = call->child;
642 new->next_subcall->prev_subcall = new;
643 new->prev_subcall->next_subcall = new;
644 } else {
645 new->next_subcall = new->prev_subcall = new;
646 call->child = new;
647 }
648
649 return new;
650 }
651
652 void
s48_free_subcall(s48_call_t subcall)653 s48_free_subcall (s48_call_t subcall)
654 {
655 s48_call_t parent = subcall->subcall_parent;
656 if (subcall->next_subcall == subcall) {
657 parent->child = NULL;
658 } else {
659 parent->child = subcall->next_subcall;
660 subcall->prev_subcall->next_subcall = subcall->next_subcall;
661 subcall->next_subcall->prev_subcall = subcall->prev_subcall;
662 }
663 free_call (subcall);
664 }
665
666 s48_ref_t
s48_finish_subcall(s48_call_t call,s48_call_t subcall,s48_ref_t ref)667 s48_finish_subcall (s48_call_t call, s48_call_t subcall, s48_ref_t ref)
668 {
669 s48_ref_t result = ref ? s48_copy_local_ref (call, ref) : NULL;
670 s48_free_subcall (subcall);
671 return result;
672 }
673
674 static void
walk_call(s48_call_t call,void (* func)(s48_ref_t,void * closure),void * closure)675 walk_call (s48_call_t call,
676 void (*func) (s48_ref_t, void *closure),
677 void *closure)
678 {
679 s48_call_t c = NULL;
680 walk_ref_group (call->local_refs, func, closure);
681 c = call->child;
682 if (c)
683 do
684 walk_call (c, func, closure);
685 while ((c = c->next_subcall) != call->child);
686 }
687
688 static void
walk_local_refs(void (* func)(s48_ref_t,void * closure),void * closure)689 walk_local_refs (void (*func) (s48_ref_t, void *closure), void *closure)
690 {
691 s48_call_t c;
692 for (c = current_call; c; c = c->older_call)
693 walk_call (c, func, closure);
694 }
695
696 #ifdef DEBUG_FFI /* for debugging */
697 static void
count_a_ref(s48_ref_t ref,void * closure)698 count_a_ref (s48_ref_t ref, void *closure)
699 {
700 size_t *count_p = closure;
701 (*count_p)++;
702 }
703
704 static size_t
count_global_refs()705 count_global_refs ()
706 {
707 size_t count = 0;
708 walk_global_refs (count_a_ref, &count);
709 return count;
710 }
711
712 static size_t
count_local_refs()713 count_local_refs ()
714 {
715 size_t count = 0;
716 walk_local_refs (count_a_ref, &count);
717 return count;
718 }
719
720 static size_t
count_calls()721 count_calls ()
722 {
723 size_t count;
724 s48_call_t c;
725 for (c = current_call, count = 0; c; c = c->older_call, count++);
726 return count;
727 }
728 #endif
729
730 void
s48_setref(s48_ref_t ref,s48_value obj)731 s48_setref (s48_ref_t ref, s48_value obj)
732 {
733 ref->obj = obj;
734 }
735
736 s48_value
s48_deref(s48_ref_t ref)737 s48_deref (s48_ref_t ref)
738 {
739 return ref->obj;
740 }
741
742 s48_call_t
s48_first_call(void)743 s48_first_call (void)
744 {
745 return really_make_call (NULL);
746 }
747
748 s48_call_t
s48_get_current_call(void)749 s48_get_current_call (void)
750 {
751 return current_call;
752 }
753
754 void
s48_initialize_ffi(void)755 s48_initialize_ffi (void)
756 {
757 if (current_call)
758 s48_assertion_violation ("s48_init_ffi", "current_call is already set", 0);
759 current_call = s48_first_call ();
760
761 if (global_ref_group)
762 s48_assertion_violation ("s48_init_ffi", "global_ref_group is already set", 0);
763 global_ref_group = make_ref_group ();
764 }
765
766 static void
trace_a_ref(s48_ref_t ref,void * closure)767 trace_a_ref (s48_ref_t ref, void *closure)
768 {
769 (*(size_t *) closure)++;
770 s48_setref(ref, s48_trace_value (s48_deref(ref)));
771 }
772
773 void
s48_trace_external_calls(void)774 s48_trace_external_calls (void)
775 {
776 size_t cnt_locals = 0;
777 size_t cnt_globals = 0;
778 walk_local_refs (trace_a_ref, &cnt_locals);
779 walk_global_refs (trace_a_ref, &cnt_globals);
780 #ifdef DEBUG_FFI
781 fprintf(stderr, "### TRACED locals %d globals %d ###\n", cnt_locals, cnt_globals);
782 #endif
783 }
784
785
786 #ifdef DEBUG_FFI
787 /* TESTS */
788
789 static s48_ref_t
test_0(s48_call_t call)790 test_0 (s48_call_t call)
791 {
792 fprintf(stderr, "test_0\n");
793 fprintf(stderr, " count calls: %d, localrefs: %d, globalrefs: %d\n",
794 count_calls(), count_local_refs (), count_global_refs());
795 return s48_make_local_ref (call, _s48_value_true);
796 }
797
798 static s48_ref_t
test_1(s48_call_t call,s48_ref_t ref_1)799 test_1 (s48_call_t call, s48_ref_t ref_1)
800 {
801 s48_ref_t result;
802
803 fprintf(stderr, ">>> %d <<<\n", s48_extract_fixnum (s48_deref(ref_1)));
804 /*
805 s48_ref_t proc =
806 s48_make_local_ref (call,
807 S48_SHARED_BINDING_REF(s48_get_imported_binding ("display")));
808 fprintf(stderr, "> test_1\n");
809 fprintf(stderr, " count calls: %d, localrefs: %d, globalrefs: %d\n",
810 count_calls(), count_local_refs (), count_global_refs());
811 result = s48_call_scheme_2 (call, proc, 1, ref_1);
812 fprintf(stderr, " count calls: %d, localrefs: %d, globalrefs: %d\n",
813 count_calls(), count_local_refs (), count_global_refs());
814 fprintf(stderr, "< test_1\n");
815 */
816 return result;
817 }
818
819 static s48_ref_t
call_thunk(s48_call_t call,s48_ref_t thunk)820 call_thunk (s48_call_t call, s48_ref_t thunk)
821 {
822 s48_ref_t result;
823 fprintf(stderr, "> call_thunk\n");
824 fprintf(stderr, " count calls: %d, localrefs: %d, globalrefs: %d\n",
825 count_calls(), count_local_refs (), count_global_refs());
826 result = s48_call_scheme_2 (call, thunk, 0);
827 fprintf(stderr, " count calls: %d, localrefs: %d, globalrefs: %d\n",
828 count_calls(), count_local_refs (), count_global_refs());
829 fprintf(stderr, "< call_thunk\n");
830 return result;
831 }
832
833 static s48_ref_t
call_unary(s48_call_t call,s48_ref_t unary,s48_ref_t arg)834 call_unary (s48_call_t call, s48_ref_t unary, s48_ref_t arg)
835 {
836 s48_ref_t result;
837 fprintf(stderr, "> call_unary\n");
838 fprintf(stderr, " count calls: %d, localrefs: %d, globalrefs: %d\n",
839 count_calls(), count_local_refs (), count_global_refs());
840 result = s48_call_scheme_2 (call, unary, 1, arg);
841 fprintf(stderr, " count calls: %d, localrefs: %d, globalrefs: %d\n",
842 count_calls(), count_local_refs (), count_global_refs());
843 fprintf(stderr, "< call_unary\n");
844 return result;
845 }
846
847 void
init_debug_ffi(void)848 init_debug_ffi (void)
849 {
850 S48_EXPORT_FUNCTION(test_0);
851 S48_EXPORT_FUNCTION(test_1);
852 S48_EXPORT_FUNCTION(call_thunk);
853 S48_EXPORT_FUNCTION(call_unary);
854 S48_EXPORT_FUNCTION(s48_length_2);
855 }
856
857 /*
858 ; ,open external-calls primitives
859
860 (import-lambda-definition-2 call-thunk (thunk))
861 (import-lambda-definition-2 call-unary (proc arg))
862
863 (call-thunk
864 (lambda ()
865 (call-with-current-continuation
866 (lambda (cont)
867 (call-thunk
868 (lambda ()
869 (call-thunk
870 (lambda ()
871 (collect)
872 (call-unary cont 23)))))))))
873
874 */
875
876 #endif
877