diff --git a/collects/ffi/unsafe.rkt b/collects/ffi/unsafe.rkt index 2e8bc251d9..b4400fdd14 100644 --- a/collects/ffi/unsafe.rkt +++ b/collects/ffi/unsafe.rkt @@ -441,13 +441,14 @@ #:wrapper [wrapper #f] #:keep [keep #t] #:atomic? [atomic? #f] - #:async-apply [async-apply #f] + #:in-original-place? [orig-place? #f] + #:async-apply [async-apply #f] #:save-errno [errno #f]) - (_cprocedure* itypes otype abi wrapper keep atomic? async-apply errno)) + (_cprocedure* itypes otype abi wrapper keep atomic? orig-place? async-apply errno)) ;; for internal use (define held-callbacks (make-weak-hasheq)) -(define (_cprocedure* itypes otype abi wrapper keep atomic? async-apply errno) +(define (_cprocedure* itypes otype abi wrapper keep atomic? orig-place? async-apply errno) (define-syntax-rule (make-it wrap) (make-ctype _fpointer (lambda (x) @@ -460,7 +461,7 @@ (if (or (null? x) (pair? x)) (cons cb x) cb)))] [(procedure? keep) (keep cb)]) cb))) - (lambda (x) (and x (wrap (ffi-call x itypes otype abi errno)))))) + (lambda (x) (and x (wrap (ffi-call x itypes otype abi errno orig-place?)))))) (if wrapper (make-it wrapper) (make-it begin))) ;; Syntax for the special _fun type: @@ -483,7 +484,8 @@ (provide _fun) (define-for-syntax _fun-keywords - `([#:abi ,#'#f] [#:keep ,#'#t] [#:atomic? ,#'#f] [#:async-apply ,#'#f] [#:save-errno ,#'#f])) + `([#:abi ,#'#f] [#:keep ,#'#t] [#:atomic? ,#'#f] [#:in-original-place? ,#'#f] + [#:async-apply ,#'#f] [#:save-errno ,#'#f])) (define-syntax (_fun stx) (define (err msg . sub) (apply raise-syntax-error '_fun msg stx sub)) (define xs #f) @@ -632,6 +634,7 @@ #,wrapper #,(kwd-ref '#:keep) #,(kwd-ref '#:atomic?) + #,(kwd-ref '#:in-original-place?) #,(kwd-ref '#:async-apply) #,(kwd-ref '#:save-errno)))]) (if (or (caddr output) input-names (ormap caddr inputs) diff --git a/collects/racket/draw/unsafe/pango.rkt b/collects/racket/draw/unsafe/pango.rkt index 00496e72c5..eb657a63c2 100644 --- a/collects/racket/draw/unsafe/pango.rkt +++ b/collects/racket/draw/unsafe/pango.rkt @@ -114,10 +114,19 @@ [glyphs _PangoGlyphString-pointer])) (provide (struct-out PangoGlyphItem)) +;; As of Pango 1.28, Pango is not thread-safe at the C level, which +;; means that it isn't place-safe in Racket. Also, for some reason, +;; when parts of Pango are initialized in a non-main place under +;; Windows, then font operations start to fail when that place exits. +;; Run all Pango calls in the original place, which synchronizes them +;; and avoids Windows problems. +(define-syntax-rule (_pfun spec ...) + (_fun #:in-original-place? #t spec ...)) + (provide g_object_unref g_free) -(define-gobj g_object_unref (_fun _pointer -> _void) +(define-gobj g_object_unref (_pfun _pointer -> _void) #:wrap (deallocator)) -(define-glib g_free (_fun _pointer -> _void) +(define-glib g_free (_pfun _pointer -> _void) #:wrap (deallocator)) ;; For working around a Win32 Pango bug (see `unref-font-map'): @@ -127,9 +136,9 @@ [qdata _pointer] [font_cache _pointer] [freed_fonts _GQueue])) -(define-glib g_queue_foreach (_fun _GQueue (_fun _pointer -> _void) _pointer -> _void)) -(define-glib g_queue_free (_fun _GQueue -> _void)) -(define-glib g_queue_new (_fun -> _GQueue)) +(define-glib g_queue_foreach (_pfun _GQueue _fpointer #;(_fun _pointer -> _void) _pointer -> _void)) +(define-glib g_queue_free (_pfun _GQueue -> _void)) +(define-glib g_queue_new (_pfun -> _GQueue)) (define (unref-font-map v) (when (eq? (system-type) 'windows) @@ -147,11 +156,11 @@ (set-PangoWin32FontMap-freed_fonts! fm (g_queue_new)))) (g_object_unref v)) -(define-pangocairo pango_cairo_font_map_get_default (_fun -> PangoFontMap)) ;; not an allocator -(define-pangocairo pango_cairo_font_map_new (_fun -> PangoFontMap) +(define-pangocairo pango_cairo_font_map_get_default (_pfun -> PangoFontMap)) ;; not an allocator +(define-pangocairo pango_cairo_font_map_new (_pfun -> PangoFontMap) #:wrap (allocator unref-font-map)) -(define-pango pango_context_new (_fun -> PangoContext) +(define-pango pango_context_new (_pfun -> PangoContext) #:wrap (allocator g_object_unref)) ;; pango_font_map_create_context() is in 1.22 and later (provide pango_font_map_create_context) @@ -159,7 +168,7 @@ (let ([c (pango_context_new)]) (pango_context_set_font_map c fm) c)) -(define-pangocairo pango_cairo_update_context (_fun _cairo_t PangoContext -> _void)) +(define-pangocairo pango_cairo_update_context (_pfun _cairo_t PangoContext -> _void)) ;; The convenince function pango_cairo_create_context() is in 1.22 and later (provide pango_cairo_create_context) @@ -169,31 +178,31 @@ (pango_cairo_update_context cr ctx) ctx)) -(define-pangocairo pango_cairo_create_layout (_fun _cairo_t -> PangoLayout) +(define-pangocairo pango_cairo_create_layout (_pfun _cairo_t -> PangoLayout) #:wrap (allocator g_object_unref)) -(define-pangocairo pango_cairo_update_layout (_fun _cairo_t PangoLayout -> _void)) -(define-pango pango_layout_set_text (_fun PangoLayout [s : _string] [_int = -1] -> _void)) -(define-pangocairo pango_cairo_show_layout (_fun _cairo_t PangoLayout -> _void)) -(define-pangocairo pango_cairo_show_layout_line (_fun _cairo_t PangoLayoutLine -> _void)) -(define-pangocairo pango_cairo_show_glyph_string (_fun _cairo_t PangoFont _PangoGlyphString-pointer -> _void)) +(define-pangocairo pango_cairo_update_layout (_pfun _cairo_t PangoLayout -> _void)) +(define-pango pango_layout_set_text (_pfun PangoLayout [s : _string] [_int = -1] -> _void)) +(define-pangocairo pango_cairo_show_layout (_pfun _cairo_t PangoLayout -> _void)) +(define-pangocairo pango_cairo_show_layout_line (_pfun _cairo_t PangoLayoutLine -> _void)) +(define-pangocairo pango_cairo_show_glyph_string (_pfun _cairo_t PangoFont _PangoGlyphString-pointer -> _void)) -(define-pango pango_layout_iter_free (_fun PangoLayoutIter -> _void) +(define-pango pango_layout_iter_free (_pfun PangoLayoutIter -> _void) #:wrap (deallocator)) -(define-pango pango_layout_get_iter (_fun PangoLayout -> PangoLayoutIter) +(define-pango pango_layout_get_iter (_pfun PangoLayout -> PangoLayoutIter) #:wrap (allocator pango_layout_iter_free)) -(define-pango pango_layout_iter_get_baseline (_fun PangoLayoutIter -> _int)) -(define-pango pango_layout_iter_next_run (_fun PangoLayoutIter -> _bool)) -(define-pango pango_layout_iter_get_run (_fun PangoLayoutIter -> (_or-null _PangoGlyphItem-pointer))) -(define-pango pango_layout_iter_get_run_readonly (_fun PangoLayoutIter -> (_or-null _PangoGlyphItem-pointer)) +(define-pango pango_layout_iter_get_baseline (_pfun PangoLayoutIter -> _int)) +(define-pango pango_layout_iter_next_run (_pfun PangoLayoutIter -> _bool)) +(define-pango pango_layout_iter_get_run (_pfun PangoLayoutIter -> (_or-null _PangoGlyphItem-pointer))) +(define-pango pango_layout_iter_get_run_readonly (_pfun PangoLayoutIter -> (_or-null _PangoGlyphItem-pointer)) #:fail (lambda () pango_layout_iter_get_run)) -(define-pango pango_layout_get_line (_fun PangoLayout _int -> PangoLayoutLine)) -(define-pango pango_layout_get_line_readonly (_fun PangoLayout _int -> PangoLayoutLine) +(define-pango pango_layout_get_line (_pfun PangoLayout _int -> PangoLayoutLine)) +(define-pango pango_layout_get_line_readonly (_pfun PangoLayout _int -> PangoLayoutLine) #:fail (lambda () pango_layout_get_line)) -(define-pango pango_layout_get_context (_fun PangoLayout -> PangoContext)) ;; not an allocator -(define-pango pango_layout_get_extents (_fun PangoLayout _pointer _PangoRectangle-pointer -> _void)) -(define-pango pango_layout_get_baseline (_fun PangoLayout -> _int) +(define-pango pango_layout_get_context (_pfun PangoLayout -> PangoContext)) ;; not an allocator +(define-pango pango_layout_get_extents (_pfun PangoLayout _pointer _PangoRectangle-pointer -> _void)) +(define-pango pango_layout_get_baseline (_pfun PangoLayout -> _int) ;; The convenince function pango_layout_get_baseline() is in 1.22 and later #:fail (lambda () (lambda (layout) @@ -201,60 +210,60 @@ (begin0 (pango_layout_iter_get_baseline iter) (pango_layout_iter_free iter)))))) -(define-pango pango_layout_get_spacing (_fun PangoLayout -> _int)) +(define-pango pango_layout_get_spacing (_pfun PangoLayout -> _int)) -(define-pango pango_layout_new (_fun PangoContext -> PangoLayout) +(define-pango pango_layout_new (_pfun PangoContext -> PangoLayout) #:wrap (allocator g_object_unref)) -(define-pangocairo pango_cairo_context_get_font_options (_fun PangoContext -> _cairo_font_options_t)) ;; not an allocator -(define-pangocairo pango_cairo_context_set_font_options (_fun PangoContext _cairo_font_options_t -> _void)) ;; makes a copy +(define-pangocairo pango_cairo_context_get_font_options (_pfun PangoContext -> _cairo_font_options_t)) ;; not an allocator +(define-pangocairo pango_cairo_context_set_font_options (_pfun PangoContext _cairo_font_options_t -> _void)) ;; makes a copy -(define-pango pango_layout_set_font_description (_fun PangoLayout PangoFontDescription -> _void)) ;; makes a copy -(define-pango pango_context_get_font_map (_fun PangoContext -> PangoFontMap)) ;; not an allocator -(define-pango pango_context_set_font_map (_fun PangoContext PangoFontMap -> _void)) -(define-pango pango_font_family_get_name (_fun PangoFontFamily -> _string)) ;; not an allocator -(define-pango pango_font_family_is_monospace (_fun PangoFontFamily -> _bool)) +(define-pango pango_layout_set_font_description (_pfun PangoLayout PangoFontDescription -> _void)) ;; makes a copy +(define-pango pango_context_get_font_map (_pfun PangoContext -> PangoFontMap)) ;; not an allocator +(define-pango pango_context_set_font_map (_pfun PangoContext PangoFontMap -> _void)) +(define-pango pango_font_family_get_name (_pfun PangoFontFamily -> _string)) ;; not an allocator +(define-pango pango_font_family_is_monospace (_pfun PangoFontFamily -> _bool)) -(define-pango pango_language_get_default (_fun -> PangoLanguage) +(define-pango pango_language_get_default (_pfun -> PangoLanguage) ;; not available before 1.16 #:fail (lambda () (lambda () #f))) -(define-pango pango_font_map_load_font (_fun PangoFontMap PangoContext PangoFontDescription -> (_or-null PangoFont))) -(define-pango pango_coverage_unref (_fun PangoCoverage -> _void) +(define-pango pango_font_map_load_font (_pfun PangoFontMap PangoContext PangoFontDescription -> (_or-null PangoFont))) +(define-pango pango_coverage_unref (_pfun PangoCoverage -> _void) #:wrap (deallocator)) -(define-pango pango_font_get_coverage (_fun PangoFont PangoLanguage -> PangoCoverage) +(define-pango pango_font_get_coverage (_pfun PangoFont PangoLanguage -> PangoCoverage) #:wrap (allocator pango_coverage_unref)) -(define-pango pango_coverage_get (_fun PangoCoverage _int -> _int)) +(define-pango pango_coverage_get (_pfun PangoCoverage _int -> _int)) -(define-pango pango_font_metrics_unref (_fun PangoFontMetrics -> _void) +(define-pango pango_font_metrics_unref (_pfun PangoFontMetrics -> _void) #:wrap (deallocator)) -(define-pango pango_font_get_metrics (_fun PangoFont (_or-null PangoLanguage) -> PangoFontMetrics) +(define-pango pango_font_get_metrics (_pfun PangoFont (_or-null PangoLanguage) -> PangoFontMetrics) #:wrap (allocator pango_font_metrics_unref)) -(define-pango pango_font_metrics_get_approximate_char_width (_fun PangoFontMetrics -> _int)) -(define-pango pango_font_metrics_get_ascent (_fun PangoFontMetrics -> _int)) -(define-pango pango_font_metrics_get_descent (_fun PangoFontMetrics -> _int)) +(define-pango pango_font_metrics_get_approximate_char_width (_pfun PangoFontMetrics -> _int)) +(define-pango pango_font_metrics_get_ascent (_pfun PangoFontMetrics -> _int)) +(define-pango pango_font_metrics_get_descent (_pfun PangoFontMetrics -> _int)) -(define-pango pango_layout_get_unknown_glyphs_count (_fun PangoLayout -> _int) +(define-pango pango_layout_get_unknown_glyphs_count (_pfun PangoLayout -> _int) ;; not available in old versions: #:fail (lambda () (lambda (lo) 0))) -(define-pango pango_attr_list_unref (_fun PangoAttrList -> _void) +(define-pango pango_attr_list_unref (_pfun PangoAttrList -> _void) #:wrap (deallocator)) -(define-pango pango_attr_list_new (_fun -> PangoAttrList) +(define-pango pango_attr_list_new (_pfun -> PangoAttrList) #:wrap (allocator pango_attr_list_unref)) -(define-pango pango_attr_list_insert (_fun PangoAttrList PangoAttribute -> _void) +(define-pango pango_attr_list_insert (_pfun PangoAttrList PangoAttribute -> _void) ;; takes ownership of the attribute #:wrap (deallocator cadr)) -(define-pango pango_attribute_destroy (_fun PangoAttribute -> _void) +(define-pango pango_attribute_destroy (_pfun PangoAttribute -> _void) #:wrap (deallocator)) -(define-pango pango_attr_underline_new (_fun _int -> PangoAttribute) +(define-pango pango_attr_underline_new (_pfun _int -> PangoAttribute) #:wrap (allocator pango_attribute_destroy)) -(define-pango pango_attr_fallback_new (_fun _bool -> PangoAttribute) +(define-pango pango_attr_fallback_new (_pfun _bool -> PangoAttribute) #:wrap (allocator pango_attribute_destroy)) -(define-pango pango_layout_set_attributes (_fun PangoLayout PangoAttrList -> _void)) +(define-pango pango_layout_set_attributes (_pfun PangoLayout PangoAttrList -> _void)) -(define-pango pango_font_map_list_families (_fun PangoFontMap +(define-pango pango_font_map_list_families (_pfun PangoFontMap (fams : (_ptr o _pointer)) (len : (_ptr o _int)) -> _void @@ -263,31 +272,31 @@ (ptr-ref fams PangoFontFamily i)) (g_free fams)))) -(define-pango pango_font_description_free (_fun PangoFontDescription -> _void) +(define-pango pango_font_description_free (_pfun PangoFontDescription -> _void) #:wrap (deallocator)) -(define-pango pango_font_description_new (_fun -> PangoFontDescription) +(define-pango pango_font_description_new (_pfun -> PangoFontDescription) #:wrap (allocator pango_font_description_free)) -(define-pango pango_font_description_from_string (_fun _string -> PangoFontDescription) +(define-pango pango_font_description_from_string (_pfun _string -> PangoFontDescription) #:wrap (allocator pango_font_description_free)) -(define-pango pango_font_description_set_family (_fun PangoFontDescription _string -> _void)) -(define-pango pango_font_description_set_style (_fun PangoFontDescription _int -> _void)) -(define-pango pango_font_description_set_weight (_fun PangoFontDescription _int -> _void)) -(define-pango pango_font_description_set_size (_fun PangoFontDescription _int -> _void)) -(define-pango pango_font_description_set_absolute_size (_fun PangoFontDescription _double* -> _void)) +(define-pango pango_font_description_set_family (_pfun PangoFontDescription _string -> _void)) +(define-pango pango_font_description_set_style (_pfun PangoFontDescription _int -> _void)) +(define-pango pango_font_description_set_weight (_pfun PangoFontDescription _int -> _void)) +(define-pango pango_font_description_set_size (_pfun PangoFontDescription _int -> _void)) +(define-pango pango_font_description_set_absolute_size (_pfun PangoFontDescription _double* -> _void)) (define _PangoWin32FontCache (_cpointer 'PangoWin32FontCache)) (define _HFONT (_cpointer 'HFONT)) (define _LOGFONT-pointer _pointer) -(define-pangowin32 pango_win32_font_map_for_display (_fun -> PangoFontMap) +(define-pangowin32 pango_win32_font_map_for_display (_pfun -> PangoFontMap) #:make-fail make-not-available) -(define-pangowin32 pango_win32_font_logfont (_fun PangoFont -> _LOGFONT-pointer) +(define-pangowin32 pango_win32_font_logfont (_pfun PangoFont -> _LOGFONT-pointer) #:make-fail make-not-available #:wrap (allocator g_free)) -(define-pangowin32 pango_win32_font_cache_unload (_fun _PangoWin32FontCache _HFONT -> _void) +(define-pangowin32 pango_win32_font_cache_unload (_pfun _PangoWin32FontCache _HFONT -> _void) #:make-fail make-not-available) -(define-pangowin32 pango_win32_font_cache_load (_fun _PangoWin32FontCache _LOGFONT-pointer -> _HFONT) +(define-pangowin32 pango_win32_font_cache_load (_pfun _PangoWin32FontCache _LOGFONT-pointer -> _HFONT) #:make-fail make-not-available) -(define-pangowin32 pango_win32_font_cache_new (_fun -> _PangoWin32FontCache) +(define-pangowin32 pango_win32_font_cache_new (_pfun -> _PangoWin32FontCache) #:make-fail make-not-available) (define-enum diff --git a/collects/scribblings/foreign/types.scrbl b/collects/scribblings/foreign/types.scrbl index 1216772024..dd7105ccc3 100644 --- a/collects/scribblings/foreign/types.scrbl +++ b/collects/scribblings/foreign/types.scrbl @@ -364,6 +364,7 @@ the later case, the result is the @scheme[ctype]).} [#:abi abi (or/c #f 'default 'stdcall 'sysv) #f] [#:atomic? atomic? any/c #f] [#:async-apply async-apply (or/c #f ((-> any) . -> . any)) #f] + [#:in-original-place? in-original-place? any/c #f] [#:save-errno save-errno (or/c #f 'posix 'windows) #f] [#:wrapper wrapper (or/c #f (procedure? . -> . procedure?)) #f] @@ -438,6 +439,20 @@ with an @scheme[async-apply] is called from foreign code in the same OS-level thread that runs Racket, then the @scheme[async-apply] wrapper is not used. +@margin-note{The @racket[atomic?] and @racket[async-apply] arguments +affect callbacks into Racket, while @scheme[in-original-place?] +affects calls from Racket into foreign code.} + +If @scheme[in-original-place?] is true, then when a foreign procedure +with the generated type is called in any Racket @tech[#:doc '(lib +"scribblings/reference/reference.scrbl")]{place}, the procedure is +called from the original Racket place. Use this mode for a foreign +function that is not thread-safe at the C level, which means that it +is not place-safe at the Racket level. Callbacks from place-unsafe +code back into Racket at a non-original place typically will not work, +since the place of the Racket code may have a different allocator than +the original place. + If @scheme[save-errno] is @scheme['posix], then the value of @as-index{@tt{errno}} is saved (specific to the current thread) immediately after a foreign function returns. The saved value is @@ -521,7 +536,8 @@ values: @itemize[ (code:line #:save-errno save-errno-expr) (code:line #:keep keep-expr) (code:line #:atomic? atomic?-expr) - (code:line #:async-apply async-apply-expr)] + (code:line #:async-apply async-apply-expr) + (code:line #:in-original-place? in-original-place?-expr)] [maybe-args code:blank (code:line (id ...) ::) (code:line id ::) diff --git a/src/foreign/foreign.c b/src/foreign/foreign.c index 945230695e..31fbdc2109 100644 --- a/src/foreign/foreign.c +++ b/src/foreign/foreign.c @@ -2482,6 +2482,51 @@ void do_ptr_finalizer(void *p, void *finalizer) typedef void(*VoidFun)(); +#ifdef MZ_USE_PLACES + +typedef struct FFI_Orig_Place_Call { + ffi_cif *cif; + VoidFun proc; + void *p; + void **avalues; + mzrt_sema *sema; + struct FFI_Orig_Place_Call *next; +} FFI_Orig_Place_Call; + +static mzrt_mutex *orig_place_mutex; +static FFI_Orig_Place_Call *orig_place_calls; +static void *orig_place_signal_handle; + +void ffi_call_in_orig_place(ffi_cif *cif, VoidFun proc, void *p, void **avalues) + XFORM_SKIP_PROC +{ + if (scheme_current_place_id == 0) { + ffi_call(cif, proc, p, avalues); + } else { + FFI_Orig_Place_Call *todo; + + todo = (FFI_Orig_Place_Call *)malloc(sizeof(FFI_Orig_Place_Call)); + todo->cif = cif; + todo->proc = proc; + todo->p = p; + todo->avalues = avalues; + mzrt_sema_create(&todo->sema, 0); + + mzrt_mutex_lock(orig_place_mutex); + todo->next = orig_place_calls; + orig_place_calls = todo; + mzrt_mutex_unlock(orig_place_mutex); + + scheme_signal_received_at(orig_place_signal_handle); + + mzrt_sema_wait(todo->sema); + + mzrt_sema_destroy(todo->sema); + free(todo); + } +} +#endif + Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[]) /* data := {name, c-function, itypes, otype, cif} */ { @@ -2492,8 +2537,11 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[]) Scheme_Object *otype = SCHEME_VEC_ELS(data)[3]; Scheme_Object *base; ffi_cif *cif = (ffi_cif*)(SCHEME_VEC_ELS(data)[4]); - intptr_t cfoff = SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[5]); + intptr_t cfoff = SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[5]); int save_errno = SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[6]); +#ifdef MZ_USE_PLACES + int orig_place = SCHEME_TRUEP(SCHEME_VEC_ELS(data)[7]); +#endif int nargs = cif->nargs; /* When the foreign function is called, we need an array (ivals) of nargs * ForeignAny objects to store the actual C values that are created, and we @@ -2572,7 +2620,12 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[]) } } /* Finally, call the function */ - ffi_call(cif, (VoidFun)W_OFFSET(c_func, cfoff), p, avalues); +#ifdef MZ_USE_PLACES + if (orig_place) { + ffi_call_in_orig_place(cif, (VoidFun)W_OFFSET(c_func, cfoff), p, avalues); + } else +#endif + ffi_call(cif, (VoidFun)W_OFFSET(c_func, cfoff), p, avalues); if (save_errno != 0) save_errno_values(save_errno); if (ivals != stack_ivals) free(ivals); ivals = NULL; /* no need now to hold on to this */ @@ -2602,80 +2655,95 @@ void free_fficall_data(void *ignored, void *p) free(p); } -/* (ffi-call ffi-obj in-types out-type [abi save-errno?]) -> (in-types -> out-value) */ +/* (ffi-call ffi-obj in-types out-type [abi save-errno? orig-place?]) -> (in-types -> out-value) */ /* the real work is done by ffi_do_call above */ #define MYNAME "ffi-call" static Scheme_Object *foreign_ffi_call(int argc, Scheme_Object *argv[]) { - static Scheme_Object *ffi_name_prefix = NULL; - Scheme_Object *itypes = argv[1]; - Scheme_Object *otype = argv[2]; - Scheme_Object *obj, *data, *p, *base; - ffi_abi abi; - intptr_t ooff; - GC_CAN_IGNORE ffi_type *rtype, **atypes; - GC_CAN_IGNORE ffi_cif *cif; - int i, nargs, save_errno; - MZ_REGISTER_STATIC(ffi_name_prefix); - if (!ffi_name_prefix) - ffi_name_prefix = scheme_make_byte_string_without_copying("ffi:"); - if (!SCHEME_FFIANYPTRP(argv[0])) - scheme_wrong_type(MYNAME, "ffi-obj-or-cpointer", 0, argc, argv); - obj = SCHEME_FFIANYPTR_VAL(argv[0]); - ooff = SCHEME_FFIANYPTR_OFFSET(argv[0]); - if ((obj == NULL) && (ooff == 0)) - scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv); - nargs = scheme_proper_list_length(itypes); - if (nargs < 0) - scheme_wrong_type(MYNAME, "proper list", 1, argc, argv); - if (NULL == (base = get_ctype_base(otype))) - scheme_wrong_type(MYNAME, "C-type", 2, argc, argv); - rtype = CTYPE_PRIMTYPE(base); - abi = GET_ABI(MYNAME,3); - if (argc > 4) { - save_errno = -1; - if (SCHEME_FALSEP(argv[4])) + static Scheme_Object *ffi_name_prefix = NULL; + Scheme_Object *itypes = argv[1]; + Scheme_Object *otype = argv[2]; + Scheme_Object *obj, *data, *p, *base; + ffi_abi abi; + intptr_t ooff; + GC_CAN_IGNORE ffi_type *rtype, **atypes; + GC_CAN_IGNORE ffi_cif *cif; + int i, nargs, save_errno; + #ifdef MZ_USE_PLACES + int orig_place; + # define FFI_CALL_VEC_SIZE 8 + #else + # define FFI_CALL_VEC_SIZE 7 + #endif + MZ_REGISTER_STATIC(ffi_name_prefix); + if (!ffi_name_prefix) + ffi_name_prefix = scheme_make_byte_string_without_copying("ffi:"); + if (!SCHEME_FFIANYPTRP(argv[0])) + scheme_wrong_type(MYNAME, "ffi-obj-or-cpointer", 0, argc, argv); + obj = SCHEME_FFIANYPTR_VAL(argv[0]); + ooff = SCHEME_FFIANYPTR_OFFSET(argv[0]); + if ((obj == NULL) && (ooff == 0)) + scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv); + nargs = scheme_proper_list_length(itypes); + if (nargs < 0) + scheme_wrong_type(MYNAME, "proper list", 1, argc, argv); + if (NULL == (base = get_ctype_base(otype))) + scheme_wrong_type(MYNAME, "C-type", 2, argc, argv); + rtype = CTYPE_PRIMTYPE(base); + abi = GET_ABI(MYNAME,3); + if (argc > 4) { + save_errno = -1; + if (SCHEME_FALSEP(argv[4])) + save_errno = 0; + else if (SCHEME_SYMBOLP(argv[4]) + && !SCHEME_SYM_WEIRDP(argv[4])) { + if (!strcmp(SCHEME_SYM_VAL(argv[4]), "posix")) + save_errno = 1; + else if (!strcmp(SCHEME_SYM_VAL(argv[4]), "windows")) + save_errno = 2; + } + if (save_errno == -1) { + scheme_wrong_type(MYNAME, "'posix, 'windows, or #f", 4, argc, argv); + } + } else save_errno = 0; - else if (SCHEME_SYMBOLP(argv[4]) - && !SCHEME_SYM_WEIRDP(argv[4])) { - if (!strcmp(SCHEME_SYM_VAL(argv[4]), "posix")) - save_errno = 1; - else if (!strcmp(SCHEME_SYM_VAL(argv[4]), "windows")) - save_errno = 2; + #ifdef MZ_USE_PLACES + if (argc > 5) { + orig_place = SCHEME_TRUEP(argv[5]); + } else + orig_place = 0; + #endif + atypes = malloc(nargs * sizeof(ffi_type*)); + for (i=0, p=itypes; iname : "proc")); - SCHEME_VEC_ELS(data)[0] = p; - SCHEME_VEC_ELS(data)[1] = obj; - SCHEME_VEC_ELS(data)[2] = itypes; - SCHEME_VEC_ELS(data)[3] = otype; - SCHEME_VEC_ELS(data)[4] = (Scheme_Object*)cif; - SCHEME_VEC_ELS(data)[5] = scheme_make_integer(ooff); - SCHEME_VEC_ELS(data)[6] = scheme_make_integer(save_errno); - scheme_register_finalizer(data, free_fficall_data, cif, NULL, NULL); - return scheme_make_closed_prim_w_arity - (ffi_do_call, (void*)data, SCHEME_BYTE_STR_VAL(p), - nargs, nargs); + cif = malloc(sizeof(ffi_cif)); + if (ffi_prep_cif(cif, abi, nargs, rtype, atypes) != FFI_OK) + scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK"); + data = scheme_make_vector(FFI_CALL_VEC_SIZE, NULL); + p = scheme_append_byte_string + (ffi_name_prefix, + scheme_make_byte_string_without_copying + (SCHEME_FFIOBJP(argv[0]) ? + ((ffi_obj_struct*)(argv[0]))->name : "proc")); + SCHEME_VEC_ELS(data)[0] = p; + SCHEME_VEC_ELS(data)[1] = obj; + SCHEME_VEC_ELS(data)[2] = itypes; + SCHEME_VEC_ELS(data)[3] = otype; + SCHEME_VEC_ELS(data)[4] = (Scheme_Object*)cif; + SCHEME_VEC_ELS(data)[5] = scheme_make_integer(ooff); + SCHEME_VEC_ELS(data)[6] = scheme_make_integer(save_errno); + #ifdef MZ_USE_PLACES + SCHEME_VEC_ELS(data)[7] = (orig_place ? scheme_true : scheme_false); + #endif + scheme_register_finalizer(data, free_fficall_data, cif, NULL, NULL); + return scheme_make_closed_prim_w_arity + (ffi_do_call, (void*)data, SCHEME_BYTE_STR_VAL(p), + nargs, nargs); } #undef MYNAME @@ -2801,6 +2869,23 @@ void scheme_check_foreign_work(void) } while (qc); } + +#ifdef MZ_USE_PLACES + if ((scheme_current_place_id == 0) && orig_place_mutex) { + FFI_Orig_Place_Call *todo; + + mzrt_mutex_lock(orig_place_mutex); + todo = orig_place_calls; + orig_place_calls = NULL; + mzrt_mutex_unlock(orig_place_mutex); + + while (todo) { + ffi_call(todo->cif, todo->proc, todo->p, todo->avalues); + mzrt_sema_post(todo->sema); + todo = todo->next; + } + } +#endif } #endif @@ -3176,6 +3261,12 @@ void scheme_init_foreign_globals() void scheme_init_foreign_places() { MZ_REGISTER_STATIC(opened_libs); opened_libs = scheme_make_hash_table(SCHEME_hash_string); +#ifdef MZ_USE_PLACES + if (!orig_place_mutex) { + mzrt_mutex_create(&orig_place_mutex); + orig_place_signal_handle = scheme_get_signal_handle(); + } +#endif } void scheme_init_foreign(Scheme_Env *env) @@ -3264,7 +3355,7 @@ void scheme_init_foreign(Scheme_Env *env) scheme_add_global("make-sized-byte-string", scheme_make_prim_w_arity(foreign_make_sized_byte_string, "make-sized-byte-string", 2, 2), menv); scheme_add_global("ffi-call", - scheme_make_prim_w_arity(foreign_ffi_call, "ffi-call", 3, 5), menv); + scheme_make_prim_w_arity(foreign_ffi_call, "ffi-call", 3, 6), menv); scheme_add_global("ffi-callback", scheme_make_prim_w_arity(foreign_ffi_callback, "ffi-callback", 3, 6), menv); scheme_add_global("saved-errno", @@ -3573,7 +3664,7 @@ void scheme_init_foreign(Scheme_Env *env) scheme_add_global("make-sized-byte-string", scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "make-sized-byte-string", 2, 2), menv); scheme_add_global("ffi-call", - scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "ffi-call", 3, 5), menv); + scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "ffi-call", 3, 6), menv); scheme_add_global("ffi-callback", scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "ffi-callback", 3, 6), menv); scheme_add_global("saved-errno", diff --git a/src/foreign/foreign.rktc b/src/foreign/foreign.rktc index 3fa984a4d5..090a447f06 100755 --- a/src/foreign/foreign.rktc +++ b/src/foreign/foreign.rktc @@ -1847,6 +1847,51 @@ cdefine[register-finalizer 2 3]{ typedef void(*VoidFun)(); +#ifdef MZ_USE_PLACES + +typedef struct FFI_Orig_Place_Call { + ffi_cif *cif; + VoidFun proc; + void *p; + void **avalues; + mzrt_sema *sema; + struct FFI_Orig_Place_Call *next; +} FFI_Orig_Place_Call; + +static mzrt_mutex *orig_place_mutex; +static FFI_Orig_Place_Call *orig_place_calls; +static void *orig_place_signal_handle; + +void ffi_call_in_orig_place(ffi_cif *cif, VoidFun proc, void *p, void **avalues) + XFORM_SKIP_PROC +{ + if (scheme_current_place_id == 0) { + ffi_call(cif, proc, p, avalues); + } else { + FFI_Orig_Place_Call *todo; + + todo = (FFI_Orig_Place_Call *)malloc(sizeof(FFI_Orig_Place_Call)); + todo->cif = cif; + todo->proc = proc; + todo->p = p; + todo->avalues = avalues; + mzrt_sema_create(&todo->sema, 0); + + mzrt_mutex_lock(orig_place_mutex); + todo->next = orig_place_calls; + orig_place_calls = todo; + mzrt_mutex_unlock(orig_place_mutex); + + scheme_signal_received_at(orig_place_signal_handle); + + mzrt_sema_wait(todo->sema); + + mzrt_sema_destroy(todo->sema); + free(todo); + } +} +#endif + Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[]) /* data := {name, c-function, itypes, otype, cif} */ { @@ -1857,8 +1902,11 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[]) Scheme_Object *otype = SCHEME_VEC_ELS(data)[3]; Scheme_Object *base; ffi_cif *cif = (ffi_cif*)(SCHEME_VEC_ELS(data)[4]); - intptr_t cfoff = SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[5]); + intptr_t cfoff = SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[5]); int save_errno = SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[6]); +#ifdef MZ_USE_PLACES + int orig_place = SCHEME_TRUEP(SCHEME_VEC_ELS(data)[7]); +#endif int nargs = cif->nargs; /* When the foreign function is called, we need an array (ivals) of nargs * ForeignAny objects to store the actual C values that are created, and we @@ -1937,7 +1985,12 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[]) } } /* Finally, call the function */ - ffi_call(cif, (VoidFun)W_OFFSET(c_func, cfoff), p, avalues); +#ifdef MZ_USE_PLACES + if (orig_place) { + ffi_call_in_orig_place(cif, (VoidFun)W_OFFSET(c_func, cfoff), p, avalues); + } else +#endif + ffi_call(cif, (VoidFun)W_OFFSET(c_func, cfoff), p, avalues); if (save_errno != 0) save_errno_values(save_errno); if (ivals != stack_ivals) free(ivals); ivals = NULL; /* no need now to hold on to this */ @@ -1967,9 +2020,9 @@ void free_fficall_data(void *ignored, void *p) free(p); } -/* (ffi-call ffi-obj in-types out-type [abi save-errno?]) -> (in-types -> out-value) */ +/* (ffi-call ffi-obj in-types out-type [abi save-errno? orig-place?]) -> (in-types -> out-value) */ /* the real work is done by ffi_do_call above */ -@cdefine[ffi-call 3 5]{ +@cdefine[ffi-call 3 6]{ static Scheme_Object *ffi_name_prefix = NULL; Scheme_Object *itypes = argv[1]; Scheme_Object *otype = argv[2]; @@ -1979,6 +2032,12 @@ void free_fficall_data(void *ignored, void *p) GC_CAN_IGNORE ffi_type *rtype, **atypes; GC_CAN_IGNORE ffi_cif *cif; int i, nargs, save_errno; +#ifdef MZ_USE_PLACES + int orig_place; +# define FFI_CALL_VEC_SIZE 8 +#else +# define FFI_CALL_VEC_SIZE 7 +#endif MZ_REGISTER_STATIC(ffi_name_prefix); if (!ffi_name_prefix) ffi_name_prefix = scheme_make_byte_string_without_copying("ffi:"); @@ -2011,6 +2070,12 @@ void free_fficall_data(void *ignored, void *p) } } else save_errno = 0; +#ifdef MZ_USE_PLACES + if (argc > 5) { + orig_place = SCHEME_TRUEP(argv[5]); + } else + orig_place = 0; +#endif atypes = malloc(nargs * sizeof(ffi_type*)); for (i=0, p=itypes; icif, todo->proc, todo->p, todo->avalues); + mzrt_sema_post(todo->sema); + todo = todo->next; + } + } +#endif } #endif @@ -2500,6 +2585,12 @@ void scheme_init_foreign_globals() void scheme_init_foreign_places() { MZ_REGISTER_STATIC(opened_libs); opened_libs = scheme_make_hash_table(SCHEME_hash_string); +#ifdef MZ_USE_PLACES + if (!orig_place_mutex) { + mzrt_mutex_create(&orig_place_mutex); + orig_place_signal_handle = scheme_get_signal_handle(); + } +#endif } void scheme_init_foreign(Scheme_Env *env)