diff --git a/pkgs/base/info.rkt b/pkgs/base/info.rkt index bdeb18ef2b..95f8dccdb2 100644 --- a/pkgs/base/info.rkt +++ b/pkgs/base/info.rkt @@ -14,7 +14,7 @@ ;; In the Racket source repo, this version should change only when ;; "racket_version.h" changes: -(define version "7.9.0.16") +(define version "7.9.0.17") (define deps `("racket-lib" ["racket" #:version ,version])) diff --git a/pkgs/racket-doc/scribblings/foreign/unexported.scrbl b/pkgs/racket-doc/scribblings/foreign/unexported.scrbl index 3b9d38853a..d32182bacd 100644 --- a/pkgs/racket-doc/scribblings/foreign/unexported.scrbl +++ b/pkgs/racket-doc/scribblings/foreign/unexported.scrbl @@ -44,10 +44,11 @@ cstructs, and another ctype for user-defined ctypes.} @defproc[(ffi-call [ptr cpointer?] [in-types (listof ctype?)] [out-type ctype?] [abi (or/c #f 'default 'stdcall 'sysv) #f] - [save-errno? any/c] - [orig-place? any/c] + [save-errno? any/c #f] + [orig-place? any/c #f] [lock-name (or/c #f string?) #f] - [blocking? any/c #f]) + [blocking? any/c #f] + [varargs-after (or/c #f positive-exact-integer?) #f]) procedure?]{ The primitive mechanism that creates Racket @tech{callout} values for @@ -57,10 +58,11 @@ values are marshaled.} @defproc[(ffi-call-maker [in-types (listof ctype?)] [out-type ctype?] [abi (or/c #f 'default 'stdcall 'sysv) #f] - [save-errno? any/c] - [orig-place? any/c] + [save-errno? any/c #f] + [orig-place? any/c #f] [lock-name (or/c #f string?) #f] - [blocking? any/c #f]) + [blocking? any/c #f] + [varargs-after (or/c #f positive-exact-integer?) #f]) (cpointer . -> . procedure?)]{ A curried variant of @racket[ffi-call] that takes the foreign-procedure pointer @@ -70,7 +72,8 @@ separately.} @defproc[(ffi-callback [proc procedure?] [in-types any/c] [out-type any/c] [abi (or/c #f 'default 'stdcall 'sysv) #f] [atomic? any/c #f] - [async-apply (or/c #f ((-> any) . -> . any)) #f]) + [async-apply (or/c #f ((-> any) . -> . any) box?) #f] + [varargs-after (or/c #f positive-exact-integer?) #f]) ffi-callback?]{ The symmetric counterpart of @racket[ffi-call]. It receives a Racket @@ -80,7 +83,8 @@ C pointer.} @defproc[(ffi-callback-maker [in-types any/c] [out-type any/c] [abi (or/c #f 'default 'stdcall 'sysv) #f] [atomic? any/c #f] - [async-apply (or/c #f ((-> any) . -> . any)) #f]) + [async-apply (or/c #f ((-> any) . -> . any) box?) #f] + [varargs-after (or/c #f positive-exact-integer?) #f]) (procedure? . -> . ffi-callback?)]{ A curried variant of @racket[ffi-callback] that takes the callback procedure diff --git a/racket/collects/ffi/unsafe.rkt b/racket/collects/ffi/unsafe.rkt index 4536349412..530b01dec6 100644 --- a/racket/collects/ffi/unsafe.rkt +++ b/racket/collects/ffi/unsafe.rkt @@ -534,8 +534,8 @@ ;; for internal use (define held-callbacks (make-weak-hasheq)) (define (_cprocedure* itypes otype abi varargs-after wrapper keep atomic? orig-place? blocking? async-apply errno lock-name) - (define make-ffi-callback (delay/cas (ffi-callback-maker itypes otype abi varargs-after atomic? async-apply))) - (define make-ffi-call (delay/cas (ffi-call-maker itypes otype abi varargs-after errno orig-place? lock-name blocking?))) + (define make-ffi-callback (delay/cas (ffi-callback-maker itypes otype abi atomic? async-apply varargs-after))) + (define make-ffi-call (delay/cas (ffi-call-maker itypes otype abi errno orig-place? lock-name blocking? varargs-after))) (define-syntax-rule (make-it wrap) (make-ctype _fpointer (lambda (x) diff --git a/racket/src/bc/foreign/foreign.c b/racket/src/bc/foreign/foreign.c index 04edc215ae..adeacefe52 100644 --- a/racket/src/bc/foreign/foreign.c +++ b/racket/src/bc/foreign/foreign.c @@ -3910,36 +3910,38 @@ static Scheme_Object *ffi_call_or_curry(const char *who, int curry, int argc, Sc rtype = CTYPE_ARG_PRIMTYPE(base); abi = GET_ABI(who, ARGPOS(3)); if (argc > ARGPOS(4)) { - varargs_after = extract_varargs_after(who, argc, argv, ARGPOS(4), nargs); - } else - varargs_after = -1; - if (argc > ARGPOS(5)) { save_errno = -1; - if (SCHEME_FALSEP(argv[ARGPOS(5)])) + if (SCHEME_FALSEP(argv[ARGPOS(4)])) save_errno = 0; - else if (SCHEME_SYMBOLP(argv[ARGPOS(5)]) - && !SCHEME_SYM_WEIRDP(argv[ARGPOS(5)])) { - if (!strcmp(SCHEME_SYM_VAL(argv[ARGPOS(5)]), "posix")) + else if (SCHEME_SYMBOLP(argv[ARGPOS(4)]) + && !SCHEME_SYM_WEIRDP(argv[ARGPOS(4)])) { + if (!strcmp(SCHEME_SYM_VAL(argv[ARGPOS(4)]), "posix")) save_errno = 1; - else if (!strcmp(SCHEME_SYM_VAL(argv[ARGPOS(5)]), "windows")) + else if (!strcmp(SCHEME_SYM_VAL(argv[ARGPOS(4)]), "windows")) save_errno = 2; } if (save_errno == -1) { - scheme_wrong_contract(who, "(or/c 'posix 'windows #f)", ARGPOS(5), argc, argv); + scheme_wrong_contract(who, "(or/c 'posix 'windows #f)", ARGPOS(4), argc, argv); } } else save_errno = 0; # if defined(MZ_USE_PLACES) && !defined(MZ_USE_FFIPOLL) - if (argc > ARGPOS(6)) orig_place = SCHEME_TRUEP(argv[ARGPOS(6)]); + if (argc > ARGPOS(5)) orig_place = SCHEME_TRUEP(argv[ARGPOS(5)]); else orig_place = 0; # endif /* defined(MZ_USE_PLACES) && !defined(MZ_USE_FFIPOLL) */ - if (argc > ARGPOS(7)) { - if (!SCHEME_FALSEP(argv[ARGPOS(7)])) { - if (!SCHEME_CHAR_STRINGP(argv[ARGPOS(7)])) - scheme_wrong_contract(who, "(or/c string? #f)", ARGPOS(7), argc, argv); - lock = name_to_ffi_lock(scheme_char_string_to_byte_string(argv[ARGPOS(7)])); + if (argc > ARGPOS(6)) { + if (!SCHEME_FALSEP(argv[ARGPOS(6)])) { + if (!SCHEME_CHAR_STRINGP(argv[ARGPOS(6)])) + scheme_wrong_contract(who, "(or/c string? #f)", ARGPOS(6), argc, argv); + lock = name_to_ffi_lock(scheme_char_string_to_byte_string(argv[ARGPOS(6)])); } } + /* ARGPOS(7) is `blocking?`, but we don't use that */ + if (argc > ARGPOS(8)) { + varargs_after = extract_varargs_after(who, argc, argv, ARGPOS(8), nargs); + } else + varargs_after = -1; + if (cp && SCHEME_FFIOBJP(cp)) name = scheme_make_byte_string(((ffi_obj_struct*)(cp))->name); else @@ -4347,16 +4349,16 @@ static Scheme_Object *ffi_callback_or_curry(const char *who, int curry, int argc scheme_wrong_contract(who, "ctype?", ARGPOS(2), argc, argv); rtype = CTYPE_ARG_PRIMTYPE(base); abi = GET_ABI(who, ARGPOS(3)); - if (argc > ARGPOS(4)) - varargs_after = extract_varargs_after(who, argc, argv, ARGPOS(4), nargs); + is_atomic = ((argc > ARGPOS(4)) && SCHEME_TRUEP(argv[ARGPOS(4)])); + sync = (is_atomic ? scheme_true : NULL); + if ((argc > ARGPOS(5)) + && !SCHEME_BOXP(argv[ARGPOS(5)]) + && !scheme_check_proc_arity2(NULL, 1, ARGPOS(5), argc, argv, 1)) + scheme_wrong_contract(who, "(or/c #f (procedure-arity-includes/c 0) box?)", ARGPOS(5), argc, argv); + if (argc > ARGPOS(6)) + varargs_after = extract_varargs_after(who, argc, argv, ARGPOS(6), nargs); else varargs_after = -1; - is_atomic = ((argc > ARGPOS(5)) && SCHEME_TRUEP(argv[ARGPOS(5)])); - sync = (is_atomic ? scheme_true : NULL); - if ((argc > ARGPOS(6)) - && !SCHEME_BOXP(argv[ARGPOS(6)]) - && !scheme_check_proc_arity2(NULL, 1, ARGPOS(6), argc, argv, 1)) - scheme_wrong_contract(who, "(or/c #f (procedure-arity-includes/c 0) box?)", ARGPOS(6), argc, argv); if (curry) { /* all checks are done */ @@ -4402,6 +4404,7 @@ static Scheme_Object *ffi_callback_or_curry(const char *who, int curry, int argc do_callback = ffi_queue_callback; } else do_callback = ffi_do_callback; + /* malloc space for everything needed, so a single free gets rid of this */ cl_cif_args = scheme_malloc_code(sizeof(closure_and_cif) + nargs*sizeof(ffi_cif*)); scheme_thread_code_start_write(); diff --git a/racket/src/bc/foreign/foreign.rktc b/racket/src/bc/foreign/foreign.rktc index 2d7289be01..f2fa9c1954 100755 --- a/racket/src/bc/foreign/foreign.rktc +++ b/racket/src/bc/foreign/foreign.rktc @@ -3077,36 +3077,38 @@ static Scheme_Object *ffi_call_or_curry(const char *who, int curry, int argc, Sc rtype = CTYPE_ARG_PRIMTYPE(base); abi = GET_ABI(who, ARGPOS(3)); if (argc > ARGPOS(4)) { - varargs_after = extract_varargs_after(who, argc, argv, ARGPOS(4), nargs); - } else - varargs_after = -1; - if (argc > ARGPOS(5)) { save_errno = -1; - if (SCHEME_FALSEP(argv[ARGPOS(5)])) + if (SCHEME_FALSEP(argv[ARGPOS(4)])) save_errno = 0; - else if (SCHEME_SYMBOLP(argv[ARGPOS(5)]) - && !SCHEME_SYM_WEIRDP(argv[ARGPOS(5)])) { - if (!strcmp(SCHEME_SYM_VAL(argv[ARGPOS(5)]), "posix")) + else if (SCHEME_SYMBOLP(argv[ARGPOS(4)]) + && !SCHEME_SYM_WEIRDP(argv[ARGPOS(4)])) { + if (!strcmp(SCHEME_SYM_VAL(argv[ARGPOS(4)]), "posix")) save_errno = 1; - else if (!strcmp(SCHEME_SYM_VAL(argv[ARGPOS(5)]), "windows")) + else if (!strcmp(SCHEME_SYM_VAL(argv[ARGPOS(4)]), "windows")) save_errno = 2; } if (save_errno == -1) { - scheme_wrong_contract(who, "(or/c 'posix 'windows #f)", ARGPOS(5), argc, argv); + scheme_wrong_contract(who, "(or/c 'posix 'windows #f)", ARGPOS(4), argc, argv); } } else save_errno = 0; @@IF{defined(MZ_USE_PLACES) && !defined(MZ_USE_FFIPOLL)}{ - if (argc > ARGPOS(6)) orig_place = SCHEME_TRUEP(argv[ARGPOS(6)]); + if (argc > ARGPOS(5)) orig_place = SCHEME_TRUEP(argv[ARGPOS(5)]); else orig_place = 0; } - if (argc > ARGPOS(7)) { - if (!SCHEME_FALSEP(argv[ARGPOS(7)])) { - if (!SCHEME_CHAR_STRINGP(argv[ARGPOS(7)])) - scheme_wrong_contract(who, "(or/c string? #f)", ARGPOS(7), argc, argv); - lock = name_to_ffi_lock(scheme_char_string_to_byte_string(argv[ARGPOS(7)])); + if (argc > ARGPOS(6)) { + if (!SCHEME_FALSEP(argv[ARGPOS(6)])) { + if (!SCHEME_CHAR_STRINGP(argv[ARGPOS(6)])) + scheme_wrong_contract(who, "(or/c string? #f)", ARGPOS(6), argc, argv); + lock = name_to_ffi_lock(scheme_char_string_to_byte_string(argv[ARGPOS(6)])); } } + /* ARGPOS(7) is `blocking?`, but we don't use that */ + if (argc > ARGPOS(8)) { + varargs_after = extract_varargs_after(who, argc, argv, ARGPOS(8), nargs); + } else + varargs_after = -1; + if (cp && SCHEME_FFIOBJP(cp)) name = scheme_make_byte_string(((ffi_obj_struct*)(cp))->name); else @@ -3504,16 +3506,16 @@ static Scheme_Object *ffi_callback_or_curry(const char *who, int curry, int argc scheme_wrong_contract(who, "ctype?", ARGPOS(2), argc, argv); rtype = CTYPE_ARG_PRIMTYPE(base); abi = GET_ABI(who, ARGPOS(3)); - if (argc > ARGPOS(4)) - varargs_after = extract_varargs_after(who, argc, argv, ARGPOS(4), nargs); + is_atomic = ((argc > ARGPOS(4)) && SCHEME_TRUEP(argv[ARGPOS(4)])); + sync = (is_atomic ? scheme_true : NULL); + if ((argc > ARGPOS(5)) + && !SCHEME_BOXP(argv[ARGPOS(5)]) + && !scheme_check_proc_arity2(NULL, 1, ARGPOS(5), argc, argv, 1)) + scheme_wrong_contract(who, "(or/c #f (procedure-arity-includes/c 0) box?)", ARGPOS(5), argc, argv); + if (argc > ARGPOS(6)) + varargs_after = extract_varargs_after(who, argc, argv, ARGPOS(6), nargs); else varargs_after = -1; - is_atomic = ((argc > ARGPOS(5)) && SCHEME_TRUEP(argv[ARGPOS(5)])); - sync = (is_atomic ? scheme_true : NULL); - if ((argc > ARGPOS(6)) - && !SCHEME_BOXP(argv[ARGPOS(6)]) - && !scheme_check_proc_arity2(NULL, 1, ARGPOS(6), argc, argv, 1)) - scheme_wrong_contract(who, "(or/c #f (procedure-arity-includes/c 0) box?)", ARGPOS(6), argc, argv); if (curry) { /* all checks are done */ @@ -3559,6 +3561,7 @@ static Scheme_Object *ffi_callback_or_curry(const char *who, int curry, int argc do_callback = ffi_queue_callback; } else do_callback = ffi_do_callback; + /* malloc space for everything needed, so a single free gets rid of this */ cl_cif_args = scheme_malloc_code(sizeof(closure_and_cif) + nargs*sizeof(ffi_cif*)); scheme_thread_code_start_write(); diff --git a/racket/src/cs/compile-file.ss b/racket/src/cs/compile-file.ss index b4df086e1f..3724078de2 100644 --- a/racket/src/cs/compile-file.ss +++ b/racket/src/cs/compile-file.ss @@ -108,7 +108,7 @@ (when xpatch-path (load xpatch-path)) -(time +(define (compile-it) (cond [whole-program? (unless (= 1 (length deps)) @@ -150,4 +150,6 @@ ;; Normal mode (compile-file src dest)]))])) +(time (compile-it)) + (printf " ~a bytes peak memory use\n" (maximum-memory-bytes)) diff --git a/racket/src/cs/rumble/foreign.ss b/racket/src/cs/rumble/foreign.ss index baea34c754..a5a11a78b4 100644 --- a/racket/src/cs/rumble/foreign.ss +++ b/racket/src/cs/rumble/foreign.ss @@ -1517,15 +1517,15 @@ (ffi-call p in-types out-type #f #f #f)] [(p in-types out-type abi) (ffi-call p in-types out-type abi #f #f #f)] - [(p in-types out-type abi varargs-after) - (ffi-call p in-types out-type abi varargs-after #f #f)] - [(p in-types out-type abi varargs-after save-errno) - (ffi-call p in-types out-type abi varargs-after save-errno #f)] - [(p in-types out-type abi varargs-after save-errno orig-place?) - (ffi-call p in-types out-type abi varargs-after save-errno orig-place? #f)] - [(p in-types out-type abi varargs-after save-errno orig-place? lock-name) - (ffi-call p in-types out-type abi varargs-after save-errno orig-place? lock-name #f)] - [(p in-types out-type abi varargs-after save-errno orig-place? lock-name blocking?) + [(p in-types out-type abi save-errno) + (ffi-call p in-types out-type abi save-errno #f #f)] + [(p in-types out-type abi save-errno orig-place?) + (ffi-call p in-types out-type abi save-errno orig-place? #f #f)] + [(p in-types out-type abi save-errno orig-place? lock-name) + (ffi-call p in-types out-type abi save-errno orig-place? lock-name #f #f)] + [(p in-types out-type abi save-errno orig-place? lock-name blocking?) + (ffi-call p in-types out-type abi save-errno orig-place? lock-name blocking? #f)] + [(p in-types out-type abi save-errno orig-place? lock-name blocking? varargs-after) (check who cpointer? p) (check-ffi-call who in-types out-type abi varargs-after save-errno lock-name) ((ffi-call/callable #t in-types out-type abi varargs-after save-errno lock-name blocking? orig-place? #f #f) p)])) @@ -1536,15 +1536,15 @@ (ffi-call-maker in-types out-type #f #f #f #f)] [(in-types out-type abi) (ffi-call-maker in-types out-type abi #f #f #f)] - [(in-types out-type abi varargs-after) - (ffi-call-maker in-types out-type abi varargs-after #f #f)] - [(in-types out-type abi varargs-after save-errno) - (ffi-call-maker in-types out-type abi varargs-after save-errno #f)] - [(in-types out-type abi varargs-after save-errno orig-place?) - (ffi-call-maker in-types out-type abi varargs-after save-errno orig-place? #f)] - [(in-types out-type abi varargs-after save-errno orig-place? lock-name) - (ffi-call-maker in-types out-type abi varargs-after save-errno orig-place? lock-name #f)] - [(in-types out-type abi varargs-after save-errno orig-place? lock-name blocking?) + [(in-types out-type abi save-errno) + (ffi-call-maker in-types out-type abi save-errno #f #f)] + [(in-types out-type abi save-errno orig-place?) + (ffi-call-maker in-types out-type abi save-errno orig-place? #f #f)] + [(in-types out-type abi save-errno orig-place? lock-name) + (ffi-call-maker in-types out-type abi save-errno orig-place? lock-name #f #f)] + [(in-types out-type abi save-errno orig-place? lock-name blocking?) + (ffi-call-maker in-types out-type abi save-errno orig-place? lock-name blocking? #f)] + [(in-types out-type abi save-errno orig-place? lock-name blocking? varargs-after) (check-ffi-call who in-types out-type abi varargs-after save-errno lock-name) (ffi-call/callable #t in-types out-type abi varargs-after save-errno lock-name blocking? orig-place? #f #f)])) @@ -1940,11 +1940,11 @@ (ffi-callback proc in-types out-type #f #f #f #f)] [(proc in-types out-type abi) (ffi-callback proc in-types out-type abi #f #f #f)] - [(proc in-types out-type abi varargs-after) - (ffi-callback proc in-types out-type abi varargs-after #f #f)] - [(proc in-types out-type abi varargs-after atomic?) - (ffi-callback proc in-types out-type abi varargs-after atomic? #f)] - [(proc in-types out-type abi varargs-after atomic? async-apply) + [(proc in-types out-type abi atomic?) + (ffi-callback proc in-types out-type abi atomic? #f #f)] + [(proc in-types out-type abi atomic? async-apply) + (ffi-callback proc in-types out-type abi atomic? #f)] + [(proc in-types out-type abi atomic? async-apply varargs-after) (check who procedure? proc) (check-ffi-callback who in-types out-type abi varargs-after async-apply) ((ffi-callback-maker* in-types out-type abi varargs-after atomic? async-apply) proc)])) @@ -1955,11 +1955,11 @@ (ffi-callback-maker in-types out-type #f #f #f #f)] [(in-types out-type abi) (ffi-callback-maker in-types out-type abi #f #f #f)] - [(in-types out-type abi varargs-after) - (ffi-callback-maker in-types out-type abi varargs-after #f #f)] - [(in-types out-type abi varargs-after atomic?) - (ffi-callback-maker in-types out-type abi varargs-after atomic? #f)] - [(in-types out-type abi varargs-after atomic? async-apply) + [(in-types out-type abi atomic?) + (ffi-callback-maker in-types out-type abi atomic? #f #f)] + [(in-types out-type abi atomic? async-apply) + (ffi-callback-maker in-types out-type abi atomic? async-apply #f)] + [(in-types out-type abi atomic? async-apply varargs-after) (check-ffi-callback who in-types out-type abi varargs-after async-apply) (ffi-callback-maker* in-types out-type abi varargs-after atomic? async-apply)])) diff --git a/racket/src/version/racket_version.h b/racket/src/version/racket_version.h index 9d71044af3..3c31429aac 100644 --- a/racket/src/version/racket_version.h +++ b/racket/src/version/racket_version.h @@ -16,7 +16,7 @@ #define MZSCHEME_VERSION_X 7 #define MZSCHEME_VERSION_Y 9 #define MZSCHEME_VERSION_Z 0 -#define MZSCHEME_VERSION_W 16 +#define MZSCHEME_VERSION_W 17 /* A level of indirection makes `#` work as needed: */ #define AS_a_STR_HELPER(x) #x