Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-06-24 06:46:40 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

FFI struct types no longer use global variables (with improved type-inference as a bonus)

Browse source
This commit is contained in:
Alex Shinn 2011-11-24 01:20:47 +09:00
parent 3468ee5145
commit e1731fabf3
8 changed files with 227 additions and 87 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

12
eval.c
View file

@ -1702,13 +1702,11 @@ sexp sexp_make_foreign (sexp ctx, const char *name, int num_args,
sexp sexp_define_foreign_aux (sexp ctx, sexp env, const char *name, int num_args,
int flags, sexp_proc1 f, sexp data) {
sexp_gc_var2(op, res);
sexp_gc_preserve2(ctx, op, res);
op = sexp_make_foreign(ctx, name, num_args, flags, f, data);
if (sexp_exceptionp(op))
res = op;
else
sexp_env_define(ctx, env, res = sexp_intern(ctx, name, -1), op);
sexp_gc_var2(sym, res);
sexp_gc_preserve2(ctx, sym, res);
res = sexp_make_foreign(ctx, name, num_args, flags, f, data);
if (!sexp_exceptionp(res))
sexp_env_define(ctx, env, sym = sexp_intern(ctx, name, -1), res);
sexp_gc_release2(ctx);
return res;
}

4
include/chibi/sexp.h
View file

@ -246,7 +246,8 @@ struct sexp_type_struct {
struct sexp_opcode_struct {
unsigned char op_class, code, num_args, flags, inverse;
sexp name, data, data2, proc, ret_type, arg1_type, arg2_type, arg3_type, dl;
sexp name, data, data2, proc, ret_type, arg1_type, arg2_type, arg3_type,
argn_type, dl;
sexp_proc1 func;
};
@ -871,6 +872,7 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x);
#define sexp_opcode_arg1_type(x) (sexp_field(x, opcode, SEXP_OPCODE, arg1_type))
#define sexp_opcode_arg2_type(x) (sexp_field(x, opcode, SEXP_OPCODE, arg2_type))
#define sexp_opcode_arg3_type(x) (sexp_field(x, opcode, SEXP_OPCODE, arg3_type))
#define sexp_opcode_argn_type(x) (sexp_field(x, opcode, SEXP_OPCODE, argn_type))
#define sexp_opcode_func(x) (sexp_field(x, opcode, SEXP_OPCODE, func))
#define sexp_opcode_variadic_p(x) (sexp_opcode_flags(x) & 1)

14
lib/chibi/accept.c
View file

@ -4,23 +4,15 @@
/* EWOULDBLOCK and block on the socket, and listen should automatically make */
/* sockets non-blocking. */
sexp sexp_accept (sexp ctx, sexp self, sexp arg0, sexp arg1, sexp arg2) {
sexp sexp_accept (sexp ctx, sexp self, int sock, struct sockaddr* addr, socklen_t len) {
sexp f;
socklen_t tmp;
int res;
if (! sexp_exact_integerp(arg0))
return sexp_type_exception(ctx, self, SEXP_FIXNUM, arg0);
if (! (sexp_pointerp(arg1) && (sexp_pointer_tag(arg1) == sexp_type_tag(sexp_sockaddr_type_t))))
return sexp_type_exception(ctx, self, sexp_type_tag(sexp_sockaddr_type_t), arg1);
if (! sexp_exact_integerp(arg2))
return sexp_type_exception(ctx, self, SEXP_FIXNUM, arg2);
tmp = sexp_sint_value(arg2);
res = accept(sexp_sint_value(arg0), (struct sockaddr*)sexp_cpointer_value(arg1), &tmp);
res = accept(sock, addr, &len);
#if SEXP_USE_GREEN_THREADS
if (res < 0 && errno == EWOULDBLOCK) {
f = sexp_global(ctx, SEXP_G_THREADS_BLOCKER);
if (sexp_opcodep(f)) {
((sexp_proc2)sexp_opcode_func(f))(ctx, f, 1, arg0);
((sexp_proc2)sexp_opcode_func(f))(ctx, f, 1, sexp_make_fixnum(sock));
return sexp_global(ctx, SEXP_G_IO_BLOCK_ERROR);
}
}

2
lib/chibi/net.stub
View file

@ -38,7 +38,7 @@
;;> Accept a connection on a socket.
(define-c sexp (accept "sexp_accept")
((value ctx sexp) (value self sexp) sexp sexp sexp))
((value ctx sexp) (value self sexp) int sockaddr int))
;;> Create an endpoint for communication.

4
opcodes.c
View file

@ -1,8 +1,8 @@
#define _I(n) sexp_make_fixnum(n)
#define _OP(c,o,n,m,rt,a1,a2,a3,i,s,d,f) {c, o, n, m, i, (sexp)s, d, NULL, NULL, rt, a1, a2, a3, SEXP_FALSE, f}
#define _OP(c,o,n,m,rt,a1,a2,a3,i,s,d,f) {c, o, n, m, i, (sexp)s, d, NULL, NULL, rt, a1, a2, a3, NULL, SEXP_FALSE, f}
#if SEXP_USE_IMAGE_LOADING
#define _FN(o,n,m,rt,a1,a2,a3,s,d,f) {SEXP_OPC_FOREIGN, o, n, m, 0, (sexp)s, d, (sexp)#f, NULL, rt, a1, a2, a3, SEXP_FALSE, (sexp_proc1)f}
#define _FN(o,n,m,rt,a1,a2,a3,s,d,f) {SEXP_OPC_FOREIGN, o, n, m, 0, (sexp)s, d, (sexp)#f, NULL, rt, a1, a2, a3, NULL, SEXP_FALSE, (sexp_proc1)f}
#else
#define _FN(o,n,m,rt,a1,a2,a3,s,d,f) _OP(SEXP_OPC_FOREIGN, o, n, m, rt, a1, a2, a3, 0, s, d, (sexp_proc1)f)
#endif

2
sexp.c
View file

@ -176,7 +176,7 @@ static struct sexp_type_struct _sexp_type_specs[] = {
#if SEXP_USE_DL
{SEXP_DL, sexp_offsetof(dl, file), 1, 1, 0, 0, sexp_sizeof(dl), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Dynamic-Library", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, SEXP_FINALIZE_DL},
#endif
{SEXP_OPCODE, sexp_offsetof(opcode, name), 8+SEXP_USE_DL, 8+SEXP_USE_DL, 0, 0, sexp_sizeof(opcode), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Opcode", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
{SEXP_OPCODE, sexp_offsetof(opcode, name), 10, 10, 0, 0, sexp_sizeof(opcode), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Opcode", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
{SEXP_LAMBDA, sexp_offsetof(lambda, name), 11, 11, 0, 0, sexp_sizeof(lambda), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Lambda", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL},
{SEXP_CND, sexp_offsetof(cnd, test), 4, 4, 0, 0, sexp_sizeof(cnd), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Conditional", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL},
{SEXP_REF, sexp_offsetof(ref, name), 3, 3, 0, 0, sexp_sizeof(ref), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Reference", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL},

44
tests/foreign/typeid.c Normal file
View file

@ -0,0 +1,44 @@
#include "chibi/eval.h"
#define sexp_safe_pointer_tag(x) (sexp_pointerp(x) ? sexp_pointer_tag(x) : -1)
#define CHECK(expr) res = expr; check_exception(res, #expr)
void check_exception (sexp x, const char* expr) {
if (sexp_exceptionp(x))
fprintf(stderr, "Exception: %s => %s\n", expr,
sexp_string_data(sexp_exception_message(x)));
}
int main (int argc, char **argv) {
sexp ctx1, ctx2, res;
/* Create a context and load two modules with C types. */
ctx1 = sexp_make_eval_context(NULL, NULL, NULL, 0, 0);
sexp_load_standard_env(ctx1, NULL, SEXP_SEVEN);
CHECK(sexp_eval_string(ctx1, "(import (chibi net))", -1, NULL));
CHECK(sexp_eval_string(ctx1, "(import (chibi time))", -1, NULL));
/* Create another context and load the same modules in a different order. */
ctx2 = sexp_make_eval_context(NULL, NULL, NULL, 0, 0);
sexp_load_standard_env(ctx2, NULL, SEXP_SEVEN);
CHECK(sexp_eval_string(ctx2, "(import (chibi time))", -1, NULL));
CHECK(sexp_eval_string(ctx2, "(import (chibi net))", -1, NULL));
/* Both instances of seconds->time should return the same type, */
/* but with different tags. */
CHECK(sexp_eval_string(ctx1, "(seconds->time 0)", -1, NULL));
fprintf(stderr, "ctx1: %p (%d): %s\n", res, sexp_safe_pointer_tag(res),
sexp_string_data(sexp_object_type_name(ctx1, res)));
CHECK(sexp_eval_string(ctx2, "(seconds->time 0)", -1, NULL));
fprintf(stderr, "ctx2: %p (%d): %s\n", res, sexp_safe_pointer_tag(res),
sexp_string_data(sexp_object_type_name(ctx2, res)));
/* Cleanup. */
sexp_destroy_context(ctx1);
sexp_destroy_context(ctx2);
return 0;
}

226
tools/chibi-ffi
View file

@ -32,6 +32,7 @@
(define *funcs* '())
(define *consts* '())
(define *inits* '())
(define *tags* '())
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; type objects
@ -100,6 +101,18 @@
((symbol? (car ls)) (lp (cddr ls) res))
(else (lp (cdr ls) (cons (car ls) res))))))
(define (type-field-type type field)
(cond
((assq (type-base (parse-type type)) *types*)
=> (lambda (x)
(let lp ((ls (struct-fields (cdr x))))
(cond
((null? ls) #f)
((eq? field (caar ls)) (cadar ls))
(else (lp (cdr ls)))))))
(else
#f)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; type predicates
@ -266,6 +279,14 @@
(thunk)
(current-output-port old-out)))))
(define (warn msg . args)
(let ((err (current-error-port)))
(display "WARNING: " err)
(display msg err)
(if (pair? args) (display ":" err))
(for-each (lambda (x) (display " " err) (write x err)) args)
(newline err)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; naming
@ -290,7 +311,7 @@
(string-append "sexp_" (mangle sym) "_stub"))
(define (type-id-name sym)
(string-append "sexp_" (mangle sym) "_type_t"))
(string-append "sexp_" (mangle sym) "_type_tag"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; .stub file interface
@ -327,7 +348,8 @@
`((,(cadr expr)
,@(parse-struct-like (cddr expr)))
,@*types*))
`(cat "\nstatic sexp " ,(type-id-name (cadr expr)) ";\n"))))
(set! *tags* `(,(type-id-name (cadr expr)) ,@*tags*))
#f)))
(define-syntax define-c-struct
(er-macro-transformer
@ -365,6 +387,75 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; C code generation
(define (type-predicate type)
(let ((base (type-base (parse-type type))))
(cond
((int-type? base) "sexp_exact_integerp")
((float-type? base) "sexp_flonump")
((string-type? base) "sexp_stringp")
((eq? base 'char) "sexp_charp")
((eq? base 'boolean) "sexp_booleanp")
((eq? base 'port) "sexp_portp")
((eq? base 'input-port) "sexp_iportp")
((eq? base 'output-port) "sexp_oportp")
(else #f))))
(define (type-name type)
(let ((base (type-base (parse-type type))))
(cond
((int-type? base) "integer")
((float-type? base) "flonum")
((eq? 'boolean base) "int")
(else base))))
(define (type-id-number type . o)
(let ((base (type-base type)))
(cond
((int-type? base) "SEXP_FIXNUM")
((float-type? base) "SEXP_FLONUM")
((string-type? base) "SEXP_STRING")
((eq? base 'char) "SEXP_CHAR")
((eq? base 'boolean) "SEXP_BOOLEAN")
((eq? base 'string) "SEXP_STRING")
((eq? base 'symbol) "SEXP_SYMBOL")
((eq? base 'pair) "SEXP_PAIR")
((eq? base 'port) "SEXP_IPORT")
((eq? base 'input-port) "SEXP_IPORT")
((eq? base 'output-port) "SEXP_OPORT")
((void-pointer-type? type) "SEXP_CPOINTER")
((assq base *types*)
;; (string-append "sexp_type_tag(" (type-id-name base) ")")
(let ((i (type-index type)))
(cond
((not i)
;;(warn "type-id-number on unknown arg" type)
(if (and (pair? o) (car o))
"sexp_unbox_fixnum(sexp_opcode_return_type(self))"
(string-append "sexp_type_tag(" (type-id-name base) ")")))
((< i 3)
(string-append
"sexp_unbox_fixnum(sexp_opcode_arg"
(number->string (+ i 1)) "_type(self))"))
(else
(string-append
"sexp_unbox_fixnum(sexp_vector_ref(sexp_opcode_argn_type(self), "
(number->string (- i 3)) "))")))))
(else "SEXP_OBJECT"))))
(define (type-id-value type . o)
(cond
((eq? 'void (type-base type))
"SEXP_VOID")
(else
(string-append "sexp_make_fixnum(" (apply type-id-number type o) ")"))))
(define (type-id-init-value type)
(cond
((assq (type-base type) *types*)
(string-append "sexp_make_fixnum(sexp_type_tag(" (type-id-name (type-base type)) "))"))
(else
(type-id-value type))))
(define (c->scheme-converter type val . o)
(let ((base (type-base type)))
(cond
@ -404,7 +495,8 @@
(cat "sexp_make_cpointer(ctx, "
(if void*?
"SEXP_CPOINTER"
(string-append "sexp_type_tag(" (type-id-name base) ")"))
;;(string-append "sexp_type_tag(" (type-id-name base) ")")
(type-id-number type #t))
", "
val ", " (or (and (pair? o) (car o)) "SEXP_FALSE") ", "
(if (or (type-free? type)
@ -455,27 +547,6 @@
(else
(error "unknown type" base))))))))
(define (type-predicate type)
(let ((base (type-base (parse-type type))))
(cond
((int-type? base) "sexp_exact_integerp")
((float-type? base) "sexp_flonump")
((string-type? base) "sexp_stringp")
((eq? base 'char) "sexp_charp")
((eq? base 'boolean) "sexp_booleanp")
((eq? base 'port) "sexp_portp")
((eq? base 'input-port) "sexp_iportp")
((eq? base 'output-port) "sexp_oportp")
(else #f))))
(define (type-name type)
(let ((base (type-base (parse-type type))))
(cond
((int-type? base) "integer")
((float-type? base) "flonum")
((eq? 'boolean base) "int")
(else base))))
(define (base-type-c-name base)
(case base
((string env-string non-null-string) "char*")
@ -515,29 +586,13 @@
" && (sexp_pointer_tag(" arg ") == "
(if (void-pointer-type? type)
"SEXP_CPOINTER"
(string-append "sexp_type_tag(" (type-id-name base) ")"))
(type-id-number type))
"))"
(lambda () (if (type-null? type) (cat " || sexp_not(" arg "))")))))
(else
(display "WARNING: don't know how to check: " (current-error-port))
(write type (current-error-port))
(newline (current-error-port))
(warn "don't know how to check" type)
(cat "1")))))
(define (type-id-number type)
(let ((base (type-base type)))
(cond
((int-type? base) "SEXP_FIXNUM")
((float-type? base) "SEXP_FLONUM")
((string-type? base) "SEXP_STRING")
((eq? base 'char) "SEXP_CHAR")
((eq? base 'boolean) "SEXP_BOOLEAN")
((eq? base 'port) "SEXP_IPORT")
((eq? base 'input-port) "SEXP_IPORT")
((eq? base 'output-port) "SEXP_OPORT")
((void-pointer-type? type) "SEXP_CPOINTER")
(else (string-append "sexp_type_tag(" (type-id-name base) ")")))))
(define (write-validator arg type)
(let* ((type (parse-type type))
(array (type-array type))
@ -577,9 +632,7 @@
((string-type? type)
(write-validator arg 'string))
(else
(display "WARNING: don't know how to validate: " (current-error-port))
(write type (current-error-port))
(newline (current-error-port))))))
(warn "don't know how to validate" type)))))
(define (write-parameters args)
(lambda () (for-each (lambda (a) (cat ", sexp arg" (type-index a))) args)))
@ -982,6 +1035,8 @@
(cat "\"current-output-port\""))
((equal? value '(current-error-port))
(cat "\"current-error-port\""))
((equal? value 'NULL)
(cat "SEXP_FALSE"))
(else
(c->scheme-converter x value))))))
@ -989,7 +1044,8 @@
(let ((default (and (pair? (func-scheme-args func))
(type-default? (car (reverse (func-scheme-args func))))
(car (reverse (func-scheme-args func))))))
(cat (if default
(cat " op = "
(if default
(if (parameter-default? (type-value default))
"sexp_define_foreign_param(ctx, env, "
"sexp_define_foreign_opt(ctx, env, ")
@ -1000,7 +1056,36 @@
(func-stub-name func)
(if default ", " "")
(if default (write-default default) "")
");\n")))
");\n"
(cond
((and (pair? (func-c-args func))
(any (lambda (a) (not (eq? 'sexp (type-base a))))
(func-c-args func)))
(lambda ()
(cat
" if (sexp_opcodep(op)) {\n"
" sexp_opcode_return_type(op) = "
(type-id-init-value (func-ret-type func)) ";\n"
(lambda ()
(do ((ls (func-c-args func) (cdr ls))
(i 1 (+ i 1)))
((null? ls))
(cond
((<= i 3)
(cat " sexp_opcode_arg" i "_type(op) = "
(type-id-init-value (car ls)) ";\n"))
(else
(if (= i 4)
(cat " sexp_opcode_argn_type(op) = "
"sexp_make_vector(ctx, sexp_make_fixnum("
(- i 3) "),"
" sexp_make_fixnum(SEXP_OBJECT));\n"))
(cat " sexp_vector_set(sexp_opcode_argn_type(op), "
"sexp_make_fixnum(" (- i 4) "), "
(type-id-init-value (car ls)) ");\n")))))
" }\n")))
(else
"")))))
(define (write-type type)
(let ((name (car type))
@ -1029,7 +1114,7 @@
(define (write-type-getter type name field)
(cat "static sexp " (type-getter-name type name field)
" (sexp ctx, sexp self, sexp_sint_t n, sexp x) {\n"
(lambda () (write-validator "x" name))
(lambda () (write-validator "x" (parse-type name 0)))
" return "
(lambda ()
(c->scheme-converter
@ -1075,8 +1160,8 @@
(define (write-type-setter type name field)
(cat "static sexp " (type-setter-name type name field)
" (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp v) {\n"
(lambda () (write-validator "x" name))
(lambda () (write-validator "v" (car field)))
(lambda () (write-validator "x" (parse-type name 0)))
(lambda () (write-validator "v" (parse-type (car field) 1)))
(write-type-setter-assignment
type name field
(string-append "((" (x->string (or (type-struct-type name) ""))
@ -1113,16 +1198,22 @@
(cat ", sexp arg" i)
(lp (cdr ls) (+ i 1))))))
") {\n"
" " (or (type-struct-type name) "") " " (type-name name) " *r;\n"
" " (or (type-struct-type name) "")
" " (type-name name) " *r;\n"
" sexp_gc_var1(res);\n"
" sexp_gc_preserve1(ctx, res);\n"
;; " res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer) + sizeof(struct " (type-name name) "), "
;; TODO: support heap-managed allocations
;; " res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer)"
;; " + sizeof(struct " (type-name name) "), "
;; (type-id-name name)
;; ");\n"
;; " r = sexp_cpointer_value(res) = sexp_cpointer_body(res);\n"
" res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer), sexp_type_tag("
(type-id-name name)
"));\n"
;; " r = sexp_cpointer_value(res) = "
;; "sexp_cpointer_body(res);\n"
;; " res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer), sexp_type_tag("
;; (type-id-name name)
;; "));\n"
" res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer), "
"sexp_unbox_fixnum(sexp_opcode_return_type(self)));\n"
" r = sexp_cpointer_value(res) = calloc(1, sizeof("
(or (type-struct-type name) "") " " (type-name name) "));\n"
" memset(r, 0, sizeof("
@ -1149,7 +1240,16 @@
" return res;\n"
"}\n\n")
(set! *funcs*
(cons (parse-func `(void ,make ,args)) *funcs*))))))
(cons (parse-func
`(,name ,make
,(map (lambda (a)
(cond
((find (lambda (x) (eq? a (cadr x)))
(struct-fields type))
=> car)
(else 'sexp)))
args)))
*funcs*))))))
;; write field accessors
(for-each
(lambda (field)
@ -1213,16 +1313,20 @@
(for-each write-func *funcs*)
(for-each write-type-funcs *types*)
(cat "sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char* version, sexp_abi_identifier_t abi) {\n"
" sexp_gc_var2(name, tmp);\n"
(lambda ()
(for-each
(lambda (t) (cat " sexp " t ";\n"))
*tags*))
" sexp_gc_var3(name, tmp, op);\n"
" if (!(sexp_version_compatible(ctx, version, sexp_version)\n"
" && sexp_abi_compatible(ctx, abi, SEXP_ABI_IDENTIFIER)))\n"
" return sexp_global(ctx, SEXP_G_ABI_ERROR);"
" sexp_gc_preserve2(ctx, name, tmp);\n")
" return sexp_global(ctx, SEXP_G_ABI_ERROR);\n"
" sexp_gc_preserve3(ctx, name, tmp, op);\n")
(for-each write-const *consts*)
(for-each write-type *types*)
(for-each write-func-binding *funcs*)
(for-each (lambda (x) (cat " " x "\n")) (reverse *inits*))
(cat " sexp_gc_release2(ctx);\n"
(cat " sexp_gc_release3(ctx);\n"
" return SEXP_VOID;\n"
"}\n\n"))