suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

ffi: add `#:in-original-place?' to deal with thread-unsafe libs

Browse Source 
and use it for Pango, which is not thread-safe at the C level
This commit is contained in:
Matthew Flatt 2011-05-13 07:14:31 -06:00
parent c5816ab6f9
commit 49aadc599a
5 changed files with 360 additions and 150 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
collects/ffi/unsafe.rkt
View File

@ -441,13 +441,14 @@
#:wrapper [wrapper #f] #:wrapper [wrapper #f]
#:keep [keep #t] #:keep [keep #t]
#:atomic? [atomic? #f] #:atomic? [atomic? #f]
#:async-apply [async-apply #f] #:in-original-place? [orig-place? #f]
#:async-apply [async-apply #f]
#:save-errno [errno #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 ;; for internal use
(define held-callbacks (make-weak-hasheq)) (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) (define-syntax-rule (make-it wrap)
(make-ctype _fpointer (make-ctype _fpointer
(lambda (x) (lambda (x)
@ -460,7 +461,7 @@
(if (or (null? x) (pair? x)) (cons cb x) cb)))] (if (or (null? x) (pair? x)) (cons cb x) cb)))]
[(procedure? keep) (keep cb)]) [(procedure? keep) (keep cb)])
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))) (if wrapper (make-it wrapper) (make-it begin)))
;; Syntax for the special _fun type: ;; Syntax for the special _fun type:
@ -483,7 +484,8 @@
(provide _fun) (provide _fun)
(define-for-syntax _fun-keywords (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-syntax (_fun stx)
(define (err msg . sub) (apply raise-syntax-error '_fun msg stx sub)) (define (err msg . sub) (apply raise-syntax-error '_fun msg stx sub))
(define xs #f) (define xs #f)
@ -632,6 +634,7 @@
#,wrapper #,wrapper
#,(kwd-ref '#:keep) #,(kwd-ref '#:keep)
#,(kwd-ref '#:atomic?) #,(kwd-ref '#:atomic?)
#,(kwd-ref '#:in-original-place?)
#,(kwd-ref '#:async-apply) #,(kwd-ref '#:async-apply)
#,(kwd-ref '#:save-errno)))]) #,(kwd-ref '#:save-errno)))])
(if (or (caddr output) input-names (ormap caddr inputs) (if (or (caddr output) input-names (ormap caddr inputs)

143
collects/racket/draw/unsafe/pango.rkt
View File

@ -114,10 +114,19 @@
[glyphs _PangoGlyphString-pointer])) [glyphs _PangoGlyphString-pointer]))
(provide (struct-out PangoGlyphItem)) (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) (provide g_object_unref g_free)
(define-gobj g_object_unref (_fun _pointer -> _void) (define-gobj g_object_unref (_pfun _pointer -> _void)
#:wrap (deallocator)) #:wrap (deallocator))
(define-glib g_free (_fun _pointer -> _void) (define-glib g_free (_pfun _pointer -> _void)
#:wrap (deallocator)) #:wrap (deallocator))
;; For working around a Win32 Pango bug (see `unref-font-map'): ;; For working around a Win32 Pango bug (see `unref-font-map'):
@ -127,9 +136,9 @@
[qdata _pointer] [qdata _pointer]
[font_cache _pointer] [font_cache _pointer]
[freed_fonts _GQueue])) [freed_fonts _GQueue]))
(define-glib g_queue_foreach (_fun _GQueue (_fun _pointer -> _void) _pointer -> _void)) (define-glib g_queue_foreach (_pfun _GQueue _fpointer #;(_fun _pointer -> _void) _pointer -> _void))
(define-glib g_queue_free (_fun _GQueue -> _void)) (define-glib g_queue_free (_pfun _GQueue -> _void))
(define-glib g_queue_new (_fun -> _GQueue)) (define-glib g_queue_new (_pfun -> _GQueue))
(define (unref-font-map v) (define (unref-font-map v)
(when (eq? (system-type) 'windows) (when (eq? (system-type) 'windows)
@ -147,11 +156,11 @@
(set-PangoWin32FontMap-freed_fonts! fm (g_queue_new)))) (set-PangoWin32FontMap-freed_fonts! fm (g_queue_new))))
(g_object_unref v)) (g_object_unref v))
(define-pangocairo pango_cairo_font_map_get_default (_fun -> PangoFontMap)) ;; not an allocator (define-pangocairo pango_cairo_font_map_get_default (_pfun -> PangoFontMap)) ;; not an allocator
(define-pangocairo pango_cairo_font_map_new (_fun -> PangoFontMap) (define-pangocairo pango_cairo_font_map_new (_pfun -> PangoFontMap)
#:wrap (allocator unref-font-map)) #:wrap (allocator unref-font-map))
(define-pango pango_context_new (_fun -> PangoContext) (define-pango pango_context_new (_pfun -> PangoContext)
#:wrap (allocator g_object_unref)) #:wrap (allocator g_object_unref))
;; pango_font_map_create_context() is in 1.22 and later ;; pango_font_map_create_context() is in 1.22 and later
(provide pango_font_map_create_context) (provide pango_font_map_create_context)
@ -159,7 +168,7 @@
(let ([c (pango_context_new)]) (let ([c (pango_context_new)])
(pango_context_set_font_map c fm) (pango_context_set_font_map c fm)
c)) 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 ;; The convenince function pango_cairo_create_context() is in 1.22 and later
(provide pango_cairo_create_context) (provide pango_cairo_create_context)
@ -169,31 +178,31 @@
(pango_cairo_update_context cr ctx) (pango_cairo_update_context cr ctx)
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)) #:wrap (allocator g_object_unref))
(define-pangocairo pango_cairo_update_layout (_fun _cairo_t PangoLayout -> _void)) (define-pangocairo pango_cairo_update_layout (_pfun _cairo_t PangoLayout -> _void))
(define-pango pango_layout_set_text (_fun PangoLayout [s : _string] [_int = -1] -> _void)) (define-pango pango_layout_set_text (_pfun PangoLayout [s : _string] [_int = -1] -> _void))
(define-pangocairo pango_cairo_show_layout (_fun _cairo_t PangoLayout -> _void)) (define-pangocairo pango_cairo_show_layout (_pfun _cairo_t PangoLayout -> _void))
(define-pangocairo pango_cairo_show_layout_line (_fun _cairo_t PangoLayoutLine -> _void)) (define-pangocairo pango_cairo_show_layout_line (_pfun _cairo_t PangoLayoutLine -> _void))
(define-pangocairo pango_cairo_show_glyph_string (_fun _cairo_t PangoFont _PangoGlyphString-pointer -> _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)) #: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)) #:wrap (allocator pango_layout_iter_free))
(define-pango pango_layout_iter_get_baseline (_fun PangoLayoutIter -> _int)) (define-pango pango_layout_iter_get_baseline (_pfun PangoLayoutIter -> _int))
(define-pango pango_layout_iter_next_run (_fun PangoLayoutIter -> _bool)) (define-pango pango_layout_iter_next_run (_pfun PangoLayoutIter -> _bool))
(define-pango pango_layout_iter_get_run (_fun PangoLayoutIter -> (_or-null _PangoGlyphItem-pointer))) (define-pango pango_layout_iter_get_run (_pfun 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_run_readonly (_pfun PangoLayoutIter -> (_or-null _PangoGlyphItem-pointer))
#:fail (lambda () pango_layout_iter_get_run)) #:fail (lambda () pango_layout_iter_get_run))
(define-pango pango_layout_get_line (_fun PangoLayout _int -> PangoLayoutLine)) (define-pango pango_layout_get_line (_pfun PangoLayout _int -> PangoLayoutLine))
(define-pango pango_layout_get_line_readonly (_fun PangoLayout _int -> PangoLayoutLine) (define-pango pango_layout_get_line_readonly (_pfun PangoLayout _int -> PangoLayoutLine)
#:fail (lambda () pango_layout_get_line)) #:fail (lambda () pango_layout_get_line))
(define-pango pango_layout_get_context (_fun PangoLayout -> PangoContext)) ;; not an allocator (define-pango pango_layout_get_context (_pfun PangoLayout -> PangoContext)) ;; not an allocator
(define-pango pango_layout_get_extents (_fun PangoLayout _pointer _PangoRectangle-pointer -> _void)) (define-pango pango_layout_get_extents (_pfun PangoLayout _pointer _PangoRectangle-pointer -> _void))
(define-pango pango_layout_get_baseline (_fun PangoLayout -> _int) (define-pango pango_layout_get_baseline (_pfun PangoLayout -> _int)
;; The convenince function pango_layout_get_baseline() is in 1.22 and later ;; The convenince function pango_layout_get_baseline() is in 1.22 and later
#:fail (lambda () #:fail (lambda ()
(lambda (layout) (lambda (layout)
@ -201,60 +210,60 @@
(begin0 (begin0
(pango_layout_iter_get_baseline iter) (pango_layout_iter_get_baseline iter)
(pango_layout_iter_free 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)) #: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_get_font_options (_pfun 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_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_layout_set_font_description (_pfun PangoLayout PangoFontDescription -> _void)) ;; makes a copy
(define-pango pango_context_get_font_map (_fun PangoContext -> PangoFontMap)) ;; not an allocator (define-pango pango_context_get_font_map (_pfun PangoContext -> PangoFontMap)) ;; not an allocator
(define-pango pango_context_set_font_map (_fun PangoContext PangoFontMap -> _void)) (define-pango pango_context_set_font_map (_pfun PangoContext PangoFontMap -> _void))
(define-pango pango_font_family_get_name (_fun PangoFontFamily -> _string)) ;; not an allocator (define-pango pango_font_family_get_name (_pfun PangoFontFamily -> _string)) ;; not an allocator
(define-pango pango_font_family_is_monospace (_fun PangoFontFamily -> _bool)) (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 ;; not available before 1.16
#:fail (lambda () (lambda () #f))) #:fail (lambda () (lambda () #f)))
(define-pango pango_font_map_load_font (_fun PangoFontMap PangoContext PangoFontDescription -> (_or-null PangoFont))) (define-pango pango_font_map_load_font (_pfun PangoFontMap PangoContext PangoFontDescription -> (_or-null PangoFont)))
(define-pango pango_coverage_unref (_fun PangoCoverage -> _void) (define-pango pango_coverage_unref (_pfun PangoCoverage -> _void)
#:wrap (deallocator)) #: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)) #: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)) #: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)) #:wrap (allocator pango_font_metrics_unref))
(define-pango pango_font_metrics_get_approximate_char_width (_fun PangoFontMetrics -> _int)) (define-pango pango_font_metrics_get_approximate_char_width (_pfun PangoFontMetrics -> _int))
(define-pango pango_font_metrics_get_ascent (_fun PangoFontMetrics -> _int)) (define-pango pango_font_metrics_get_ascent (_pfun PangoFontMetrics -> _int))
(define-pango pango_font_metrics_get_descent (_fun 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: ;; not available in old versions:
#:fail (lambda () (lambda (lo) 0))) #: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)) #:wrap (deallocator))
(define-pango pango_attr_list_new (_fun -> PangoAttrList) (define-pango pango_attr_list_new (_pfun -> PangoAttrList)
#:wrap (allocator pango_attr_list_unref)) #: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 ;; takes ownership of the attribute
#:wrap (deallocator cadr)) #:wrap (deallocator cadr))
(define-pango pango_attribute_destroy (_fun PangoAttribute -> _void) (define-pango pango_attribute_destroy (_pfun PangoAttribute -> _void)
#:wrap (deallocator)) #: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)) #: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)) #: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)) (fams : (_ptr o _pointer))
(len : (_ptr o _int)) (len : (_ptr o _int))
-> _void -> _void
@ -263,31 +272,31 @@
(ptr-ref fams PangoFontFamily i)) (ptr-ref fams PangoFontFamily i))
(g_free fams)))) (g_free fams))))
(define-pango pango_font_description_free (_fun PangoFontDescription -> _void) (define-pango pango_font_description_free (_pfun PangoFontDescription -> _void)
#:wrap (deallocator)) #:wrap (deallocator))
(define-pango pango_font_description_new (_fun -> PangoFontDescription) (define-pango pango_font_description_new (_pfun -> PangoFontDescription)
#:wrap (allocator pango_font_description_free)) #: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)) #:wrap (allocator pango_font_description_free))
(define-pango pango_font_description_set_family (_fun PangoFontDescription _string -> _void)) (define-pango pango_font_description_set_family (_pfun PangoFontDescription _string -> _void))
(define-pango pango_font_description_set_style (_fun PangoFontDescription _int -> _void)) (define-pango pango_font_description_set_style (_pfun PangoFontDescription _int -> _void))
(define-pango pango_font_description_set_weight (_fun PangoFontDescription _int -> _void)) (define-pango pango_font_description_set_weight (_pfun PangoFontDescription _int -> _void))
(define-pango pango_font_description_set_size (_fun PangoFontDescription _int -> _void)) (define-pango pango_font_description_set_size (_pfun PangoFontDescription _int -> _void))
(define-pango pango_font_description_set_absolute_size (_fun PangoFontDescription _double* -> _void)) (define-pango pango_font_description_set_absolute_size (_pfun PangoFontDescription _double* -> _void))
(define _PangoWin32FontCache (_cpointer 'PangoWin32FontCache)) (define _PangoWin32FontCache (_cpointer 'PangoWin32FontCache))
(define _HFONT (_cpointer 'HFONT)) (define _HFONT (_cpointer 'HFONT))
(define _LOGFONT-pointer _pointer) (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) #: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 #:make-fail make-not-available
#:wrap (allocator g_free)) #: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) #: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) #: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) #:make-fail make-not-available)
(define-enum (define-enum

18
collects/scribblings/foreign/types.scrbl
View File

@ -364,6 +364,7 @@ the later case, the result is the @scheme[ctype]).}
[#:abi abi (or/c #f 'default 'stdcall 'sysv) #f] [#:abi abi (or/c #f 'default 'stdcall 'sysv) #f]
[#:atomic? atomic? any/c #f] [#:atomic? atomic? any/c #f]
[#:async-apply async-apply (or/c #f ((-> any) . -> . any)) #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] [#:save-errno save-errno (or/c #f 'posix 'windows) #f]
[#:wrapper wrapper (or/c #f (procedure? . -> . procedure?)) [#:wrapper wrapper (or/c #f (procedure? . -> . procedure?))
#f] #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 OS-level thread that runs Racket, then the @scheme[async-apply] wrapper is
not used. 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 If @scheme[save-errno] is @scheme['posix], then the value of
@as-index{@tt{errno}} is saved (specific to the current thread) @as-index{@tt{errno}} is saved (specific to the current thread)
immediately after a foreign function returns. The saved value is 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 #:save-errno save-errno-expr)
(code:line #:keep keep-expr) (code:line #:keep keep-expr)
(code:line #:atomic? atomic?-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 [maybe-args code:blank
(code:line (id ...) ::) (code:line (id ...) ::)
(code:line id ::) (code:line id ::)

235
src/foreign/foreign.c
View File

@ -2482,6 +2482,51 @@ void do_ptr_finalizer(void *p, void *finalizer)
typedef void(*VoidFun)(); 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[]) Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
/* data := {name, c-function, itypes, otype, cif} */ /* 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 *otype = SCHEME_VEC_ELS(data)[3];
Scheme_Object *base; Scheme_Object *base;
ffi_cif *cif = (ffi_cif*)(SCHEME_VEC_ELS(data)[4]); 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]); 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; int nargs = cif->nargs;
/* When the foreign function is called, we need an array (ivals) of 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 * 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 */ /* 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 (save_errno != 0) save_errno_values(save_errno);
if (ivals != stack_ivals) free(ivals); if (ivals != stack_ivals) free(ivals);
ivals = NULL; /* no need now to hold on to this */ ivals = NULL; /* no need now to hold on to this */
@ -2602,80 +2655,95 @@ void free_fficall_data(void *ignored, void *p)
free(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 */ /* the real work is done by ffi_do_call above */
#define MYNAME "ffi-call" #define MYNAME "ffi-call"
static Scheme_Object *foreign_ffi_call(int argc, Scheme_Object *argv[]) static Scheme_Object *foreign_ffi_call(int argc, Scheme_Object *argv[])
{ {
static Scheme_Object *ffi_name_prefix = NULL; static Scheme_Object *ffi_name_prefix = NULL;
Scheme_Object *itypes = argv[1]; Scheme_Object *itypes = argv[1];
Scheme_Object *otype = argv[2]; Scheme_Object *otype = argv[2];
Scheme_Object *obj, *data, *p, *base; Scheme_Object *obj, *data, *p, *base;
ffi_abi abi; ffi_abi abi;
intptr_t ooff; intptr_t ooff;
GC_CAN_IGNORE ffi_type *rtype, **atypes; GC_CAN_IGNORE ffi_type *rtype, **atypes;
GC_CAN_IGNORE ffi_cif *cif; GC_CAN_IGNORE ffi_cif *cif;
int i, nargs, save_errno; int i, nargs, save_errno;
MZ_REGISTER_STATIC(ffi_name_prefix); #ifdef MZ_USE_PLACES
if (!ffi_name_prefix) int orig_place;
ffi_name_prefix = scheme_make_byte_string_without_copying("ffi:"); # define FFI_CALL_VEC_SIZE 8
if (!SCHEME_FFIANYPTRP(argv[0])) #else
scheme_wrong_type(MYNAME, "ffi-obj-or-cpointer", 0, argc, argv); # define FFI_CALL_VEC_SIZE 7
obj = SCHEME_FFIANYPTR_VAL(argv[0]); #endif
ooff = SCHEME_FFIANYPTR_OFFSET(argv[0]); MZ_REGISTER_STATIC(ffi_name_prefix);
if ((obj == NULL) && (ooff == 0)) if (!ffi_name_prefix)
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv); ffi_name_prefix = scheme_make_byte_string_without_copying("ffi:");
nargs = scheme_proper_list_length(itypes); if (!SCHEME_FFIANYPTRP(argv[0]))
if (nargs < 0) scheme_wrong_type(MYNAME, "ffi-obj-or-cpointer", 0, argc, argv);
scheme_wrong_type(MYNAME, "proper list", 1, argc, argv); obj = SCHEME_FFIANYPTR_VAL(argv[0]);
if (NULL == (base = get_ctype_base(otype))) ooff = SCHEME_FFIANYPTR_OFFSET(argv[0]);
scheme_wrong_type(MYNAME, "C-type", 2, argc, argv); if ((obj == NULL) && (ooff == 0))
rtype = CTYPE_PRIMTYPE(base); scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
abi = GET_ABI(MYNAME,3); nargs = scheme_proper_list_length(itypes);
if (argc > 4) { if (nargs < 0)
save_errno = -1; scheme_wrong_type(MYNAME, "proper list", 1, argc, argv);
if (SCHEME_FALSEP(argv[4])) 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; save_errno = 0;
else if (SCHEME_SYMBOLP(argv[4]) #ifdef MZ_USE_PLACES
&& !SCHEME_SYM_WEIRDP(argv[4])) { if (argc > 5) {
if (!strcmp(SCHEME_SYM_VAL(argv[4]), "posix")) orig_place = SCHEME_TRUEP(argv[5]);
save_errno = 1; } else
else if (!strcmp(SCHEME_SYM_VAL(argv[4]), "windows")) orig_place = 0;
save_errno = 2; #endif
atypes = malloc(nargs * sizeof(ffi_type*));
for (i=0, p=itypes; i<nargs; i++, p=SCHEME_CDR(p)) {
if (NULL == (base = get_ctype_base(SCHEME_CAR(p))))
scheme_wrong_type(MYNAME, "list-of-C-types", 1, argc, argv);
if (CTYPE_PRIMLABEL(base) == FOREIGN_void)
scheme_wrong_type(MYNAME, "list-of-non-void-C-types", 1, argc, argv);
atypes[i] = CTYPE_PRIMTYPE(base);
} }
if (save_errno == -1) { cif = malloc(sizeof(ffi_cif));
scheme_wrong_type(MYNAME, "'posix, 'windows, or #f", 4, argc, argv); if (ffi_prep_cif(cif, abi, nargs, rtype, atypes) != FFI_OK)
} scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK");
} else data = scheme_make_vector(FFI_CALL_VEC_SIZE, NULL);
save_errno = 0; p = scheme_append_byte_string
atypes = malloc(nargs * sizeof(ffi_type*)); (ffi_name_prefix,
for (i=0, p=itypes; i<nargs; i++, p=SCHEME_CDR(p)) { scheme_make_byte_string_without_copying
if (NULL == (base = get_ctype_base(SCHEME_CAR(p)))) (SCHEME_FFIOBJP(argv[0]) ?
scheme_wrong_type(MYNAME, "list-of-C-types", 1, argc, argv); ((ffi_obj_struct*)(argv[0]))->name : "proc"));
if (CTYPE_PRIMLABEL(base) == FOREIGN_void) SCHEME_VEC_ELS(data)[0] = p;
scheme_wrong_type(MYNAME, "list-of-non-void-C-types", 1, argc, argv); SCHEME_VEC_ELS(data)[1] = obj;
atypes[i] = CTYPE_PRIMTYPE(base); SCHEME_VEC_ELS(data)[2] = itypes;
} SCHEME_VEC_ELS(data)[3] = otype;
cif = malloc(sizeof(ffi_cif)); SCHEME_VEC_ELS(data)[4] = (Scheme_Object*)cif;
if (ffi_prep_cif(cif, abi, nargs, rtype, atypes) != FFI_OK) SCHEME_VEC_ELS(data)[5] = scheme_make_integer(ooff);
scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK"); SCHEME_VEC_ELS(data)[6] = scheme_make_integer(save_errno);
data = scheme_make_vector(7, NULL); #ifdef MZ_USE_PLACES
p = scheme_append_byte_string SCHEME_VEC_ELS(data)[7] = (orig_place ? scheme_true : scheme_false);
(ffi_name_prefix, #endif
scheme_make_byte_string_without_copying scheme_register_finalizer(data, free_fficall_data, cif, NULL, NULL);
(SCHEME_FFIOBJP(argv[0]) ? return scheme_make_closed_prim_w_arity
((ffi_obj_struct*)(argv[0]))->name : "proc")); (ffi_do_call, (void*)data, SCHEME_BYTE_STR_VAL(p),
SCHEME_VEC_ELS(data)[0] = p; nargs, nargs);
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);
} }
#undef MYNAME #undef MYNAME
@ -2801,6 +2869,23 @@ void scheme_check_foreign_work(void)
} while (qc); } 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 #endif
@ -3176,6 +3261,12 @@ void scheme_init_foreign_globals()
void scheme_init_foreign_places() { void scheme_init_foreign_places() {
MZ_REGISTER_STATIC(opened_libs); MZ_REGISTER_STATIC(opened_libs);
opened_libs = scheme_make_hash_table(SCHEME_hash_string); 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) 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_add_global("make-sized-byte-string",
scheme_make_prim_w_arity(foreign_make_sized_byte_string, "make-sized-byte-string", 2, 2), menv); scheme_make_prim_w_arity(foreign_make_sized_byte_string, "make-sized-byte-string", 2, 2), menv);
scheme_add_global("ffi-call", 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_add_global("ffi-callback",
scheme_make_prim_w_arity(foreign_ffi_callback, "ffi-callback", 3, 6), menv); scheme_make_prim_w_arity(foreign_ffi_callback, "ffi-callback", 3, 6), menv);
scheme_add_global("saved-errno", scheme_add_global("saved-errno",
@ -3573,7 +3664,7 @@ void scheme_init_foreign(Scheme_Env *env)
scheme_add_global("make-sized-byte-string", scheme_add_global("make-sized-byte-string",
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "make-sized-byte-string", 2, 2), menv); scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "make-sized-byte-string", 2, 2), menv);
scheme_add_global("ffi-call", 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_add_global("ffi-callback",
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "ffi-callback", 3, 6), menv); scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "ffi-callback", 3, 6), menv);
scheme_add_global("saved-errno", scheme_add_global("saved-errno",

101
src/foreign/foreign.rktc
View File

@ -1847,6 +1847,51 @@ cdefine[register-finalizer 2 3]{
typedef void(*VoidFun)(); 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[]) Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
/* data := {name, c-function, itypes, otype, cif} */ /* 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 *otype = SCHEME_VEC_ELS(data)[3];
Scheme_Object *base; Scheme_Object *base;
ffi_cif *cif = (ffi_cif*)(SCHEME_VEC_ELS(data)[4]); 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]); 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; int nargs = cif->nargs;
/* When the foreign function is called, we need an array (ivals) of 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 * 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 */ /* 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 (save_errno != 0) save_errno_values(save_errno);
if (ivals != stack_ivals) free(ivals); if (ivals != stack_ivals) free(ivals);
ivals = NULL; /* no need now to hold on to this */ ivals = NULL; /* no need now to hold on to this */
@ -1967,9 +2020,9 @@ void free_fficall_data(void *ignored, void *p)
free(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 */ /* 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; static Scheme_Object *ffi_name_prefix = NULL;
Scheme_Object *itypes = argv[1]; Scheme_Object *itypes = argv[1];
Scheme_Object *otype = argv[2]; 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_type *rtype, **atypes;
GC_CAN_IGNORE ffi_cif *cif; GC_CAN_IGNORE ffi_cif *cif;
int i, nargs, save_errno; 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); MZ_REGISTER_STATIC(ffi_name_prefix);
if (!ffi_name_prefix) if (!ffi_name_prefix)
ffi_name_prefix = scheme_make_byte_string_without_copying("ffi:"); ffi_name_prefix = scheme_make_byte_string_without_copying("ffi:");
@ -2011,6 +2070,12 @@ void free_fficall_data(void *ignored, void *p)
} }
} else } else
save_errno = 0; 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*)); atypes = malloc(nargs * sizeof(ffi_type*));
for (i=0, p=itypes; i<nargs; i++, p=SCHEME_CDR(p)) { for (i=0, p=itypes; i<nargs; i++, p=SCHEME_CDR(p)) {
if (NULL == (base = get_ctype_base(SCHEME_CAR(p)))) if (NULL == (base = get_ctype_base(SCHEME_CAR(p))))
@ -2022,7 +2087,7 @@ void free_fficall_data(void *ignored, void *p)
cif = malloc(sizeof(ffi_cif)); cif = malloc(sizeof(ffi_cif));
if (ffi_prep_cif(cif, abi, nargs, rtype, atypes) != FFI_OK) if (ffi_prep_cif(cif, abi, nargs, rtype, atypes) != FFI_OK)
scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK"); scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK");
data = scheme_make_vector(7, NULL); data = scheme_make_vector(FFI_CALL_VEC_SIZE, NULL);
p = scheme_append_byte_string p = scheme_append_byte_string
(ffi_name_prefix, (ffi_name_prefix,
scheme_make_byte_string_without_copying scheme_make_byte_string_without_copying
@ -2035,6 +2100,9 @@ void free_fficall_data(void *ignored, void *p)
SCHEME_VEC_ELS(data)[4] = (Scheme_Object*)cif; SCHEME_VEC_ELS(data)[4] = (Scheme_Object*)cif;
SCHEME_VEC_ELS(data)[5] = scheme_make_integer(ooff); SCHEME_VEC_ELS(data)[5] = scheme_make_integer(ooff);
SCHEME_VEC_ELS(data)[6] = scheme_make_integer(save_errno); 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); scheme_register_finalizer(data, free_fficall_data, cif, NULL, NULL);
return scheme_make_closed_prim_w_arity return scheme_make_closed_prim_w_arity
(ffi_do_call, (void*)data, SCHEME_BYTE_STR_VAL(p), (ffi_do_call, (void*)data, SCHEME_BYTE_STR_VAL(p),
@ -2163,6 +2231,23 @@ void scheme_check_foreign_work(void)
} while (qc); } 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 #endif
@ -2500,6 +2585,12 @@ void scheme_init_foreign_globals()
void scheme_init_foreign_places() { void scheme_init_foreign_places() {
MZ_REGISTER_STATIC(opened_libs); MZ_REGISTER_STATIC(opened_libs);
opened_libs = scheme_make_hash_table(SCHEME_hash_string); 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) void scheme_init_foreign(Scheme_Env *env)