ffi: add `#:in-original-place?' to deal with thread-unsafe libs
and use it for Pango, which is not thread-safe at the C level
This commit is contained in:
Matthew Flatt
parent
c5816ab6f9
commit
49aadc599a
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ::)
|
||||
|
|
|
|||
|
|
@ -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; 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) {
|
||||
scheme_wrong_type(MYNAME, "'posix, 'windows, or #f", 4, argc, argv);
|
||||
}
|
||||
} else
|
||||
save_errno = 0;
|
||||
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);
|
||||
}
|
||||
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(7, 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);
|
||||
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",
|
||||
|
|
|
|||
|
|
@ -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; i<nargs; i++, p=SCHEME_CDR(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));
|
||||
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(7, NULL);
|
||||
data = scheme_make_vector(FFI_CALL_VEC_SIZE, NULL);
|
||||
p = scheme_append_byte_string
|
||||
(ffi_name_prefix,
|
||||
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)[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),
|
||||
|
|
@ -2163,6 +2231,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
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user