diff --git a/pkgs/racket-doc/openssl/openssl.scrbl b/pkgs/racket-doc/openssl/openssl.scrbl index 03a6c958a0..3911dd893a 100644 --- a/pkgs/racket-doc/openssl/openssl.scrbl +++ b/pkgs/racket-doc/openssl/openssl.scrbl @@ -29,8 +29,10 @@ or with the Racket distribution. In particular: included in the Racket distribution for Windows.} @item{For Mac OS X, @racketmodname[openssl] depends on -@filepath{libssl.dylib} and @filepath{libcrypto.dylib}, which are -provided by Mac OS X 10.2 and later.} +@filepath{libssl.dylib} and @filepath{libcrypto.dylib}. Although those +libraries are provided by Mac OS X 10.2 and later, their use is +deprecated, so the Racket distribution for Mac OS X includes newer +versions.} @item{For Unix, @racketmodname[openssl] depends on @filepath{libssl.so} and @filepath{libcrypto.so}, which must be diff --git a/racket/collects/net/http-client.rkt b/racket/collects/net/http-client.rkt index 79d7de5ddf..381e4bb913 100644 --- a/racket/collects/net/http-client.rkt +++ b/racket/collects/net/http-client.rkt @@ -9,6 +9,7 @@ [tcp-abandon-port plain-tcp-abandon-port]) openssl "win32-ssl.rkt" + "osx-ssl.rkt" file/gunzip) (define tolerant? #t) @@ -65,8 +66,13 @@ (cond [ssl? (set-http-conn-port-usual?! hc (= 443 port)) (cond + [(osx-old-openssl?) + ;; OpenSSL is either not available or too old; use + ;; native OS X tools + (set-http-conn-abandon-p! hc osx-ssl-abandon-port) + (osx-ssl-connect host port ssl-version)] [(or ssl-available? (not win32-ssl-available?)) - (set-http-conn-abandon-p! hc ssl-abandon-port) + (set-http-conn-abandon-p! hc ssl-abandon-port) (ssl-connect host port ssl-version)] [else (set-http-conn-abandon-p! hc win32-ssl-abandon-port) diff --git a/racket/collects/net/osx-ssl.rkt b/racket/collects/net/osx-ssl.rkt new file mode 100644 index 0000000000..4311988040 --- /dev/null +++ b/racket/collects/net/osx-ssl.rkt @@ -0,0 +1,462 @@ +#lang racket/base +(require ffi/unsafe + ffi/unsafe/define + ffi/unsafe/nsstring + ffi/unsafe/alloc + ffi/unsafe/atomic + ffi/unsafe/custodian + racket/port + racket/format + openssl) + +(provide osx-ssl-connect + osx-ssl-abandon-port + osx-ssl-output-port? + osx-old-openssl?) + +(define (osx-old-openssl?) + (and (eq? 'macosx (system-type)) + (or (not ssl-available?) + (not (memq 'tls12 (supported-client-protocols)))))) + +(define cf-lib + (and (eq? 'macosx (system-type)) + (ffi-lib "/System/Library/Frameworks/CoreFoundation.framework/CoreFoundation"))) +(define net-lib + (and (eq? 'macosx (system-type)) + (ffi-lib "/System/Library/Frameworks/CFNetwork.framework/CFNetwork"))) + +(define-ffi-definer define-cf cf-lib + #:default-make-fail make-not-available) +(define-ffi-definer define-net net-lib + #:default-make-fail make-not-available) +(define-ffi-definer define-racket #f + #:default-make-fail make-not-available) + +(define _CFReadStreamRef (_cpointer/null 'CFReadStreamRef)) +(define _CFWriteStreamRef (_cpointer/null 'CFWriteStreamRef)) + +(define _CFRunLoopRef (_cpointer/null 'CFRunLoopRef)) + +(define _CFDictionaryRef (_cpointer/null 'CFDictionaryRef)) + +(define _Boolean _bool) +(define _CFIndex _long) + +(define-cf CFRelease (_fun _pointer -> _void) + #:wrap (deallocator)) + +(define retain + ((allocator CFRelease) (lambda (p) p))) + +;; Call in atomic mode to ensure `retain` calls: +(define-cf CFStreamCreatePairWithSocketToHost + (_fun (_pointer = #f) + _NSString + _int32 + (in : (_ptr o _CFReadStreamRef)) + (out : (_ptr o _CFWriteStreamRef)) + -> _void + -> (values (and in (retain in)) (and out (retain out))))) + +(define-cf CFReadStreamScheduleWithRunLoop (_fun _CFReadStreamRef _CFRunLoopRef _pointer -> _void)) +(define-cf CFWriteStreamScheduleWithRunLoop (_fun _CFWriteStreamRef _CFRunLoopRef _pointer -> _void)) + +(define-cf CFReadStreamOpen (_fun _CFReadStreamRef -> _Boolean)) +(define-cf CFWriteStreamOpen (_fun _CFWriteStreamRef -> _Boolean)) + +(define-cf CFReadStreamClose (_fun _CFReadStreamRef -> _void)) +(define-cf CFWriteStreamClose (_fun _CFWriteStreamRef -> _void)) + +(define-cf CFReadStreamHasBytesAvailable (_fun _CFReadStreamRef -> _Boolean)) +(define-cf CFReadStreamRead (_fun _CFReadStreamRef _pointer _CFIndex -> _CFIndex)) + +(define-cf CFWriteStreamCanAcceptBytes (_fun _CFWriteStreamRef -> _Boolean)) +(define-cf CFWriteStreamWrite (_fun _CFWriteStreamRef _pointer _CFIndex -> _CFIndex)) + +(define-cf kCFRunLoopDefaultMode _pointer) + +(define-cf CFRunLoopStop (_fun _CFRunLoopRef -> _void)) + +(define-cstruct _CFStreamError ([domain _int] + [error _int32])) + +(define-cf CFReadStreamGetError (_fun _CFReadStreamRef -> _CFStreamError)) +(define-cf CFWriteStreamGetError (_fun _CFWriteStreamRef -> _CFStreamError)) + +(define-cf NSStreamSocketSecurityLevelNegotiatedSSL _pointer) +(define-cf NSStreamSocketSecurityLevelKey _pointer) + +(define-net kCFStreamPropertySSLSettings _pointer) +(define-net kCFStreamSSLValidatesCertificateChain _pointer) +(define-net kCFStreamSSLLevel _pointer) + +(define-cf kCFBooleanFalse _pointer) +(define-cf kCFBooleanTrue _pointer) + +(define-net kCFStreamSocketSecurityLevelSSLv2 _pointer) +(define-net kCFStreamSocketSecurityLevelSSLv3 _pointer) +(define-net kCFStreamSocketSecurityLevelTLSv1 _pointer) +(define-net kCFStreamSocketSecurityLevelNegotiatedSSL _pointer) + +(define-cf CFReadStreamSetProperty (_fun _CFReadStreamRef _pointer _pointer -> _Boolean)) +(define-cf CFWriteStreamSetProperty (_fun _CFWriteStreamRef _pointer _pointer -> _Boolean)) + +(define-cstruct _CFStreamClientContext ([version _CFIndex] + [info _pointer] + [retain _pointer] + [release _pointer] + [copy _pointer])) + +(define-cf CFReadStreamSetClient (_fun _CFReadStreamRef + _int + (_fun #:atomic? #t + #:async-apply (lambda (f) (f)) + _CFReadStreamRef _int _pointer -> _void) + _CFStreamClientContext-pointer + -> _Boolean)) +(define-cf CFWriteStreamSetClient (_fun _CFWriteStreamRef + _int + (_fun #:atomic? #t + #:async-apply (lambda (f) (f)) + _CFWriteStreamRef _int _pointer -> _void) + _CFStreamClientContext-pointer + -> _Boolean)) + +(define kCFStreamEventNone 0) +(define kCFStreamEventOpenCompleted 1) +(define kCFStreamEventHasBytesAvailable 2) +(define kCFStreamEventCanAcceptBytes 4) +(define kCFStreamEventErrorOccurred 8) +(define kCFStreamEventEndEncountered 16) + +(define all-evts (bitwise-ior + kCFStreamEventOpenCompleted + kCFStreamEventHasBytesAvailable + kCFStreamEventCanAcceptBytes + kCFStreamEventErrorOccurred + kCFStreamEventEndEncountered)) + +(define _CFStreamStatus + (_enum '(kCFStreamStatusNotOpen + kCFStreamStatusOpening + kCFStreamStatusOpen + kCFStreamStatusReading + kCFStreamStatusWriting + kCFStreamStatusAtEnd + kCFStreamStatusClosed + kCFStreamStatusError))) + +(define-cf CFReadStreamGetStatus + (_fun _CFReadStreamRef -> _CFStreamStatus)) +(define-cf CFWriteStreamGetStatus + (_fun _CFWriteStreamRef -> _CFStreamStatus)) + + +(define-cf CFDictionaryCreate + (_fun (_pointer = #f) + (keys : (_list i _pointer)) + (vals : (_list i _pointer)) + (_CFIndex = (length keys)) + (_pointer = #f) + (_pointer = #f) + -> _CFDictionaryRef) + #:wrap (allocator CFRelease)) + +;; ---------------------------------------- + +(define-cstruct _Scheme_Proc_Sequence ([num_procs _racket] + [data _pointer] + [proc1 _pointer] + [proc2 (_fun #:atomic? #t #:async-apply (lambda (f) (f)) _pointer -> _pointer)] + [proc3 _pointer] + [proc4 (_fun #:atomic? #t #:async-apply (lambda (f) (f)) -> _pointer)]) + #:malloc-mode 'nonatomic) + +(define-racket scheme_signal_received (_fun -> _void)) + +(define _pthread (_cpointer/null 'pthread)) + +(define-racket pthread_create + (_fun (p : (_ptr o _pthread)) _pointer _pointer _pointer + -> (r : _int) + -> (and (zero? r) + p))) +(define-racket pthread_detach + (_fun _pointer -> _int)) + +(define-racket scheme_call_sequence_of_procedures-ptr _fpointer + #:c-id scheme_call_sequence_of_procedures) + +(define-cf CFRunLoopRun-ptr _fpointer + #:c-id CFRunLoopRun) +(define-cf CFRunLoopGetCurrent-ptr _fpointer + #:c-id CFRunLoopGetCurrent) + +(define stop-and-release + ((deallocator) + (lambda (run-loop) + (CFRunLoopStop run-loop) + (CFReleaseRunLoop run-loop)))) + +(define-cf CFRetainRunLoop (_fun _CFRunLoopRef -> _CFRunLoopRef) + #:c-id CFRetain + #:wrap (allocator stop-and-release)) +(define-cf CFReleaseRunLoop (_fun _pointer -> _void) + #:c-id CFRelease) + +(define (launch-run-loop-in-pthread init-reg more-retain) + (define run-loop #f) + (define done (make-semaphore)) + (define (setup r) + ;; Called in atomic mode in arbitrary Racket thread: + (set! run-loop (CFRetainRunLoop (cast r _pointer _CFRunLoopRef))) + (init-reg run-loop) + (semaphore-post done) + (scheme_signal_received) + #f) + (define (finished) + (free-immobile-cell retainer) + #f) + ;; Retains callbacks until the thread is done: + (define retainer (malloc-immobile-cell + (vector setup finished more-retain))) + (define seq (make-Scheme_Proc_Sequence 4 + #f + CFRunLoopGetCurrent-ptr + ;; `#:aync-apply` moves the following + ;; back to the main thread (in atomic mode): + setup + CFRunLoopRun-ptr + ;; `#:async-apply` here, too: + finished)) + (define pth (pthread_create #f scheme_call_sequence_of_procedures-ptr seq)) + (unless pth (error "could not start run-loop thread")) + (pthread_detach pth) + + (semaphore-wait done) + (set! done seq) ; retains `seq` until here + + run-loop) + +;; ---------------------------------------- + +(define (osx-ssl-connect host port [protocol 'auto]) + (define-syntax-rule (check-ok (op arg ...)) + (unless (op arg ...) + (error 'op "failed"))) + + (define-values (in out) + (call-as-atomic + (lambda () + (CFStreamCreatePairWithSocketToHost host port)))) + + (check-ok (CFReadStreamSetProperty in + NSStreamSocketSecurityLevelKey + NSStreamSocketSecurityLevelNegotiatedSSL)) + (check-ok (CFWriteStreamSetProperty out + NSStreamSocketSecurityLevelKey + NSStreamSocketSecurityLevelNegotiatedSSL)) + + (unless (eq? protocol 'secure) + (define d (CFDictionaryCreate + (list kCFStreamSSLValidatesCertificateChain + kCFStreamSSLLevel) + (list kCFBooleanFalse + (case protocol + [(sslv2) kCFStreamSocketSecurityLevelSSLv2] + [(sslv3) kCFStreamSocketSecurityLevelSSLv3] + [(tls tls11 tls12) kCFStreamSocketSecurityLevelTLSv1] + [else kCFStreamSocketSecurityLevelNegotiatedSSL])))) + (check-ok (CFReadStreamSetProperty in kCFStreamPropertySSLSettings d)) + (check-ok (CFWriteStreamSetProperty out kCFStreamPropertySSLSettings d)) + (CFRelease d)) + + (define in-ready (make-semaphore)) + (define out-ready (make-semaphore 1)) + + ;; These callback must be retained so that they're not GCed + ;; until the run loop is terminated: + (define in-callback (lambda (_in evt _null) + (void (semaphore-try-wait? in-ready)) + (semaphore-post in-ready) + (scheme_signal_received))) + (define out-callback (lambda (_out evt _null) + (void (semaphore-try-wait? out-ready)) + (semaphore-post out-ready) + (scheme_signal_received))) + + (define context (make-CFStreamClientContext 0 #f #f #f #f)) + (check-ok (CFReadStreamSetClient in all-evts in-callback context)) + (check-ok (CFWriteStreamSetClient out all-evts out-callback context)) + + (define run-loop + (launch-run-loop-in-pthread + ;; This function will be called as atomic within the scheduler: + (lambda (run-loop) + (CFReadStreamScheduleWithRunLoop in run-loop kCFRunLoopDefaultMode) + (CFWriteStreamScheduleWithRunLoop out run-loop kCFRunLoopDefaultMode)) + (list in-callback out-callback))) + + (check-ok (CFWriteStreamOpen out)) + (check-ok (CFReadStreamOpen in)) + + (let loop () + (when (or (eq? (CFReadStreamGetStatus in) 'kCFStreamStatusOpening) + (eq? (CFWriteStreamGetStatus out) 'kCFStreamStatusOpening)) + (sync in-ready out-ready) + (loop))) + + (when (or (eq? (CFReadStreamGetStatus in) 'kCFStreamStatusError) + (eq? (CFWriteStreamGetStatus out) 'kCFStreamStatusError)) + (raise + (exn:fail:network + (~a "osx-ssl-connect: connection failed\n" + " address: " host "\n" + " port number: " port) + (current-continuation-marks)))) + + (define open-count 2) + (define skip-close-out? #f) + + (define in-cust-reg (register-custodian-shutdown in (lambda (v) (close!)))) + (define out-cust-reg (register-custodian-shutdown out (lambda (v) (close!)))) + + (define (close!) + (call-as-atomic + (lambda () + (set! open-count (sub1 open-count)) + (when (zero? open-count) + (unregister-custodian-shutdown in in-cust-reg) + (unregister-custodian-shutdown out out-cust-reg) + (stop-and-release run-loop) + (CFRelease in) + (CFRelease out))))) + + (define-values (in-buffer-in in-buffer-out) (make-pipe)) + (define IN-BUFFER-SIZE 4096) + (define in-buffer (make-bytes IN-BUFFER-SIZE)) + + (define lock (make-semaphore 1)) + + ;; Callbacks used below (written here so that they're allocated once): + (define (lock-unavailable/read) (wrap-evt lock (lambda () 0))) + (define (lock-unavailable/write) (wrap-evt lock (lambda () #f))) + + (define (read-in bstr) + (define n (read-bytes-avail!* bstr in-buffer-in)) + (cond + [(positive? n) n] + [(zero? n) + (void (semaphore-try-wait? in-ready)) + (cond + [(CFReadStreamHasBytesAvailable in) + (define use-bstr + (if ((bytes-length bstr) . < . IN-BUFFER-SIZE) + in-buffer + bstr)) + (define n (CFReadStreamRead in use-bstr (bytes-length use-bstr))) + (cond + [(zero? n) eof] + [(negative? n) + (raise-osx-ssl-network-error 'read-bytes + (CFReadStreamGetError in))] + [else + (cond + [(eq? use-bstr in-buffer) + (write-bytes in-buffer in-buffer-out 0 n) + ;; Try again: + 0] + [else n])])] + [(equal? (CFReadStreamGetStatus in) + 'kCFStreamStatusError) + (raise-osx-ssl-network-error 'read-bytes + (CFReadStreamGetError in))] + [else + (wrap-evt (semaphore-peek-evt in-ready) (lambda (v) 0))])])) + + (define (write-out bstr start end buffer? breakable?) + (cond + [(= start end) 0] + [else + (void (semaphore-try-wait? out-ready)) + (cond + [(CFWriteStreamCanAcceptBytes out) + (let ([n (CFWriteStreamWrite out + (if (zero? start) + bstr + (substring bstr start end)) + (- end start))]) + (cond + [(zero? n) + (wrap-evt always-evt (lambda (v) #f))] + [(n . < . -1) + (raise-osx-ssl-network-error 'write-bytes + (CFWriteStreamGetError out))] + [else n]))] + [(equal? (CFWriteStreamGetStatus out) + 'kCFStreamStatusError) + (raise-osx-ssl-network-error 'write-bytes + (CFWriteStreamGetError out))] + [else + (wrap-evt (semaphore-peek-evt out-ready) (lambda (v) #f))])])) + + (values (make-input-port/read-to-peek + 'osx-ssl + ;; read: + (lambda (bstr) + (call-with-semaphore + lock + read-in + lock-unavailable/read + bstr)) + ;; peek: + (lambda (bstr offset slow) + ;; Try fast peek on buffer port: + (define n (peek-bytes-avail!* bstr offset #f in-buffer-in)) + (if (zero? n) + (slow bstr offset) + n)) + (lambda () + (call-with-semaphore + lock + (lambda () + (CFReadStreamClose in) + (close!))))) + + (osx-ssl-output-port + (make-output-port + 'osx-ssl + (semaphore-peek-evt out-ready) + ;; write + (lambda (bstr start end non-block? enable-break?) + (call-with-semaphore + lock + write-out + lock-unavailable/write + bstr start end non-block? enable-break?)) + ;; close + (lambda () + (call-with-semaphore + lock + (lambda () + (unless skip-close-out? + (CFWriteStreamClose out)) + (close!))))) + ;; abandon: + (lambda (self) + (set! skip-close-out? #t) + (close-output-port self))))) + +(struct osx-ssl-output-port (port abandon) + #:property prop:output-port 0) + +(define (osx-ssl-abandon-port p) + (if (osx-ssl-output-port? p) + ((osx-ssl-output-port-abandon p) p) + (close-output-port p))) + +(define (raise-osx-ssl-network-error who err) + (exn:fail:network + (~a who ": failed " (CFStreamError->list err)) + (current-continuation-marks))) diff --git a/racket/collects/net/url-connect.rkt b/racket/collects/net/url-connect.rkt index d644cac826..b722c48363 100644 --- a/racket/collects/net/url-connect.rkt +++ b/racket/collects/net/url-connect.rkt @@ -4,7 +4,8 @@ [tcp-connect plain-tcp-connect] [tcp-abandon-port plain-tcp-abandon-port]) openssl - "win32-ssl.rkt") + "win32-ssl.rkt" + "osx-ssl.rkt") (provide (all-defined-out)) @@ -16,14 +17,19 @@ ;; `current-connect-scheme' (define (tcp-connect host port) (cond [(equal? (current-connect-scheme) "https") - (if (or ssl-available? - (not win32-ssl-available?)) - (ssl-connect host port (current-https-protocol)) - (win32-ssl-connect host port (current-https-protocol)))] + (cond + [(osx-old-openssl?) + (osx-ssl-connect host port (current-https-protocol))] + [(or ssl-available? + (not win32-ssl-available?)) + (ssl-connect host port (current-https-protocol))] + [else + (win32-ssl-connect host port (current-https-protocol))])] [else (plain-tcp-connect host port)])) (define (tcp-abandon-port port) (cond [(ssl-port? port) (ssl-abandon-port port)] [(win32-ssl-port? port) (win32-ssl-abandon-port port)] + [(osx-ssl-output-port? port) (osx-ssl-abandon-port port)] [else (plain-tcp-abandon-port port)])) diff --git a/racket/collects/openssl/libcrypto.rkt b/racket/collects/openssl/libcrypto.rkt index 8eeefd4120..772e9b5d1a 100644 --- a/racket/collects/openssl/libcrypto.rkt +++ b/racket/collects/openssl/libcrypto.rkt @@ -44,6 +44,9 @@ (define-runtime-path libcrypto-so (case (system-type) [(windows) '(so "libeay32")] + [(macosx) + ;; Version "1.0.0" is bundled with Racket + '(so "libcrypto" ("1.0.0" #f))] [else '(so "libcrypto")])) (define libcrypto diff --git a/racket/collects/openssl/libssl.rkt b/racket/collects/openssl/libssl.rkt index 122a346fa1..214b4fe28a 100644 --- a/racket/collects/openssl/libssl.rkt +++ b/racket/collects/openssl/libssl.rkt @@ -14,6 +14,9 @@ (define-runtime-path libssl-so (case (system-type) [(windows) '(so "ssleay32")] + [(macosx) + ;; Version "1.0.0" is bundled with Racket + '(so "libssl" ("1.0.0" #f))] [else '(so "libssl")])) (define libssl diff --git a/racket/src/native-libs/build-all.rkt b/racket/src/native-libs/build-all.rkt index d13ff7ec50..5ba42c0682 100644 --- a/racket/src/native-libs/build-all.rkt +++ b/racket/src/native-libs/build-all.rkt @@ -18,11 +18,11 @@ (cond [(or win? linux?) '("sqlite" - "openssl" "zlib")] [else null]) - '("expat" + '("openssl" + "expat" "gettext") (cond [linux? diff --git a/racket/src/native-libs/build.rkt b/racket/src/native-libs/build.rkt index f955c40eae..29dcc51512 100644 --- a/racket/src/native-libs/build.rkt +++ b/racket/src/native-libs/build.rkt @@ -314,21 +314,33 @@ (~a "cd " (build-path dest "bin") " && mv libsqlite3-0.dll sqlite3.dll")))] [("openssl") - (nonmac-only) + (define make + (if linux? + (~a "make SHARED_LDFLAGS=" "-Wl,-rpath," dest "/lib") + "make")) (config #:configure-exe (find-executable-path "sh") - #:configure (if win? - (list "./Configure" - (~a "--cross-compile-prefix=" win-prefix "-") - #f ; other flags here - (~a "mingw" (if m32? "" "64")) - "shared") - (list "./Configure" - #f - "shared" - "linux-x86_64")) - #:make (if linux? - (~a "make SHARED_LDFLAGS=" "-Wl,-rpath," dest "/lib") - "make"))] + #:configure (cond + [win? + (list "./Configure" + (~a "--cross-compile-prefix=" win-prefix "-") + #f ; other flags here + (~a "mingw" (if m32? "" "64")) + "shared")] + [mac? + (list "./Configure" + #f + "shared" + (cond + [ppc? "darwin-ppc-cc"] + [m32? "darwin-i386-cc"] + [else "darwin64-x86_64-cc"]))] + [else + (list "./Configure" + #f + "shared" + "linux-x86_64")]) + #:make make + #:make-install (~a make " install_sw"))] [("expat") (config)] [("gettext") (config #:depends (if win? '("libiconv") '()) #:configure '("--enable-languages=c") diff --git a/racket/src/native-libs/install.rkt b/racket/src/native-libs/install.rkt index 728d9e72ad..beda881d3b 100644 --- a/racket/src/native-libs/install.rkt +++ b/racket/src/native-libs/install.rkt @@ -39,6 +39,10 @@ "zlib1" "libpangowin32-1.0.0")) +(define nonwin-libs + '("libcrypto.1.0.0" + "libssl.1.0.0")) + (define linux-libs (append '("libXau.6" @@ -49,9 +53,7 @@ "libXext.6" "libXrender.1" "fonts") - '("libcrypto.1.0.0" - "libssl.1.0.0" - "libz.1" + '("libz.1" "libsqlite3.0") '("libgtk-x11-2.0.0" "libgdk-x11-2.0.0" @@ -323,6 +325,8 @@ (define (install-mac) (define (fixup p p-new) (printf "Fixing ~s\n" p-new) + (unless (memq 'write (file-or-directory-permissions p-new)) + (file-or-directory-permissions p-new #o744)) (system (format "install_name_tool -id ~a ~a" (file-name-from-path p-new) p-new)) (for-each (lambda (s) (system (format "install_name_tool -change ~a @loader_path/~a ~a" @@ -337,7 +341,7 @@ "x86_64") "-macosx")) - (install platform platform "dylib" fixup libs)) + (install platform platform "dylib" fixup (append libs nonwin-libs))) (define (install-win) (define exe-prefix (if m32? @@ -398,6 +402,7 @@ (install platform platform add-so fixup (append (remove* linux-remove-libs libs) + nonwin-libs linux-libs))) (cond diff --git a/racket/src/racket/src/port.c b/racket/src/racket/src/port.c index c5202e4205..00ec531b0b 100644 --- a/racket/src/racket/src/port.c +++ b/racket/src/racket/src/port.c @@ -11310,6 +11310,48 @@ void scheme_end_sleeper_thread() #endif +/*========================================================================*/ +/* thread helper */ +/*========================================================================*/ + +/* The scheme_call_sequence() functionc an be used, with some care, + via the FFI to run a computation in a foreign thread and thread + results through. Keeping the number of procedures below + `NUM_COPIED_SEQUENCE_PROCS` can potentially simplify things, too */ + +#define NUM_COPIED_SEQUENCE_PROCS 5 + +typedef void *(*Scheme_Sequenced_Proc)(void *); + +struct Scheme_Proc_Sequence { + Scheme_Object *num_procs; /* pointer simplifies allocation issues */ + void *init_data; + Scheme_Sequenced_Proc p[mzFLEX_ARRAY_DECL]; +}; + +void *scheme_call_sequence_of_procedures(struct Scheme_Proc_Sequence *s) + XFORM_SKIP_PROC +{ + int i, num_procs = SCHEME_INT_VAL(s->num_procs); + void *data = s->init_data; + Scheme_Sequenced_Proc copied[NUM_COPIED_SEQUENCE_PROCS]; + + if (num_procs <= NUM_COPIED_SEQUENCE_PROCS) { + for (i = 0; i < num_procs; i++) { + copied[i] = s->p[i]; + } + } + + for (i = 0; i < num_procs; i++) { + if (num_procs <= NUM_COPIED_SEQUENCE_PROCS) + data = copied[i](data); + else + data = s->p[i](data); + } + + return data; +} + /*========================================================================*/ /* memory debugging help */ /*========================================================================*/