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

add some unsafe operations as an alternative to FFI access

Browse Source 
Accessing unsafe functionality through the FFI seemed like a good way
to avoid writing C code, but it made things more complicated instead
of easier, and it interacts badly with a more agressive shift away
from C (such as porting to Chez Scheme). So, add functions to the
primitive `#%unsafe` module, instead.
This commit is contained in:
Matthew Flatt 2017-05-26 15:44:10 -06:00
parent 7f1ab90806
commit bf83d1126d
18 changed files with 337 additions and 261 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/base/info.rkt
View File

@ -12,7 +12,7 @@
(define collection 'multi)
(define version "6.9.0.4")
(define version "6.9.0.5")
(define deps `("racket-lib"
["racket" #:version ,version]))

12
pkgs/racket-doc/scribblings/foreign/custodian.scrbl
View File

@ -64,3 +64,15 @@ about to be collected by the garbage collector, whichever happens
first. The @racket[callback] is only applied to @racket[v] once.
@history[#:added "6.1.1.6"]}
@defproc[(make-custodian-at-root) custodian?]{
Creates a custodian that is a child of the root custodian, bypassing
the @racket[current-custodian] setting.
Creating a child of the root custodian is useful for registering a
shutdown function that will be triggered only when the current place
terminates.
@history[#:added "6.9.0.5"]}

4
pkgs/racket-doc/scribblings/reference/bytes.scrbl
View File

@ -362,7 +362,7 @@ For communication among @tech{places}, the new byte string is allocated in the
[err-char (or/c #f char?) #f]
[start exact-nonnegative-integer? 0]
[end exact-nonnegative-integer? (bytes-length bstr)])
char?]{
(or/c char? #f)]{
Returns the @racket[skip]th character in the UTF-8 decoding of
@racket[bstr]'s substring from @racket[start] to @racket[end], but without
actually generating the other decoded characters. If the substring is
@ -386,7 +386,7 @@ For communication among @tech{places}, the new byte string is allocated in the
[err-char (or/c #f char?) #f]
[start exact-nonnegative-integer? 0]
[end exact-nonnegative-integer? (bytes-length bstr)])
exact-nonnegative-integer?]{
(or/c exact-nonnegative-integer? #f)]{
Returns the offset in bytes into @racket[bstr] at which the @racket[skip]th
character's encoding starts in the UTF-8 decoding of @racket[bstr]'s
substring from @racket[start] to @racket[end] (but without actually

151
racket/collects/ffi/file.rkt
View File

@ -1,146 +1,9 @@
#lang racket/base
(require ffi/unsafe)
(require (only-in '#%paramz
security-guard-check-file
security-guard-check-file-link
security-guard-check-network))
(provide security-guard-check-file
_file/guard
_file/r
_file/rw)
(define SCHEME_GUARD_FILE_READ #x1)
(define SCHEME_GUARD_FILE_WRITE #x2)
(define SCHEME_GUARD_FILE_EXECUTE #x4)
(define SCHEME_GUARD_FILE_DELETE #x8)
(define SCHEME_GUARD_FILE_EXISTS #x10)
(define scheme_security_check_file
(get-ffi-obj "scheme_security_check_file" (ffi-lib #f)
(_fun _symbol _path _int -> _void)))
(define (convert-modes who guards)
(unless (list? guards)
(raise-argument-error who "(listof symbol?)" guards))
(let ([read? 0]
[write? 0]
[execute? 0]
[delete? 0]
[exists? 0])
(for-each (lambda (guard)
(case guard
((read) (set! read? SCHEME_GUARD_FILE_READ))
((write) (set! write? SCHEME_GUARD_FILE_WRITE))
((execute) (set! execute? SCHEME_GUARD_FILE_EXECUTE))
((delete) (set! delete? SCHEME_GUARD_FILE_DELETE))
((exists) (set! exists? SCHEME_GUARD_FILE_EXISTS))
(else (raise-arguments-error who "bad permission symbol" "symbol" guard))))
guards)
(when (and (positive? exists?)
(positive? (+ read? write? execute? delete?)))
(raise-arguments-error who "permission 'exists must occur alone"
"permissions" guards))
(+ read? write? execute? delete? exists?)))
(define (security-guard-check-file who path modes)
(unless (symbol? who)
(raise-argument-error 'security-guard-check-file "symbol?" 0 who path modes))
(unless (or (path? path) (path-string? path))
(raise-argument-error 'security-guard-check-file "path-string?" 1 who path modes))
(let ([cp (cleanse-path (path->complete-path path))]
[mode (convert-modes 'security-guard-check-file modes)])
(scheme_security_check_file who cp mode)))
(define (_file/guard modes [who '_file/guard])
(let ([mode (convert-modes '_file/guard modes)])
(unless (symbol? who)
(raise-argument-error '_file/guard "symbol?" who))
(make-ctype
_path
(lambda (p)
(let ([cp (cleanse-path (path->complete-path p))])
(scheme_security_check_file who cp mode)
cp))
#f)))
(define _file/r (_file/guard '(read) '_file/r))
(define _file/rw (_file/guard '(read write) '_file/rw))
#|
;; -- Tests --
(require rackunit
racket/runtime-path)
(define-runtime-module-path pub-mod0 racket/list)
(define-runtime-module-path priv-mod0 racket/private/stx)
(define pub-mod (resolved-module-path-name pub-mod0))
(define priv-mod (resolved-module-path-name priv-mod0))
(define (mk-fun modes)
;; receives path pointer, casts as int, who cares
(get-ffi-obj "scheme_make_integer_value" (ffi-lib #f)
(_fun (path) ::
(path : (_file/guard modes))
-> _scheme)))
(define (fun path modes)
((mk-fun modes) path))
(define sg0 (current-security-guard))
(define sg-ro
(make-security-guard
sg0
(lambda (who path modes)
(when (or (memq 'write modes) (memq 'delete modes))
(error who "write/delete not allowed")))
void void))
(define sg-priv
(make-security-guard
sg0
(lambda (who path modes)
(when (and path (regexp-match #rx"private" (path->string path)))
(error who "no access to private paths: ~e" path)))
void void))
;; Test works on both strings and paths, rel and abs.
(define-syntax-rule (check-ok expr) (check-not-exn (lambda () expr)))
(define-syntax-rule (check-err expr) (check-exn exn:fail? (lambda () expr)))
(define-syntax-rule (run1 expr ok?)
(void
(if ok?
(check-not-exn (lambda () expr))
(check-exn exn:fail? (lambda () expr)))))
(define (run path modes ok?)
(run1 (security-guard-check-file 'me path modes) ok?)
(run1 (fun path modes) ok?))
(test-case "default security guard"
(parameterize ((current-security-guard sg0))
(run "foo.txt" '(read) #t)
(run "bar.txt" '(write delete) #t)
(run pub-mod '(read) #t)
(run pub-mod '(write) #t)
(run priv-mod '(read) #t)
(run priv-mod '(read write delete) #t)))
(test-case "read-only security-guard"
(parameterize ((current-security-guard sg-ro))
(run "foo.txt" '(read) #t)
(run "bar.txt" '(write delete) #f)
(run pub-mod '(read) #t)
(run pub-mod '(write) #f)
(run priv-mod '(read) #t)
(run priv-mod '(read write delete) #f)))
(test-case "private security-guard"
(parameterize ((current-security-guard sg-priv))
(run pub-mod '(read) #t)
(run pub-mod '(write) #t)
(run priv-mod '(read) #f)
(run priv-mod '(read write delete) #f)))
(provide (all-defined-out))
|#
security-guard-check-file-link
security-guard-check-network)

51
racket/collects/ffi/unsafe.rkt
View File

@ -2,6 +2,7 @@
;; Foreign Racket interface
(require '#%foreign setup/dirs racket/unsafe/ops racket/private/for
(only-in '#%unsafe unsafe-thread-at-root)
(for-syntax racket/base racket/list syntax/stx racket/syntax
racket/struct-info))
@ -1951,39 +1952,25 @@
;; We need to make a thread that runs in a privildged custodian and
;; that doesn't retain the current namespace --- either directly
;; or indirectly through some parameter setting in the current thread.
(let ([priviledged-custodian ((get-ffi-obj 'scheme_make_custodian #f (_fun _pointer -> _scheme)) #f)]
[no-cells ((get-ffi-obj 'scheme_empty_cell_table #f (_fun -> _gcpointer)))]
[min-config ((get-ffi-obj 'scheme_minimal_config #f (_fun -> _gcpointer)))]
[thread/details (get-ffi-obj 'scheme_thread_w_details #f (_fun _scheme
_gcpointer ; config
_gcpointer ; cells
_pointer ; break_cell
_scheme ; custodian
_int ; suspend-to-kill?
-> _scheme))]
[logger (current-logger)]
(let ([logger (current-logger)]
[cweh #f]) ; <- avoids a reference to a module-level binding
(set! cweh call-with-exception-handler)
(set! killer-thread
(thread/details (lambda ()
(let retry-loop ()
(call-with-continuation-prompt
(lambda ()
(cweh
(lambda (exn)
(log-message logger
'error
(if (exn? exn)
(exn-message exn)
(format "~s" exn))
#f)
(abort-current-continuation void))
(lambda ()
(let loop () (will-execute killer-executor) (loop))))))
(retry-loop)))
min-config
no-cells
#f ; default break cell
priviledged-custodian
0))))
(unsafe-thread-at-root
(lambda ()
(let retry-loop ()
(call-with-continuation-prompt
(lambda ()
(cweh
(lambda (exn)
(log-message logger
'error
(if (exn? exn)
(exn-message exn)
(format "~s" exn))
#f)
(abort-current-continuation void))
(lambda ()
(let loop () (will-execute killer-executor) (loop))))))
(retry-loop)))))))
(will-register killer-executor obj finalizer))))

44
racket/collects/ffi/unsafe/custodian.rkt
View File

@ -1,48 +1,26 @@
#lang racket/base
(require ffi/unsafe
ffi/unsafe/atomic)
ffi/unsafe/atomic
(only-in '#%unsafe
unsafe-make-custodian-at-root
unsafe-custodian-register
unsafe-custodian-unregister))
(provide (protect-out register-custodian-shutdown
(provide (protect-out make-custodian-at-root
register-custodian-shutdown
register-finalizer-and-custodian-shutdown
unregister-custodian-shutdown))
(define _Scheme_Custodian_Reference-pointer
(_gcable (_cpointer 'Scheme_Custodian_Reference)))
(define scheme_add_managed
(get-ffi-obj 'scheme_add_managed #f
(_fun _racket _racket _fpointer _racket _int
-> _Scheme_Custodian_Reference-pointer)))
(define scheme_add_managed_close_on_exit
(get-ffi-obj 'scheme_add_managed_close_on_exit #f
(_fun _racket _racket _fpointer _racket
-> _Scheme_Custodian_Reference-pointer)))
(define scheme_remove_managed
(get-ffi-obj 'scheme_remove_managed #f
(_fun _Scheme_Custodian_Reference-pointer _racket -> _void)))
(define (shutdown-callback impl proc+box)
((car proc+box) impl))
(define shutdown-callback-box (box #f))
(define shutdown_callback
(cast shutdown-callback (_fun #:atomic? #t #:keep shutdown-callback-box
_racket _racket -> _void) _fpointer))
(define (make-custodian-at-root)
(unsafe-make-custodian-at-root))
(define (register-custodian-shutdown obj proc [custodian (current-custodian)]
#:at-exit? [at-exit? #f]
#:weak? [weak? #f])
(define proc+box (cons proc
shutdown-callback-box)) ; proc as data -> ffi callback retained
(if at-exit?
(scheme_add_managed_close_on_exit custodian
obj shutdown_callback proc+box)
(scheme_add_managed custodian
obj shutdown_callback proc+box
(if weak? 0 1))))
(unsafe-custodian-register custodian obj proc at-exit? weak?))
(define (unregister-custodian-shutdown obj mref)
(scheme_remove_managed mref obj))
(unsafe-custodian-unregister obj mref))
(define (register-finalizer-and-custodian-shutdown value callback
[custodian (current-custodian)]

34
racket/collects/ffi/unsafe/try-atomic.rkt
View File

@ -1,20 +1,15 @@
#lang racket/base
(require ffi/unsafe
ffi/unsafe/atomic)
ffi/unsafe/atomic
(only-in '#%unsafe
unsafe-abort-current-continuation/no-wind
unsafe-call-with-composable-continuation/no-wind
unsafe-set-on-atomic-timeout!))
(provide call-as-nonatomic-retry-point
can-try-atomic?
try-atomic)
(define scheme_abort_continuation_no_dws
(get-ffi-obj 'scheme_abort_continuation_no_dws #f (_fun _scheme _scheme -> _scheme)))
(define scheme_call_with_composable_no_dws
(get-ffi-obj 'scheme_call_with_composable_no_dws #f (_fun _scheme _scheme -> _scheme)))
(define scheme_set_on_atomic_timeout
(get-ffi-obj 'scheme_set_on_atomic_timeout #f (_fun (_fun _int -> _void) -> _pointer)))
(define scheme_restore_on_atomic_timeout
(get-ffi-obj 'scheme_set_on_atomic_timeout #f (_fun _pointer -> _pointer)))
(define freezer-tag (make-continuation-prompt-tag))
(define freezer-box-key (gensym))
(define in-try-atomic-key (gensym))
@ -66,9 +61,6 @@
(define (can-try-atomic?) (and (freezer-box) (not (in-try-atomic?))))
;; prevent GC of handler while it's installed:
(define saved-ptrs (make-hasheq))
(define (try-atomic thunk default
#:should-give-up? [should-give-up?
(let ([now (current-inexact-milliseconds)])
@ -87,22 +79,21 @@
;; try to do some work:
(let* ([ready? #f]
[done? #f]
[handler (lambda (must-give-up)
[handler (lambda (must-give-up?)
(when (and ready?
(not done?)
(or (positive? must-give-up)
(or must-give-up?
(force-timeout)
(should-give-up?)))
(scheme_call_with_composable_no_dws
(unsafe-call-with-composable-continuation/no-wind
(lambda (proc)
(set-box! b (cons proc (unbox b)))
(scheme_restore_on_atomic_timeout #f)
(scheme_abort_continuation_no_dws
(unsafe-set-on-atomic-timeout! #f)
(unsafe-abort-current-continuation/no-wind
freeze-tag
(lambda () default)))
freeze-tag)
(void)))])
(hash-set! saved-ptrs handler #t)
(with-continuation-mark in-try-atomic-key #t
(let/ec esc ;; esc + dynamic-wind prevents escape via alternate prompt tags
(dynamic-wind
@ -112,7 +103,7 @@
(lambda ()
(call-with-continuation-prompt ; to catch aborts
(lambda ()
(when (scheme_set_on_atomic_timeout handler)
(when (unsafe-set-on-atomic-timeout! handler)
(error 'try-atomic "nested atomic timeout"))
(set! ready? #t)
(begin0
@ -132,7 +123,6 @@
(set! done? #t)
(thunk))))
(lambda ()
(hash-remove! saved-ptrs handler)
(scheme_restore_on_atomic_timeout #f)
(unsafe-set-on-atomic-timeout! #f)
(unless done? (esc (void))))))))])))

8
racket/collects/openssl/mzssl.rkt
View File

@ -29,6 +29,7 @@ TO DO:
ffi/unsafe/atomic
ffi/unsafe/alloc
ffi/file
ffi/unsafe/custodian
racket/list
racket/port
racket/tcp
@ -424,8 +425,6 @@ TO DO:
(define SSL_TLSEXT_ERR_OK 0)
(define SSL_TLSEXT_ERR_NOACK 3)
(define-mzscheme scheme_make_custodian (_fun _pointer -> _scheme))
(define-runtime-path ssl-dh4096-param-path "dh4096.pem")
;; Make this bigger than 4096 to accommodate at least
@ -1147,9 +1146,8 @@ TO DO:
(loop)))))))
(define (kernel-thread thunk)
;; Since we provide #f to scheme_make_custodian,
;; the custodian is managed directly by the root:
(parameterize ([current-custodian (scheme_make_custodian #f)])
;; Run with a custodian that is managed directly by the root custodian:
(parameterize ([current-custodian (make-custodian-at-root)])
(thread thunk)))
(define (make-ssl-output-port mzssl)

2
racket/collects/racket/place.rkt
View File

@ -1,6 +1,6 @@
#lang racket/base
(require (prefix-in pl- '#%place)
(only-in '#%paramz parameterization-key make-custodian-from-main)
(only-in '#%paramz parameterization-key)
(only-in '#%futures processor-count)
'#%place-struct
racket/fixnum

5
racket/collects/racket/place/private/th-place.rkt
View File

@ -1,7 +1,8 @@
#lang racket/base
(require (prefix-in pl- '#%place)
'#%boot
(only-in '#%paramz parameterization-key make-custodian-from-main)
(only-in '#%paramz parameterization-key)
(only-in '#%unsafe unsafe-make-custodian-at-root)
'#%place-struct
racket/fixnum
racket/flonum
@ -48,7 +49,7 @@
(unless (symbol? funcname)
(raise-argument-error 'dynamic-place "symbol?" 1 mod funcname))
(define-values (pch cch) (th-place-channel))
(define cust (make-custodian-from-main))
(define cust (unsafe-make-custodian-at-root))
(define cust-box (make-custodian-box cust #t))
(define result-box (box 0))
(define plumber (make-plumber))

10
racket/collects/racket/unsafe/ops.rkt
View File

@ -14,7 +14,15 @@
unsafe-impersonate-procedure
unsafe-start-atomic unsafe-end-atomic
unsafe-start-breakable-atomic unsafe-end-breakable-atomic
unsafe-in-atomic?)
unsafe-in-atomic?
unsafe-thread-at-root
unsafe-make-custodian-at-root
unsafe-custodian-register
unsafe-custodian-unregister
unsafe-register-process-global
unsafe-set-on-atomic-timeout!
unsafe-abort-current-continuation/no-wind
unsafe-call-with-composable-continuation/no-wind)
(rename-out [new:unsafe-impersonate-procedure unsafe-impersonate-procedure]
[new:unsafe-chaperone-procedure unsafe-chaperone-procedure])
(prefix-out unsafe-

4
racket/src/racket/include/schthread.h
View File

@ -122,7 +122,7 @@ typedef intptr_t objhead;
typedef void (*Scheme_Sleep_Proc)(float seconds, void *fds);
typedef void (*Scheme_On_Atomic_Timeout_Proc)(int must_give_up);
typedef void (*Scheme_On_Atomic_Timeout_Proc)(void *data, int must_give_up);
/* **************************************** */
@ -376,6 +376,7 @@ typedef struct Thread_Local_Variables {
Scheme_Sleep_Proc scheme_place_sleep_;
struct GHBN_Thread_Data *ghbn_thread_data_;
Scheme_On_Atomic_Timeout_Proc on_atomic_timeout_;
void *on_atomic_timeout_data_;
int atomic_timeout_auto_suspend_;
int atomic_timeout_atomic_level_;
void *scheme_inotify_server_;
@ -778,6 +779,7 @@ XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL;
#define scheme_place_sleep XOA (scheme_get_thread_local_variables()->scheme_place_sleep_)
#define ghbn_thread_data XOA (scheme_get_thread_local_variables()->ghbn_thread_data_)
#define on_atomic_timeout XOA (scheme_get_thread_local_variables()->on_atomic_timeout_)
#define on_atomic_timeout_data XOA (scheme_get_thread_local_variables()->on_atomic_timeout_data_)
#define atomic_timeout_auto_suspend XOA (scheme_get_thread_local_variables()->atomic_timeout_auto_suspend_)
#define atomic_timeout_atomic_level XOA (scheme_get_thread_local_variables()->atomic_timeout_atomic_level_)
#define scheme_inotify_server XOA (scheme_get_thread_local_variables()->scheme_inotify_server_)

16
racket/src/racket/src/cstartup.inc
View File

@ -1,5 +1,5 @@
{
SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,57,46,48,46,51,84,0,0,0,0,0,0,0,0,0,0,
SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,57,46,48,46,53,84,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,54,0,0,0,1,0,0,8,0,18,0,
22,0,26,0,31,0,38,0,42,0,47,0,59,0,66,0,69,0,82,0,89,
0,94,0,103,0,109,0,123,0,137,0,140,0,146,0,157,0,159,0,173,0,
@ -102,7 +102,7 @@
EVAL_ONE_SIZED_STR((char *)expr, 2090);
}
{
SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,57,46,48,46,51,84,0,0,0,0,0,0,0,0,0,0,
SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,57,46,48,46,53,84,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,183,0,0,0,1,0,0,8,0,16,0,
29,0,34,0,51,0,63,0,85,0,114,0,158,0,164,0,178,0,193,0,211,
0,223,0,239,0,253,0,19,1,39,1,73,1,90,1,107,1,130,1,145,1,
@ -917,7 +917,7 @@
1,39,16,1,11,16,0,20,27,15,56,9,2,2,2,2,29,11,11,11,11,
11,11,11,9,9,11,11,11,10,47,80,143,39,39,20,122,145,2,1,54,16,
40,2,3,2,4,2,5,2,6,2,7,2,8,2,9,30,2,11,1,20,112,
97,114,97,109,101,116,101,114,105,122,97,116,105,111,110,45,107,101,121,11,6,
97,114,97,109,101,116,101,114,105,122,97,116,105,111,110,45,107,101,121,11,5,
30,2,11,1,23,101,120,116,101,110,100,45,112,97,114,97,109,101,116,101,114,
105,122,97,116,105,111,110,11,4,2,12,2,13,2,14,2,15,2,16,2,17,
2,18,30,2,11,1,19,99,97,99,104,101,45,99,111,110,102,105,103,117,114,
@ -1011,7 +1011,7 @@
EVAL_ONE_SIZED_STR((char *)expr, 19015);
}
{
SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,57,46,48,46,51,84,0,0,0,0,0,0,0,0,0,0,
SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,57,46,48,46,53,84,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,15,0,0,0,1,0,0,8,0,23,0,
48,0,65,0,83,0,105,0,128,0,149,0,171,0,181,0,191,0,199,0,209,
0,217,0,0,0,253,1,0,0,3,1,5,105,110,115,112,48,76,35,37,112,
@ -1042,7 +1042,7 @@
EVAL_ONE_SIZED_STR((char *)expr, 581);
}
{
SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,57,46,48,46,51,84,0,0,0,0,0,0,0,0,0,0,
SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,57,46,48,46,53,84,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,102,0,0,0,1,0,0,8,0,15,0,
26,0,53,0,59,0,73,0,86,0,112,0,129,0,151,0,159,0,171,0,186,
0,202,0,220,0,241,0,253,0,13,1,36,1,60,1,72,1,103,1,108,1,
@ -1485,7 +1485,7 @@
9,20,122,145,2,1,39,16,1,11,16,0,20,27,15,56,9,2,2,2,2,
29,11,11,11,11,11,11,11,9,9,11,11,11,10,43,80,143,39,39,20,122,
145,2,1,44,16,28,2,3,2,4,30,2,6,1,20,112,97,114,97,109,101,
116,101,114,105,122,97,116,105,111,110,45,107,101,121,11,6,30,2,6,1,23,
116,101,114,105,122,97,116,105,111,110,45,107,101,121,11,5,30,2,6,1,23,
101,120,116,101,110,100,45,112,97,114,97,109,101,116,101,114,105,122,97,116,105,
111,110,11,4,30,2,7,74,112,97,116,104,45,115,116,114,105,110,103,63,42,
196,15,2,8,30,2,7,73,114,101,114,111,111,116,45,112,97,116,104,44,196,
@ -1496,7 +1496,7 @@
14,30,2,7,75,102,105,110,100,45,99,111,108,45,102,105,108,101,49,196,4,
30,2,7,78,110,111,114,109,97,108,45,99,97,115,101,45,112,97,116,104,42,
196,11,2,23,2,24,30,2,6,76,114,101,112,97,114,97,109,101,116,101,114,
105,122,101,11,7,16,0,40,42,39,16,0,39,16,16,2,15,2,16,2,8,
105,122,101,11,6,16,0,40,42,39,16,0,39,16,16,2,15,2,16,2,8,
2,12,2,17,2,18,2,11,2,4,2,10,2,3,2,20,2,13,2,14,2,
9,2,19,2,22,55,11,11,11,16,3,2,23,2,21,2,24,16,3,11,11,
11,16,3,2,23,2,21,2,24,42,42,40,12,11,11,16,0,16,0,16,0,
@ -1538,7 +1538,7 @@
EVAL_ONE_SIZED_STR((char *)expr, 10343);
}
{
SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,57,46,48,46,51,84,0,0,0,0,0,0,0,0,0,0,
SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,57,46,48,46,53,84,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,18,0,0,0,1,0,0,8,0,18,0,
22,0,28,0,42,0,56,0,68,0,88,0,102,0,117,0,130,0,135,0,139,
0,151,0,235,0,242,0,20,1,0,0,224,1,0,0,3,1,5,105,110,115,

18
racket/src/racket/src/fun.c
View File

@ -203,6 +203,9 @@ static Scheme_Object *do_cc_guard(Scheme_Object *v, Scheme_Object *cc_guard, Sch
static Scheme_Object *chaperone_unsafe_undefined(int argc, Scheme_Object **argv);
static Scheme_Object *unsafe_abort_continuation_no_dws(int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_call_with_control_no_dws(int argc, Scheme_Object *argv[]);
static Scheme_Object *
scheme_extract_one_cc_mark_with_meta(Scheme_Object *mark_set, Scheme_Object *key,
Scheme_Object *prompt_tag, Scheme_Meta_Continuation **_meta,
@ -765,6 +768,9 @@ scheme_init_unsafe_fun (Scheme_Env *env)
"unsafe-impersonate-procedure",
2, -1),
env);
GLOBAL_PRIM_W_ARITY("unsafe-abort-current-continuation/no-wind", unsafe_abort_continuation_no_dws, 2, 2, env);
GLOBAL_PRIM_W_ARITY("unsafe-call-with-composable-continuation/no-wind", unsafe_call_with_control_no_dws, 2, 2, env);
}
void
@ -7723,6 +7729,12 @@ Scheme_Object *scheme_abort_continuation_no_dws (Scheme_Object *pt, Scheme_Objec
return do_abort_continuation(2, a, 1);
}
static Scheme_Object *unsafe_abort_continuation_no_dws(int argc, Scheme_Object *argv[])
{
/* See scheme_abort_continuation_no_dws() */
return do_abort_continuation(argc, argv, 1);
}
static Scheme_Object *do_call_with_control (int argc, Scheme_Object *argv[], int no_dws)
{
Scheme_Object *prompt_tag;
@ -7769,6 +7781,12 @@ Scheme_Object *scheme_call_with_composable_no_dws (Scheme_Object *proc, Scheme_O
return do_call_with_control(2, a, 1);
}
static Scheme_Object *unsafe_call_with_control_no_dws(int argc, Scheme_Object *argv[])
{
/* See scheme_call_with_composable_no_dws() */
return do_call_with_control(argc, argv, 1);
}
static Scheme_Cont_Mark *copy_cm_shared_on_write(Scheme_Meta_Continuation *mc)
{
Scheme_Cont_Mark *cp;

2
racket/src/racket/src/schemef.h
View File

@ -204,7 +204,7 @@ MZ_EXTERN void scheme_pop_break_enable(Scheme_Cont_Frame_Data *cframe, int post_
MZ_EXTERN Scheme_Object *scheme_abort_continuation_no_dws(Scheme_Object *pt, Scheme_Object *v);
MZ_EXTERN Scheme_Object *scheme_call_with_composable_no_dws(Scheme_Object *proc, Scheme_Object *pt);
MZ_EXTERN Scheme_On_Atomic_Timeout_Proc scheme_set_on_atomic_timeout(Scheme_On_Atomic_Timeout_Proc p);
MZ_EXTERN Scheme_On_Atomic_Timeout_Proc scheme_set_on_atomic_timeout(Scheme_On_Atomic_Timeout_Proc p, void *data);
/*========================================================================*/
/* error handling */

2
racket/src/racket/src/schminc.h
View File

@ -15,7 +15,7 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 1156
#define EXPECTED_UNSAFE_COUNT 133
#define EXPECTED_UNSAFE_COUNT 141
#define EXPECTED_FLFXNUM_COUNT 69
#define EXPECTED_EXTFL_COUNT 45
#define EXPECTED_FUTURES_COUNT 15

4
racket/src/racket/src/schvers.h
View File

@ -13,12 +13,12 @@
consistently.)
*/
#define MZSCHEME_VERSION "6.9.0.4"
#define MZSCHEME_VERSION "6.9.0.5"
#define MZSCHEME_VERSION_X 6
#define MZSCHEME_VERSION_Y 9
#define MZSCHEME_VERSION_Z 0
#define MZSCHEME_VERSION_W 4
#define MZSCHEME_VERSION_W 5
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

229
racket/src/racket/src/thread.c
View File

@ -240,6 +240,7 @@ HOOK_SHARED_OK void (*scheme_notify_multithread)(int on);
HOOK_SHARED_OK void (*scheme_wakeup_on_input)(void *fds);
HOOK_SHARED_OK int (*scheme_check_for_break)(void);
THREAD_LOCAL_DECL(static Scheme_On_Atomic_Timeout_Proc on_atomic_timeout);
THREAD_LOCAL_DECL(static void *on_atomic_timeout_data);
THREAD_LOCAL_DECL(static int atomic_timeout_auto_suspend);
THREAD_LOCAL_DECL(static int atomic_timeout_atomic_level);
@ -371,7 +372,6 @@ static Scheme_Object *evt_p(int argc, Scheme_Object *args[]);
static Scheme_Object *evts_to_evt(int argc, Scheme_Object *args[]);
static Scheme_Object *make_custodian(int argc, Scheme_Object *argv[]);
static Scheme_Object *make_custodian_from_main(int argc, Scheme_Object *argv[]);
static Scheme_Object *custodian_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *custodian_close_all(int argc, Scheme_Object *argv[]);
static Scheme_Object *custodian_to_list(int argc, Scheme_Object *argv[]);
@ -381,6 +381,15 @@ static Scheme_Object *custodian_box_value(int argc, Scheme_Object *argv[]);
static Scheme_Object *custodian_box_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *call_as_nested_thread(int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_thread_at_root(int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_make_custodian_at_root(int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_custodian_register(int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_custodian_unregister(int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_register_process_global(int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_set_on_atomic_timeout(int argc, Scheme_Object *argv[]);
static Scheme_Object *make_plumber(int argc, Scheme_Object *argv[]);
static Scheme_Object *plumber_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *plumber_flush_all(int argc, Scheme_Object *argv[]);
@ -410,6 +419,10 @@ static Scheme_Object *make_security_guard(int argc, Scheme_Object *argv[]);
static Scheme_Object *security_guard_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *current_security_guard(int argc, Scheme_Object *argv[]);
static Scheme_Object *security_guard_check_file(int argc, Scheme_Object *argv[]);
static Scheme_Object *security_guard_check_file_link(int argc, Scheme_Object *argv[]);
static Scheme_Object *security_guard_check_network(int argc, Scheme_Object *argv[]);
static Scheme_Object *cache_configuration(int argc, Scheme_Object **argv);
static Scheme_Object *make_thread_set(int argc, Scheme_Object *argv[]);
@ -671,6 +684,16 @@ scheme_init_unsafe_thread (Scheme_Env *env)
"unsafe-in-atomic?",
0, 0),
env);
GLOBAL_PRIM_W_ARITY("unsafe-thread-at-root", unsafe_thread_at_root, 1, 1, env);
GLOBAL_PRIM_W_ARITY("unsafe-make-custodian-at-root", unsafe_make_custodian_at_root, 0, 0, env);
GLOBAL_PRIM_W_ARITY("unsafe-custodian-register", unsafe_custodian_register, 5, 5, env);
GLOBAL_PRIM_W_ARITY("unsafe-custodian-unregister", unsafe_custodian_unregister, 2, 2, env);
GLOBAL_PRIM_W_ARITY("unsafe-register-process-global", unsafe_register_process_global, 2, 2, env);
GLOBAL_PRIM_W_ARITY("unsafe-set-on-atomic-timeout!", unsafe_set_on_atomic_timeout, 1, 1, env);
}
void scheme_init_thread_places(void) {
@ -680,6 +703,7 @@ void scheme_init_thread_places(void) {
REGISTER_SO(gc_prepost_callback_descs);
REGISTER_SO(place_local_misc_table);
REGISTER_SO(gc_info_prefab);
REGISTER_SO(on_atomic_timeout_data);
gc_info_prefab = scheme_lookup_prefab_type(scheme_intern_symbol("gc-info"), 10);
}
@ -748,10 +772,13 @@ void scheme_init_paramz(Scheme_Env *env)
GLOBAL_PRIM_W_ARITY("extend-parameterization" , scheme_extend_parameterization , 1, -1, newenv);
GLOBAL_PRIM_W_ARITY("check-for-break" , check_break_now , 0, 0, newenv);
GLOBAL_PRIM_W_ARITY("reparameterize" , reparameterize , 1, 1, newenv);
GLOBAL_PRIM_W_ARITY("make-custodian-from-main", make_custodian_from_main, 0, 0, newenv);
GLOBAL_PRIM_W_ARITY("cache-configuration" , cache_configuration, 2, 2, newenv);
GLOBAL_PRIM_W_ARITY("security-guard-check-file", security_guard_check_file, 3, 3, newenv);
GLOBAL_PRIM_W_ARITY("security-guard-check-file-link", security_guard_check_file_link, 3, 3, newenv);
GLOBAL_PRIM_W_ARITY("security-guard-check-network", security_guard_check_network, 4, 4, newenv);
scheme_finish_primitive_module(newenv);
scheme_protect_primitive_provide(newenv, NULL);
}
@ -1377,6 +1404,50 @@ void scheme_remove_managed(Scheme_Custodian_Reference *mr, Scheme_Object *o)
remove_managed(mr, o, NULL, NULL);
}
static void call_registered_callback(Scheme_Object *v, void *callback)
{
Scheme_Object *argv[1];
argv[0] = v;
scheme_start_in_scheduler();
_scheme_apply_multi(callback, 1, argv);
scheme_end_in_scheduler();
}
static Scheme_Object *unsafe_custodian_register(int argc, Scheme_Object *argv[])
{
Scheme_Custodian_Reference *mr;
Scheme_Custodian *custodian = (Scheme_Custodian *)argv[0];
Scheme_Object *v = argv[1];
Scheme_Object *callback = argv[2];
int at_exit = SCHEME_TRUEP(argv[3]);
int init_weak = SCHEME_TRUEP(argv[4]);
/* Some checks, just to be polite */
if (!SCHEME_CUSTODIANP(argv[0]))
scheme_wrong_contract("unsafe-custodian-register", "custodian?", 0, argc, argv);
if (!SCHEME_PROCP(callback))
scheme_wrong_contract("unsafe-custodian-register", "procedure?", 2, argc, argv);
if (at_exit)
mr = scheme_add_managed_close_on_exit(custodian, v, call_registered_callback, callback);
else
mr = scheme_add_managed(custodian, v, call_registered_callback, callback, !init_weak);
return scheme_make_cptr(mr, NULL);
}
static Scheme_Object *unsafe_custodian_unregister(int argc, Scheme_Object *argv[])
{
Scheme_Object *v = argv[0];
Scheme_Custodian_Reference *mr = (Scheme_Custodian_Reference *)SCHEME_CPTR_VAL(argv[1]);
scheme_remove_managed(mr, v);
return scheme_void;
}
Scheme_Thread *scheme_do_close_managed(Scheme_Custodian *m, Scheme_Exit_Closer_Func cf)
{
Scheme_Thread *kill_self = NULL;
@ -1567,7 +1638,7 @@ static Scheme_Object *make_custodian(int argc, Scheme_Object *argv[])
return (Scheme_Object *)scheme_make_custodian(m);
}
static Scheme_Object *make_custodian_from_main(int argc, Scheme_Object *argv[])
static Scheme_Object *unsafe_make_custodian_at_root(int argc, Scheme_Object *argv[])
{
return (Scheme_Object *)scheme_make_custodian(NULL);
}
@ -2714,6 +2785,24 @@ void *scheme_register_process_global(const char *key, void *val)
return old_val;
}
static Scheme_Object *unsafe_register_process_global(int argc, Scheme_Object *argv[])
{
void *val;
if (!SCHEME_BYTE_STRINGP(argv[0]))
scheme_wrong_contract("unsafe-register-process-global", "bytes?", 0, argc, argv);
if (!scheme_is_cpointer(argv[0]))
scheme_wrong_contract("unsafe-register-process-global", "cpointer?", 1, argc, argv);
val = scheme_register_process_global(SCHEME_BYTE_STR_VAL(argv[0]),
scheme_extract_pointer(argv[1]));
if (val)
return scheme_make_cptr(val, NULL);
else
return scheme_false;
}
void scheme_init_process_globals(void)
{
#if defined(MZ_USE_MZRT)
@ -3294,6 +3383,18 @@ static Scheme_Object *sch_thread(int argc, Scheme_Object *args[])
return scheme_thread(args[0]);
}
static Scheme_Object *unsafe_thread_at_root(int argc, Scheme_Object *args[])
{
scheme_check_proc_arity("unsafe-thread-at-root", 0, 0, argc, args);
return scheme_thread_w_details(args[0],
scheme_minimal_config(),
scheme_empty_cell_table(),
NULL, /* default break cell */
main_custodian,
0);
}
static Scheme_Object *sch_thread_nokill(int argc, Scheme_Object *args[])
{
scheme_check_proc_arity("thread/suspend-to-kill", 0, 0, argc, args);
@ -4816,7 +4917,7 @@ static void call_on_atomic_timeout(int must)
local variable so that the function call isn't
obscured to xform: */
oat = on_atomic_timeout;
oat(must);
oat(on_atomic_timeout_data, must);
restore_thread_schedule_state(p, &ssr, 1);
}
@ -5487,12 +5588,13 @@ int scheme_wait_until_suspend_ok(void)
return did;
}
Scheme_On_Atomic_Timeout_Proc scheme_set_on_atomic_timeout(Scheme_On_Atomic_Timeout_Proc p)
Scheme_On_Atomic_Timeout_Proc scheme_set_on_atomic_timeout(Scheme_On_Atomic_Timeout_Proc p, void *data)
{
Scheme_On_Atomic_Timeout_Proc old;
old = on_atomic_timeout;
on_atomic_timeout = p;
on_atomic_timeout_data = data;
if (p) {
atomic_timeout_auto_suspend = 1;
atomic_timeout_atomic_level = do_atomic;
@ -5503,6 +5605,27 @@ Scheme_On_Atomic_Timeout_Proc scheme_set_on_atomic_timeout(Scheme_On_Atomic_Time
return old;
}
static void call_timeout_callback(void *data, int must_give_up)
{
Scheme_Object *a[1];
a[0] = (must_give_up ? scheme_true : scheme_false);
scheme_start_in_scheduler();
_scheme_apply_multi((Scheme_Object *)data, 1, a);
scheme_end_in_scheduler();
}
static Scheme_Object *unsafe_set_on_atomic_timeout(int argc, Scheme_Object *argv[])
{
Scheme_On_Atomic_Timeout_Proc r;
if (SCHEME_FALSEP(argv[0]))
r = scheme_set_on_atomic_timeout(NULL, NULL);
else
r = scheme_set_on_atomic_timeout(call_timeout_callback, argv[0]);
return (r ? scheme_true : scheme_false);
}
static Scheme_Object *unsafe_start_atomic(int argc, Scheme_Object **argv)
{
@ -8526,6 +8649,102 @@ static Scheme_Object *current_security_guard(int argc, Scheme_Object *argv[])
-1, security_guard_p, "security-guard?", 0);
}
static Scheme_Object *security_guard_check_file(int argc, Scheme_Object *argv[])
{
Scheme_Object *l, *a;
int guards = 0;
if (!SCHEME_SYMBOLP(argv[0]))
scheme_wrong_contract("security-guard-check-file", "symbol?", 0, argc, argv);
if (!SCHEME_PATH_STRINGP(argv[1]))
scheme_wrong_contract("security-guard-check-file", "path-string?", 1, argc, argv);
l = argv[2];
while (SCHEME_PAIRP(l)) {
a = SCHEME_CAR(l);
if (SAME_OBJ(a, exists_symbol))
guards |= SCHEME_GUARD_FILE_EXISTS;
else if (SAME_OBJ(a, delete_symbol))
guards |= SCHEME_GUARD_FILE_DELETE;
else if (SAME_OBJ(a, execute_symbol))
guards |= SCHEME_GUARD_FILE_EXECUTE;
else if (SAME_OBJ(a, write_symbol))
guards |= SCHEME_GUARD_FILE_WRITE;
else if (SAME_OBJ(a, read_symbol))
guards |= SCHEME_GUARD_FILE_READ;
else
break;
l = SCHEME_CDR(l);
}
if (!SCHEME_NULLP(l))
scheme_wrong_contract("security-guard-check-file",
"(listof (or/c 'read 'write 'execute 'delete 'exists))",
2, argc, argv);
a = argv[1];
if (!SCHEME_PATHP(a))
a = scheme_char_string_to_path(a);
scheme_security_check_file(scheme_symbol_val(argv[0]),
SCHEME_PATH_VAL(a),
guards);
return scheme_void;
}
static Scheme_Object *security_guard_check_file_link(int argc, Scheme_Object *argv[])
{
Scheme_Object *a, *b;
if (!SCHEME_SYMBOLP(argv[0]))
scheme_wrong_contract("security-guard-check-file-link", "symbol?", 0, argc, argv);
if (!SCHEME_PATH_STRINGP(argv[1]))
scheme_wrong_contract("security-guard-check-file-link", "path-string?", 1, argc, argv);
if (!SCHEME_PATH_STRINGP(argv[2]))
scheme_wrong_contract("security-guard-check-file-link", "path-string?", 2, argc, argv);
a = argv[1];
if (!SCHEME_PATHP(a))
a = scheme_char_string_to_path(a);
b = argv[2];
if (!SCHEME_PATHP(b))
b = scheme_char_string_to_path(b);
scheme_security_check_file_link(scheme_symbol_val(argv[0]), SCHEME_PATH_VAL(a), SCHEME_PATH_VAL(b));
return scheme_void;
}
static Scheme_Object *security_guard_check_network(int argc, Scheme_Object *argv[])
{
Scheme_Object *a;
if (!SCHEME_SYMBOLP(argv[0]))
scheme_wrong_contract("security-guard-check-network", "symbol?", 0, argc, argv);
if (!SCHEME_CHAR_STRINGP(argv[1]))
scheme_wrong_contract("security-guard-check-network", "string?", 1, argc, argv);
if (!SCHEME_INTP(argv[2])
|| (SCHEME_INT_VAL(argv[2]) < 1)
|| (SCHEME_INT_VAL(argv[2]) > 65535))
scheme_wrong_contract("security-guard-check-network", "(integer-in 1 65535)", 2, argc, argv);
a = scheme_char_string_to_byte_string(argv[1]);
scheme_security_check_network(scheme_symbol_val(argv[0]),
SCHEME_BYTE_STR_VAL(a),
SCHEME_INT_VAL(argv[2]),
SCHEME_TRUEP(argv[3]));
return scheme_void;
}
void scheme_security_check_file(const char *who, const char *filename, int guards)
{