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

Another day, another sync.

Browse Source 
svn: r12887
This commit is contained in:
Stevie Strickland 2008-12-18 15:24:18 +00:00
commit 48ea3995b4
47 changed files with 722 additions and 357 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/drscheme/private/main.ss
View File

@ -94,10 +94,10 @@
(number? (car x)) (number? (car x))
(number? (cdr x)))))) (number? (cdr x))))))
(preferences:set-default 'drscheme:memory-limit (* 1024 1024 128) (preferences:set-default 'drscheme:child-only-memory-limit (* 1024 1024 128)
(λ (x) (or (boolean? x) (λ (x) (or (boolean? x)
(integer? x) (integer? x)
(x . >= . (* 1024 1024 100))))) (x . >= . (* 1024 1024 1)))))
(preferences:set-default 'drscheme:recent-language-names (preferences:set-default 'drscheme:recent-language-names
null null

6
collects/drscheme/private/rep.ss
View File

@ -867,7 +867,7 @@ TODO
(memory-killed-thread #f) (memory-killed-thread #f)
(user-custodian #f) (user-custodian #f)
(custodian-limit (and (custodian-memory-accounting-available?) (custodian-limit (and (custodian-memory-accounting-available?)
(preferences:get 'drscheme:memory-limit))) (preferences:get 'drscheme:child-only-memory-limit)))
(user-eventspace-box (make-weak-box #f)) (user-eventspace-box (make-weak-box #f))
(user-namespace-box (make-weak-box #f)) (user-namespace-box (make-weak-box #f))
(user-eventspace-main-thread #f) (user-eventspace-main-thread #f)
@ -925,7 +925,7 @@ TODO
(field (need-interaction-cleanup? #f)) (field (need-interaction-cleanup? #f))
(define/private (no-user-evaluation-message frame exit-code memory-killed?) (define/private (no-user-evaluation-message frame exit-code memory-killed?)
(let* ([new-limit (and custodian-limit (+ (* 1024 1024 128) custodian-limit))] (let* ([new-limit (and custodian-limit (+ custodian-limit custodian-limit))]
[ans (message-box/custom [ans (message-box/custom
(string-constant evaluation-terminated) (string-constant evaluation-terminated)
(string-append (string-append
@ -953,7 +953,7 @@ TODO
)]) )])
(when (equal? ans 3) (when (equal? ans 3)
(set-custodian-limit new-limit) (set-custodian-limit new-limit)
(preferences:set 'drscheme:memory-limit new-limit)) (preferences:set 'drscheme:child-only-memory-limit new-limit))
(set-insertion-point (last-position)) (set-insertion-point (last-position))
(insert-warning "\nInteractions disabled"))) (insert-warning "\nInteractions disabled")))

8
collects/drscheme/private/unit.ss
View File

@ -3292,10 +3292,10 @@ module browser threading seems wrong.
(when num (when num
(cond (cond
[(eq? num #t) [(eq? num #t)
(preferences:set 'drscheme:memory-limit #f) (preferences:set 'drscheme:child-only-memory-limit #f)
(send interactions-text set-custodian-limit #f)] (send interactions-text set-custodian-limit #f)]
[else [else
(preferences:set 'drscheme:memory-limit (preferences:set 'drscheme:child-only-memory-limit
(* 1024 1024 num)) (* 1024 1024 num))
(send interactions-text set-custodian-limit (send interactions-text set-custodian-limit
(* 1024 1024 num))]))))])) (* 1024 1024 num))]))))]))
@ -3844,7 +3844,7 @@ module browser threading seems wrong.
[parent hp] [parent hp]
[init-value (if current-limit [init-value (if current-limit
(format "~a" current-limit) (format "~a" current-limit)
"128")] "64")]
[stretchable-width #f] [stretchable-width #f]
[min-width 100] [min-width 100]
[callback [callback
@ -3886,7 +3886,7 @@ module browser threading seems wrong.
(let* ([n (string->number (send txt get-text))]) (let* ([n (string->number (send txt get-text))])
(and n (and n
(integer? n) (integer? n)
(100 . <= . n)))) (1 . <= . n))))
(define (background sd) (define (background sd)
(let ([txt (send tb get-editor)]) (let ([txt (send tb get-editor)])

20
collects/html/html.scrbl
View File

@ -4,8 +4,9 @@
(for-label html) (for-label html)
(for-label xml)) (for-label xml))
@title{@bold{HTML}: Parsing Library} @(define xexpr @tech[#:doc '(lib "xml/xml.scrbl")]{X-expression})
@title{@bold{HTML}: Parsing Library}
@defmodule[html]{The @schememodname[html] library provides @defmodule[html]{The @schememodname[html] library provides
functions to read html documents and structures to represent them.} functions to read html documents and structures to represent them.}
@ -25,12 +26,27 @@ Reads (X)HTML from a port, producing an @scheme[html] instance.}
@defproc[(read-html-as-xml [port input-port?]) @defproc[(read-html-as-xml [port input-port?])
(listof content?)]{ (listof content?)]{
Reads HTML from a port, producing an xexpr compatible with the Reads HTML from a port, producing an @xexpr compatible with the
@schememodname[xml] library (which defines @scheme[content?]).} @schememodname[xml] library (which defines @scheme[content?]).}
@defboolparam[read-html-comments v]{
If @scheme[v] is not @scheme[#f], then comments are read and returned. Defaults to @scheme[#f].
}
@defboolparam[use-html-spec v]{
If @scheme[v] is not @scheme[#f], then the HTML must respect the HTML specification
with regards to what elements are allowed to be the children of
other elements. For example, the top-level @scheme["<html>"]
element may only contain a @scheme["<body>"] and @scheme["<head>"]
element. Defaults to @scheme[#f].
}
@section{Example} @section{Example}
@(require (only-in (for-label scheme)
open-input-string string-append
list cond match apply append map printf define require module)
(for-label (prefix-in h: html))
(for-label (prefix-in x: xml)))
@def+int[ @def+int[
(module html-example scheme (module html-example scheme

2
collects/mzlib/foreign.ss
View File

@ -1500,7 +1500,7 @@
;; Used by set-ffi-obj! to get the actual value so it can be kept around ;; Used by set-ffi-obj! to get the actual value so it can be kept around
(define (get-lowlevel-object x type) (define (get-lowlevel-object x type)
(let ([basetype (ctype-basetype type)]) (let ([basetype (ctype-basetype type)])
(if basetype (if (ctype? basetype)
(let ([s->c (ctype-scheme->c type)]) (let ([s->c (ctype-scheme->c type)])
(get-lowlevel-object (if s->c (s->c x) x) basetype)) (get-lowlevel-object (if s->c (s->c x) x) basetype))
(values x type)))) (values x type))))

2
collects/repos-time-stamp/stamp.ss
View File

@ -1 +1 @@
#lang scheme/base (provide stamp) (define stamp "14dec2008") #lang scheme/base (provide stamp) (define stamp "18dec2008")

247
collects/scheme/sandbox.ss
View File

@ -25,10 +25,13 @@
sandbox-make-logger sandbox-make-logger
sandbox-memory-limit sandbox-memory-limit
sandbox-eval-limits sandbox-eval-limits
sandbox-eval-handlers
call-with-trusted-sandbox-configuration
evaluator-alive? evaluator-alive?
kill-evaluator kill-evaluator
break-evaluator break-evaluator
set-eval-limits set-eval-limits
set-eval-handler
put-input put-input
get-output get-output
get-error-output get-error-output
@ -39,6 +42,8 @@
call-in-nested-thread* call-in-nested-thread*
call-with-limits call-with-limits
with-limits with-limits
call-with-custodian-shutdown
call-with-killing-threads
exn:fail:sandbox-terminated? exn:fail:sandbox-terminated?
exn:fail:sandbox-terminated-reason exn:fail:sandbox-terminated-reason
exn:fail:resource? exn:fail:resource?
@ -58,11 +63,23 @@
(define sandbox-output (make-parameter #f)) (define sandbox-output (make-parameter #f))
(define sandbox-error-output (define sandbox-error-output
(make-parameter (lambda () (dup-output-port (current-error-port))))) (make-parameter (lambda () (dup-output-port (current-error-port)))))
(define sandbox-memory-limit (make-parameter 20)) ; 30mb total (define sandbox-memory-limit (make-parameter 30)) ; 30mb total
(define sandbox-eval-limits (make-parameter '(30 20))) ; 30sec, 20mb (define sandbox-eval-limits (make-parameter '(30 20))) ; 30sec, 20mb
(define sandbox-propagate-breaks (make-parameter #t)) (define sandbox-propagate-breaks (make-parameter #t))
(define sandbox-coverage-enabled (make-parameter #f)) (define sandbox-coverage-enabled (make-parameter #f))
(define (call-with-trusted-sandbox-configuration thunk)
(parameterize ([sandbox-propagate-breaks #t]
[sandbox-override-collection-paths '()]
[sandbox-security-guard current-security-guard]
[sandbox-exit-handler (exit-handler)]
[sandbox-make-inspector current-inspector]
[sandbox-make-code-inspector current-code-inspector]
[sandbox-make-logger current-logger]
[sandbox-memory-limit #f]
[sandbox-eval-limits #f])
(thunk)))
(define sandbox-namespace-specs (define sandbox-namespace-specs
(make-parameter `(,(mz/mr make-base-namespace make-gui-namespace) (make-parameter `(,(mz/mr make-base-namespace make-gui-namespace)
#| no modules here by default |#))) #| no modules here by default |#)))
@ -94,9 +111,14 @@
[(string? path) (string->path path)] [(string? path) (string->path path)]
[else path])))))) [else path]))))))
(define permission-order '(execute write delete read exists)) ;; 'read-bytecode is special, it's higher than 'read, but not lower than
;; 'delete.
(define permission-order '(execute write delete read-bytecode read exists))
(define (perm<=? p1 p2) (define (perm<=? p1 p2)
(memq p1 (memq p2 permission-order))) (or (eq? p1 p2)
(and (not (eq? 'read-bytecode p1))
(memq p1 (memq p2 permission-order))
#t)))
;; gets a path (can be bytes/string), returns a regexp for that path that ;; gets a path (can be bytes/string), returns a regexp for that path that
;; matches also subdirs (if it's a directory) ;; matches also subdirs (if it's a directory)
@ -117,6 +139,29 @@
(map (lambda (perm) (list (car perm) (path->bregexp (cadr perm)))) (map (lambda (perm) (list (car perm) (path->bregexp (cadr perm))))
new)))) new))))
;; compresses the (sandbox-path-permissions) value to a "compressed" list of
;; (permission regexp ...) where each permission appears exactly once (so it's
;; quicker to test it later, no need to scan the whole permission list).
(define compressed-path-permissions
(let ([t (make-weak-hasheq)])
(define (compress-permissions ps)
(map (lambda (perm)
(let* ([ps (filter (lambda (p) (perm<=? perm (car p))) ps)]
[ps (remove-duplicates (map cadr ps))])
(cons perm ps)))
permission-order))
(lambda ()
(let ([ps (sandbox-path-permissions)])
(or (hash-ref t ps #f)
(let ([c (compress-permissions ps)]) (hash-set! t ps c) c))))))
;; similar to the security guard, only with a single mode for simplification;
;; assumes valid mode and simplified path
(define (check-sandbox-path-permissions path needed)
(let ([bpath (path->bytes path)]
[perms (compressed-path-permissions)])
(ormap (lambda (rx) (regexp-match? rx bpath)) (cdr (assq needed perms)))))
(define sandbox-network-guard (define sandbox-network-guard
(make-parameter (lambda (what . xs) (make-parameter (lambda (what . xs)
(error what "network access denied: ~e" xs)))) (error what "network access denied: ~e" xs))))
@ -127,16 +172,17 @@
orig-security orig-security
(lambda (what path modes) (lambda (what path modes)
(when path (when path
(let ([needed (car (or (for/or ([p (in-list permission-order)]) (let ([spath (parameterize ([current-security-guard orig-security])
(memq p modes)) (simplify-path* path))]
(error 'default-sandbox-guard [maxperm
"unknown access modes: ~e" modes)))] ;; assumes that the modes are valid (ie, in the above list)
[bpath (parameterize ([current-security-guard orig-security]) (cond [(null? modes) (error 'default-sandbox-guard
(path->bytes (simplify-path* path)))]) "got empty mode list for ~e and ~e"
(unless (ormap (lambda (perm) what path)]
(and (perm<=? needed (car perm)) [(null? (cdr modes)) (car modes)] ; common case
(regexp-match (cadr perm) bpath))) [else (foldl (lambda (x max) (if (perm<=? max x) x max))
(sandbox-path-permissions)) (car modes) (cdr modes))])])
(unless (check-sandbox-path-permissions spath maxperm)
(error what "`~a' access denied for ~a" (error what "`~a' access denied for ~a"
(string-append* (add-between (map symbol->string modes) "+")) (string-append* (add-between (map symbol->string modes) "+"))
path))))) path)))))
@ -168,8 +214,8 @@
(append (map (lambda (p) `(read ,(path->bytes p))) paths) (append (map (lambda (p) `(read ,(path->bytes p))) paths)
(module-specs->path-permissions require-perms)))) (module-specs->path-permissions require-perms))))
;; computes permissions that are needed for require specs (`read' for all ;; computes permissions that are needed for require specs (`read-bytecode' for
;; files and "compiled" subdirs, `exists' for the base-dir) ;; all files and "compiled" subdirs, `exists' for the base-dir)
(define (module-specs->path-permissions mods) (define (module-specs->path-permissions mods)
(define paths (module-specs->non-lib-paths mods)) (define paths (module-specs->non-lib-paths mods))
(define bases (define bases
@ -180,8 +226,8 @@
(let ([base (simplify-path* base)]) (let ([base (simplify-path* base)])
(loop (cdr paths) (loop (cdr paths)
(if (member base bases) bases (cons base bases)))))))) (if (member base bases) bases (cons base bases))))))))
(append (map (lambda (p) `(read ,p)) paths) (append (map (lambda (p) `(read-bytecode ,p)) paths)
(map (lambda (b) `(read ,(build-path b "compiled"))) bases) (map (lambda (b) `(read-bytecode ,(build-path b "compiled"))) bases)
(map (lambda (b) `(exists ,b)) bases))) (map (lambda (b) `(exists ,b)) bases)))
;; takes a module-spec list and returns all module paths that are needed ;; takes a module-spec list and returns all module paths that are needed
@ -273,7 +319,8 @@
(define-values (cust cust-box) (define-values (cust cust-box)
(if (and mb memory-accounting?) (if (and mb memory-accounting?)
(let ([c (make-custodian (current-custodian))]) (let ([c (make-custodian (current-custodian))])
(custodian-limit-memory c (* mb 1024 1024) c) (custodian-limit-memory
c (inexact->exact (round (* mb 1024 1024))) c)
(values c (make-custodian-box c #t))) (values c (make-custodian-box c #t)))
(values (current-custodian) #f))) (values (current-custodian) #f)))
(parameterize ([current-custodian cust]) (parameterize ([current-custodian cust])
@ -282,7 +329,9 @@
;; time limit ;; time limit
(when sec (when sec
(let ([t (current-thread)]) (let ([t (current-thread)])
(thread (lambda () (sleep sec) (set! r 'time) (kill-thread t))))) (thread (lambda ()
(unless (sync/timeout sec t) (set! r 'time))
(kill-thread t)))))
(set! r (with-handlers ([void (lambda (e) (list raise e))]) (set! r (with-handlers ([void (lambda (e) (list raise e))])
(call-with-values thunk (lambda vs (list* values vs)))))) (call-with-values thunk (lambda vs (list* values vs))))))
;; The thread might be killed by the timer thread, so don't let ;; The thread might be killed by the timer thread, so don't let
@ -317,6 +366,28 @@
[(with-limits sec mb body ...) [(with-limits sec mb body ...)
(call-with-limits sec mb (lambda () body ...))])) (call-with-limits sec mb (lambda () body ...))]))
;; other resource utilities
(define (call-with-custodian-shutdown thunk)
(let ([cust (make-custodian (current-custodian))])
(dynamic-wind
void
(lambda () (parameterize ([current-custodian cust]) (thunk)))
(lambda () (custodian-shutdown-all cust)))))
(define (call-with-killing-threads thunk)
(let* ([cur (current-custodian)] [sub (make-custodian cur)])
(define (kill-all x)
(cond [(custodian? x) (for-each kill-all (custodian-managed-list x cur))]
[(thread? x) (kill-thread x)]))
(dynamic-wind
void
(lambda () (parameterize ([current-custodian sub]) (thunk)))
(lambda () (kill-all sub)))))
(define sandbox-eval-handlers
(make-parameter (list #f call-with-custodian-shutdown)))
;; Execution ---------------------------------------------------------------- ;; Execution ----------------------------------------------------------------
(define (literal-identifier=? x y) (define (literal-identifier=? x y)
@ -510,12 +581,14 @@
(define-evaluator-messenger kill-evaluator 'kill) (define-evaluator-messenger kill-evaluator 'kill)
(define-evaluator-messenger break-evaluator 'break) (define-evaluator-messenger break-evaluator 'break)
(define-evaluator-messenger (set-eval-limits secs mb) 'limits) (define-evaluator-messenger (set-eval-limits secs mb) 'limits)
(define-evaluator-messenger (set-eval-handler handler) 'handler)
(define-evaluator-messenger (put-input . xs) 'input) (define-evaluator-messenger (put-input . xs) 'input)
(define-evaluator-messenger get-output 'output) (define-evaluator-messenger get-output 'output)
(define-evaluator-messenger get-error-output 'error-output) (define-evaluator-messenger get-error-output 'error-output)
(define-evaluator-messenger (get-uncovered-expressions . xs) 'uncovered) (define-evaluator-messenger (get-uncovered-expressions . xs) 'uncovered)
(define-evaluator-messenger (call-in-sandbox-context thunk) 'thunk) (define (call-in-sandbox-context evaluator thunk [unrestricted? #f])
(evaluator (make-evaluator-message (if unrestricted? 'thunk* 'thunk)
(list thunk))))
(define-struct (exn:fail:sandbox-terminated exn:fail) (reason) #:transparent) (define-struct (exn:fail:sandbox-terminated exn:fail) (reason) #:transparent)
(define (make-terminated reason) (define (make-terminated reason)
@ -526,6 +599,7 @@
(define (make-evaluator* init-hook allow program-maker) (define (make-evaluator* init-hook allow program-maker)
(define orig-code-inspector (current-code-inspector)) (define orig-code-inspector (current-code-inspector))
(define orig-security-guard (current-security-guard))
(define orig-cust (current-custodian)) (define orig-cust (current-custodian))
(define memory-cust (make-custodian orig-cust)) (define memory-cust (make-custodian orig-cust))
(define memory-cust-box (make-custodian-box memory-cust #t)) (define memory-cust-box (make-custodian-box memory-cust #t))
@ -539,24 +613,33 @@
(define output #f) (define output #f)
(define error-output #f) (define error-output #f)
(define limits (sandbox-eval-limits)) (define limits (sandbox-eval-limits))
(define eval-handler (car (sandbox-eval-handlers))) ; 1st handler on startup
(define user-thread #t) ; set later to the thread (define user-thread #t) ; set later to the thread
(define user-done-evt #t) ; set in the same place (define user-done-evt #t) ; set in the same place
(define terminated? #f) ; set to an exception value when the sandbox dies (define terminated? #f) ; set to an exception value when the sandbox dies
(define (limit-thunk thunk)
(let* ([sec (and limits (car limits))]
[mb (and limits (cadr limits))]
[thunk (if (or sec mb)
(lambda () (call-with-limits sec mb thunk))
thunk)]
[thunk (if eval-handler (lambda () (eval-handler thunk)) thunk)])
thunk))
(define (terminated! reason) (define (terminated! reason)
(unless terminated? (unless terminated?
(set! terminated? (set! terminated?
(make-terminated (make-terminated
(cond [(eq? reason #t) ; => guess (cond
(if (custodian-box-value user-cust-box) ;; #f is used as an indication of an internal error, when we
'thread-killed ;; don't know why the sandbox is killed
'custodian-shutdown)] [(not reason) "internal error: no termination reason"]
[reason reason] ; => explicit ;; explicit reason given
;; otherwise it's an indication of an internal error [(not (eq? reason #t)) reason]
[else "internal error: no termination reason"]))))) ;; reason = #t => guess the reason
(define (limit-thunk thunk) [(not (custodian-box-value memory-cust-box)) 'out-of-memory]
(let* ([sec (and limits (car limits))] [(not (custodian-box-value user-cust-box)) 'custodian-shutdown]
[mb (and limits (cadr limits))]) [(thread-dead? user-thread) 'thread-killed]
(if (or sec mb) (lambda () (call-with-limits sec mb thunk)) thunk))) [else "internal error: cannot guess termination reason"])))))
(define (user-kill) (define (user-kill)
(when user-thread (when user-thread
(let ([t user-thread]) (let ([t user-thread])
@ -565,6 +648,10 @@
(custodian-shutdown-all user-cust) (custodian-shutdown-all user-cust)
(kill-thread t))) ; just in case (kill-thread t))) ; just in case
(void)) (void))
(define (terminate+kill! reason raise?)
(terminated! reason)
(user-kill)
(when raise? (raise terminated?)))
(define (user-break) (define (user-break)
(when user-thread (break-thread user-thread))) (when user-thread (break-thread user-thread)))
(define (user-process) (define (user-process)
@ -578,6 +665,7 @@
limit-thunk limit-thunk
(and coverage? (lambda (es+get) (set! uncovered es+get)))) (and coverage? (lambda (es+get) (set! uncovered es+get))))
(channel-put result-ch 'ok)) (channel-put result-ch 'ok))
(set! eval-handler (cadr (sandbox-eval-handlers))) ; interactions handler
;; finally wait for interaction expressions ;; finally wait for interaction expressions
(let ([n 0]) (let ([n 0])
(let loop () (let loop ()
@ -587,36 +675,34 @@
(with-handlers ([void (lambda (exn) (with-handlers ([void (lambda (exn)
(channel-put result-ch (cons 'exn exn)))]) (channel-put result-ch (cons 'exn exn)))])
(define run (define run
(limit-thunk (if (evaluator-message? expr) (if (evaluator-message? expr)
(lambda () (case (evaluator-message-msg expr)
(apply (evaluator-message-msg expr) [(thunk) (limit-thunk (car (evaluator-message-args expr)))]
(evaluator-message-args expr))) [(thunk*) (car (evaluator-message-args expr))]
(lambda () [else (error 'sandbox "internal error (bad message)")])
(limit-thunk (lambda ()
(set! n (add1 n)) (set! n (add1 n))
(eval* (input->code (list expr) 'eval n)))))) (eval* (input->code (list expr) 'eval n))))))
(channel-put result-ch (cons 'vals (call-with-values run list)))) (channel-put result-ch (cons 'vals (call-with-values run list))))
(loop))))) (loop)))))
(define (get-user-result)
(with-handlers ([(if (sandbox-propagate-breaks) exn:break? (lambda (_) #f))
(lambda (e) (user-break) (get-user-result))])
(sync user-done-evt result-ch)))
(define (user-eval expr) (define (user-eval expr)
;; the thread will usually be running, but it might be killed outside of ;; the thread will usually be running, but it might be killed outside of
;; the sandboxed environment, for example, if you do something like ;; the sandboxed environment, for example, if you do something like
;; (kill-thread (ev '(current-thread))) when there are no per-expression ;; (kill-thread (ev '(current-thread))) when there are no per-expression
;; limits (since then you get a different thread, which is already dead). ;; limits (since then you get a different thread, which is already dead).
(when (and user-thread (thread-dead? user-thread)) (when (and user-thread (thread-dead? user-thread))
(terminated! #t)) (terminate+kill! #t #t))
(cond (cond
[terminated? => raise] [terminated? => raise]
[(not user-thread) (error 'sandbox "internal error (user-thread is #f)")] [(not user-thread) (error 'sandbox "internal error (user-thread is #f)")]
[else [else
(channel-put input-ch expr) (channel-put input-ch expr)
(let ([r (let loop () (let ([r (get-user-result)])
(with-handlers ([(if (sandbox-propagate-breaks) (cond [(eof-object? r) (terminate+kill! #t #t)]
exn:break? (lambda (_) #f))
(lambda (e) (user-break) (loop))])
(sync user-done-evt result-ch)))])
(cond [(eof-object? r)
(terminated! (and (not (custodian-box-value memory-cust-box))
'out-of-memory))
(raise terminated?)]
[(eq? (car r) 'exn) (raise (cdr r))] [(eq? (car r) 'exn) (raise (cdr r))]
[else (apply values (cdr r))]))])) [else (apply values (cdr r))]))]))
(define get-uncovered (define get-uncovered
@ -631,7 +717,7 @@
(filter (lambda (x) (equal? src (syntax-source x))) uncovered) (filter (lambda (x) (equal? src (syntax-source x))) uncovered)
uncovered))])) uncovered))]))
(define (output-getter p) (define (output-getter p)
(if (procedure? p) (user-eval (make-evaluator-message p '())) p)) (if (procedure? p) (user-eval (make-evaluator-message 'thunk (list p))) p))
(define input-putter (define input-putter
(case-lambda (case-lambda
[() (input-putter input)] [() (input-putter input)]
@ -645,16 +731,16 @@
(if (evaluator-message? expr) (if (evaluator-message? expr)
(let ([msg (evaluator-message-msg expr)]) (let ([msg (evaluator-message-msg expr)])
(case msg (case msg
[(alive?) (and user-thread (not (thread-dead? user-thread)))] [(alive?) (and user-thread (not (thread-dead? user-thread)))]
[(kill) (terminated! 'evaluator-killed) (user-kill)] [(kill) (terminate+kill! 'evaluator-killed #f)]
[(break) (user-break)] [(break) (user-break)]
[(limits) (set! limits (evaluator-message-args expr))] [(limits) (set! limits (evaluator-message-args expr))]
[(input) (apply input-putter (evaluator-message-args expr))] [(handler) (set! eval-handler (car (evaluator-message-args expr)))]
[(output) (output-getter output)] [(input) (apply input-putter (evaluator-message-args expr))]
[(output) (output-getter output)]
[(error-output) (output-getter error-output)] [(error-output) (output-getter error-output)]
[(uncovered) (apply get-uncovered (evaluator-message-args expr))] [(uncovered) (apply get-uncovered (evaluator-message-args expr))]
[(thunk) (user-eval (make-evaluator-message [(thunk thunk*) (user-eval expr)]
(car (evaluator-message-args expr)) '()))]
[else (error 'evaluator "internal error, bad message: ~e" msg)])) [else (error 'evaluator "internal error, bad message: ~e" msg)]))
(user-eval expr))) (user-eval expr)))
(define (make-output what out set-out! allow-link?) (define (make-output what out set-out! allow-link?)
@ -679,7 +765,9 @@
;; set global memory limit ;; set global memory limit
(when (and memory-accounting? (sandbox-memory-limit)) (when (and memory-accounting? (sandbox-memory-limit))
(custodian-limit-memory (custodian-limit-memory
memory-cust (* (sandbox-memory-limit) 1024 1024) memory-cust)) memory-cust
(inexact->exact (round (* (sandbox-memory-limit) 1024 1024)))
memory-cust))
(parameterize* ; the order in these matters (parameterize* ; the order in these matters
(;; create a sandbox context first (;; create a sandbox context first
[current-custodian user-cust] [current-custodian user-cust]
@ -707,33 +795,41 @@
(append (sandbox-override-collection-paths) (append (sandbox-override-collection-paths)
(current-library-collection-paths)))] (current-library-collection-paths)))]
[sandbox-path-permissions [sandbox-path-permissions
(append (map (lambda (p) `(read ,p)) `(,@(map (lambda (p) `(read-bytecode ,p))
(current-library-collection-paths)) (current-library-collection-paths))
(compute-permissions allow) (exists ,(find-system-path 'addon-dir))
(sandbox-path-permissions))] ,@(compute-permissions allow)
,@(sandbox-path-permissions))]
;; general info ;; general info
[current-command-line-arguments '#()] [current-command-line-arguments '#()]
;; restrict the sandbox context from this point ;; restrict the sandbox context from this point
[current-security-guard [current-security-guard
(let ([g (sandbox-security-guard)]) (if (security-guard? g) g (g)))] (let ([g (sandbox-security-guard)]) (if (security-guard? g) g (g)))]
[exit-handler
(let ([h (sandbox-exit-handler)])
(if (eq? h default-sandbox-exit-handler)
(lambda _ (terminated! 'exited) (user-kill))
h))]
[current-inspector ((sandbox-make-inspector))]
[current-logger ((sandbox-make-logger))] [current-logger ((sandbox-make-logger))]
[current-code-inspector (make-inspector)] [current-inspector ((sandbox-make-inspector))]
[current-code-inspector ((sandbox-make-code-inspector))]
;; The code inspector serves two purposes -- making sure that only trusted ;; The code inspector serves two purposes -- making sure that only trusted
;; byte-code is loaded, and avoiding using protected moduel bindings, like ;; byte-code is loaded, and avoiding using protected module bindings, like
;; the foreign library's `unsafe!'. We don't need the first because we ;; the foreign library's `unsafe!'. We control the first through the path
;; control it indirectly through the security guard, so this handler makes ;; permissions -- using the 'read-bytecode permissionn level, so this
;; sure that byte-code is loaded using the original inspector. ;; handler just checks for that permission then goes on to load the file
;; using the original inspector.
[current-load/use-compiled [current-load/use-compiled
(let ([handler (current-load/use-compiled)]) (let ([handler (current-load/use-compiled)])
(lambda (path modname) (lambda (path modname)
(parameterize ([current-code-inspector orig-code-inspector]) (if (check-sandbox-path-permissions
(parameterize ([current-security-guard orig-security-guard])
(simplify-path* path))
'read-bytecode)
(parameterize ([current-code-inspector orig-code-inspector])
(handler path modname))
;; otherwise, just let the old handler throw a proper error
(handler path modname))))] (handler path modname))))]
[exit-handler
(let ([h (sandbox-exit-handler)])
(if (eq? h default-sandbox-exit-handler)
(lambda _ (terminate+kill! 'exited #f))
h))]
;; Note the above definition of `current-eventspace': in MzScheme, it ;; Note the above definition of `current-eventspace': in MzScheme, it
;; is an unused parameter. Also note that creating an eventspace ;; is an unused parameter. Also note that creating an eventspace
;; starts a thread that will eventually run the callback code (which ;; starts a thread that will eventually run the callback code (which
@ -742,10 +838,9 @@
;; it will not use the new namespace. ;; it will not use the new namespace.
[current-eventspace (make-eventspace)]) [current-eventspace (make-eventspace)])
(let ([t (bg-run->thread (run-in-bg user-process))]) (let ([t (bg-run->thread (run-in-bg user-process))])
(set! user-done-evt (set! user-done-evt (handle-evt t (lambda (_) (terminate+kill! #t #t))))
(handle-evt t (lambda (_) (terminated! #t) (user-kill) eof)))
(set! user-thread t)) (set! user-thread t))
(let ([r (channel-get result-ch)]) (let ([r (get-user-result)])
(if (eq? r 'ok) (if (eq? r 'ok)
;; initial program executed ok, so return an evaluator ;; initial program executed ok, so return an evaluator
evaluator evaluator

12
collects/scribble/eval.ss
View File

@ -239,13 +239,11 @@
[else stx])) [else stx]))
(define (make-base-eval) (define (make-base-eval)
(parameterize ([sandbox-security-guard (current-security-guard)] (call-with-trusted-sandbox-configuration
[sandbox-output 'string] (lambda ()
[sandbox-error-output 'string] (parameterize ([sandbox-output 'string]
[sandbox-eval-limits #f] [sandbox-error-output 'string])
[sandbox-memory-limit #f] (make-evaluator '(begin (require scheme/base)))))))
[sandbox-make-inspector current-inspector])
(make-evaluator '(begin (require scheme/base)))))
(define (close-eval e) (define (close-eval e)
(kill-evaluator e) (kill-evaluator e)

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

@ -20,9 +20,11 @@ along with conversion functions to and from the existing types.
[c-to-scheme (or/c #f (any/c . -> . any))]) [c-to-scheme (or/c #f (any/c . -> . any))])
ctype?]{ ctype?]{
Creates a new @tech{C type} value, with the given conversions Creates a new @tech{C type} value whose representation for foreign
functions. The conversion functions can be @scheme[#f] meaning that code is the same as @scheme[type]'s. The given conversions functions
there is no conversion for the corresponding direction. If both convert to and from the Scheme representation of @scheme[type]. Either
conversion function can be @scheme[#f], meaning that the conversion
for the corresponding direction is the identity function. If both
functions are @scheme[#f], @scheme[type] is returned.} functions are @scheme[#f], @scheme[type] is returned.}
@ -338,7 +340,7 @@ values: @itemize[
the callback value will be stored in the box, overriding any value the callback value will be stored in the box, overriding any value
that was in the box (making it useful for holding a single callback that was in the box (making it useful for holding a single callback
value). When you know that it is no longer needed, you can value). When you know that it is no longer needed, you can
`release' the callback value by changing the box contents, or by ``release'' the callback value by changing the box contents, or by
allowing the box itself to be garbage-collected. This is can be allowing the box itself to be garbage-collected. This is can be
useful if the box is held for a dynamic extent that corresponds to useful if the box is held for a dynamic extent that corresponds to
when the callback is needed; for example, you might encapsulate some when the callback is needed; for example, you might encapsulate some
@ -400,7 +402,7 @@ used to access the actual foreign return value.
In rare cases where complete control over the input arguments is needed, the In rare cases where complete control over the input arguments is needed, the
wrapper's argument list can be specified as @scheme[args], in any form (including wrapper's argument list can be specified as @scheme[args], in any form (including
a `rest' argument). Identifiers in this place are related to type labels, so a ``rest'' argument). Identifiers in this place are related to type labels, so
if an argument is there is no need to use an expression. if an argument is there is no need to use an expression.
For example, For example,
@ -746,7 +748,7 @@ than the struct itself. The following works as expected:
As described above, @scheme[_list-struct]s should be used in cases where As described above, @scheme[_list-struct]s should be used in cases where
efficiency is not an issue. We continue using @scheme[define-cstruct], first efficiency is not an issue. We continue using @scheme[define-cstruct], first
define a type for @cpp{A} which makes it possible to use `@cpp{makeA}: define a type for @cpp{A} which makes it possible to use @cpp{makeA}:
@schemeblock[ @schemeblock[
(define-cstruct #,(schemeidfont "_A") ([x _int] [y _byte])) (define-cstruct #,(schemeidfont "_A") ([x _int] [y _byte]))
@ -785,7 +787,7 @@ We can access all values of @scheme[b] using a naive approach:
] ]
but this is inefficient as it allocates and copies an instance of but this is inefficient as it allocates and copies an instance of
`@cpp{A}' on every access. Inspecting the tags @scheme[(cpointer-tag @cpp{A} on every access. Inspecting the tags @scheme[(cpointer-tag
b)] we can see that @cpp{A}'s tag is included, so we can simply use b)] we can see that @cpp{A}'s tag is included, so we can simply use
its accessors and mutators, as well as any function that is defined to its accessors and mutators, as well as any function that is defined to
take an @cpp{A} pointer: take an @cpp{A} pointer:

5
collects/scribblings/foreign/unexported.scrbl
View File

@ -39,8 +39,9 @@ These values can also be used as C pointer objects.}
[(ctype-c->scheme [type ctype?]) procedure?])]{ [(ctype-c->scheme [type ctype?]) procedure?])]{
Accessors for the components of a C type object, made by Accessors for the components of a C type object, made by
@scheme[make-ctype]. The @scheme[ctype-basetype] selector returns @scheme[make-ctype]. The @scheme[ctype-basetype] selector returns a
@scheme[#f] for primitive types (including cstruct types).} symbol for primitive types that names the type, a list of ctypes for
cstructs, and another ctype for user-defined ctypes.}
@defproc[(ffi-call [ptr any/c] [in-types (listof ctype?)] [out-type ctype?] @defproc[(ffi-call [ptr any/c] [in-types (listof ctype?)] [out-type ctype?]

21
collects/scribblings/reference/custodians.scrbl
View File

@ -57,19 +57,19 @@ or indirectly). If @scheme[cust] is not strictly subordinate to
@defproc[(custodian-memory-accounting-available?) boolean?]{ @defproc[(custodian-memory-accounting-available?) boolean?]{
Returns @scheme[#t] if PLT Scheme is compiled with support for
per-custodian memory accounting, @scheme[#f] otherwise.
@margin-note{Memory accounting is normally available in PLT Scheme 3m, @margin-note{Memory accounting is normally available in PLT Scheme 3m,
which is the main variant of PLT Scheme, and not normally available in which is the main variant of PLT Scheme, and not normally available in
PLT Scheme CGC.}} PLT Scheme CGC.}
Returns @scheme[#t] if PLT Scheme is compiled with support for
per-custodian memory accounting, @scheme[#f] otherwise.}
@defproc[(custodian-require-memory [limit-cust custodian?] @defproc[(custodian-require-memory [limit-cust custodian?]
[need-amt exact-nonnegative-integer?] [need-amt exact-nonnegative-integer?]
[stop-cust custodian?]) void?]{ [stop-cust custodian?]) void?]{
Registers a require check if PLT Scheme is compiled with support for Registers a required-memory check if PLT Scheme is compiled with
per-custodian memory accounting, otherwise the support for per-custodian memory accounting, otherwise the
@exnraise[exn:fail:unsupported]. @exnraise[exn:fail:unsupported].
If a check is registered, and if PLT Scheme later reaches a state after If a check is registered, and if PLT Scheme later reaches a state after
@ -81,8 +81,8 @@ trigger some shutdown, then @scheme[stop-cust] is shut down.}
[limit-amt exact-nonnegative-integer?] [limit-amt exact-nonnegative-integer?]
[stop-cust custodian? limit-cust]) void?]{ [stop-cust custodian? limit-cust]) void?]{
Registers a limit check if PLT Scheme is compiled with support for Registers a limited-memory check if PLT Scheme is compiled with
per-custodian memory accounting, otherwise the support for per-custodian memory accounting, otherwise the
@exnraise[exn:fail:unsupported]. @exnraise[exn:fail:unsupported].
If a check is registered, and if PLT Scheme later reaches a state If a check is registered, and if PLT Scheme later reaches a state
@ -93,7 +93,10 @@ after garbage collection (see @secref["gc-model"]) where
@margin-note{A custodian's limit is checked only after a garbage @margin-note{A custodian's limit is checked only after a garbage
collection, except that it may also be checked during collection, except that it may also be checked during
certain large allocations that are individually larger certain large allocations that are individually larger
than the custodian's limit.} than the custodian's limit. A single garbage collection
may shut down multiple custodians, even if shutting down
only one of the custodians would have reduced memory use
for other custodians.}
For reliable shutdown, @scheme[limit-amt] for For reliable shutdown, @scheme[limit-amt] for
@scheme[custodian-limit-memory] must be much lower than the total @scheme[custodian-limit-memory] must be much lower than the total

10
collects/scribblings/reference/eval-model.scrbl
View File

@ -801,7 +801,9 @@ object is reachable from two custodians where neither is an ancestor
of the other, an object is arbitrarily charged to one of the other, of the other, an object is arbitrarily charged to one of the other,
and the choice can change after each collection; objects reachable and the choice can change after each collection; objects reachable
from both a custodian and its descendant, however, are reliably from both a custodian and its descendant, however, are reliably
charged to the descendant. Reachability for per-custodian accounting charged to the custodian and not to the descendants, unless the
does not include weak references, references to threads managed by custodian can reach the objects only through a descendant custodian or
non-descendant custodians, references to non-descendant custodians, or a descendant's thread. Reachability for per-custodian accounting does
references to custodian boxes for non-descendant custodians. not include weak references, references to threads managed by other
custodians, references to other custodians, or references to custodian
boxes for other custodians.

118
collects/scribblings/reference/sandbox.scrbl
View File

@ -16,10 +16,9 @@
The @schememodname[scheme/sandbox] module provides utilities for The @schememodname[scheme/sandbox] module provides utilities for
creating ``sandboxed'' evaluators, which are configured in a creating ``sandboxed'' evaluators, which are configured in a
particular way and can have restricted resources (memory and time), particular way and can have restricted resources (memory and time),
filesystem access, and network access. The common use case for this filesystem and network access, and much. Sandboxed evaluators can be
module is for a restricted sandboxed environment, so the defaults are configured through numerous parameters --- and the defaults are set
set up to make it safe. For other uses you will likely need to change for the common use case where sandboxes are very limited.
mane of these settings.
@defproc*[([(make-evaluator [language (or/c module-path? @defproc*[([(make-evaluator [language (or/c module-path?
(list/c 'special symbol?) (list/c 'special symbol?)
@ -260,9 +259,29 @@ either @scheme['time] or @scheme['memory].}
@section{Customizing Evaluators} @section{Customizing Evaluators}
The evaluators that @scheme[make-evaluator] creates can be customized The sandboxed evaluators that @scheme[make-evaluator] creates can be
via several parameters. These parameters affect newly created customized via many parameters. Most of the configuration parameters
evaluators; changing them has no effect on already-running evaluators. affect newly created evaluators; changing them has no effect on
already-running evaluators.
The default configuration options are set for a very restricted
sandboxed environment --- one that is safe to make publicly available.
Further customizations might be needed in case more privileges are
needed, or if you want tighter restrictions. Another useful approach
for customizing an evaluator is to begin with a relatively
unrestricted configuration and add the desired restrictions. This is
possible by the @scheme[call-with-trusted-sandbox-configuration]
function.
@defproc[(call-with-trusted-sandbox-configuration [thunk (-> any)])
any]{
Invokes the @scheme[thunk] in a context where sandbox configuration
parameters are set for minimal restrictions. More specifically, there
are no memory or time limits, and the existing existing inspectors,
security guard, exit handler, and logger are used. (Note that the I/O
ports settings are not included.)}
@defparam[sandbox-init-hook thunk (-> any)]{ @defparam[sandbox-init-hook thunk (-> any)]{
@ -443,7 +462,7 @@ specifications in @scheme[sandbox-path-permissions], and it uses
@defparam[sandbox-path-permissions perms @defparam[sandbox-path-permissions perms
(listof (list/c (or/c 'execute 'write 'delete 'read 'exists) (listof (list/c (or/c 'execute 'write 'delete 'read-bytecode 'read 'exists)
(or/c byte-regexp? bytes? string? path?)))]{ (or/c byte-regexp? bytes? string? path?)))]{
A parameter that configures the behavior of the default sandbox A parameter that configures the behavior of the default sandbox
@ -453,9 +472,9 @@ each is an access mode and a byte-regexp for paths that are granted this
access. access.
The access mode symbol is one of: @scheme['execute], @scheme['write], The access mode symbol is one of: @scheme['execute], @scheme['write],
@scheme['delete], @scheme['read], or @scheme['exists]. These symbols are @scheme['delete], @scheme['read], or @scheme['exists]. These symbols
in decreasing order: each implies access for the following modes too are in decreasing order: each implies access for the following modes
(e.g., @scheme['read] allows reading or checking for existence). too (e.g., @scheme['read] allows reading or checking for existence).
The path regexp is used to identify paths that are granted access. It The path regexp is used to identify paths that are granted access. It
can also be given as a path (or a string or a byte string), which is can also be given as a path (or a string or a byte string), which is
@ -463,9 +482,25 @@ can also be given as a path (or a string or a byte string), which is
to a regexp that allows the path and sub-directories; e.g., to a regexp that allows the path and sub-directories; e.g.,
@scheme["/foo/bar"] applies to @scheme["/foo/bar/baz"]. @scheme["/foo/bar"] applies to @scheme["/foo/bar/baz"].
An additional mode symbol, @scheme['read-bytecode], is not part of the
linear order of these modes. Specifying this mode is similar to
specifying @scheme['read], but it is not implied by any other mode.
(For example, even if you specify @scheme['write] for a certain path,
you need to also specify @scheme['read-bytecode] to grant this
permission.) The sandbox usually works in the context of a lower code
inspector (see @scheme[sandbox-make-code-inspector]) which prevents
loading of untrusted bytecode files --- the sandbox is set-up to allow
loading bytecode from files that are specified with
@scheme['read-bytecode]. This specification is given by default to
the PLT collection hierarchy (including user-specific libraries) and
to libraries that are explicitly specified in an @scheme[#:allow-read]
argument. (Note that this applies for loading bytecode files only,
under a lower code inspector it is still impossible to use protected
module bindings (see @secref["modprotect"]).)
The default value is null, but when an evaluator is created, it is The default value is null, but when an evaluator is created, it is
augmented by @scheme['read] permissions that make it possible to use augmented by @scheme['read-bytecode] permissions that make it possible
collection libraries (including to use collection libraries (including
@scheme[sandbox-override-collection-paths]). See @scheme[sandbox-override-collection-paths]). See
@scheme[make-evalautor] for more information.} @scheme[make-evalautor] for more information.}
@ -490,29 +525,54 @@ appropriate error message (see
@scheme[exn:fail:sandbox-terminated-reason]).} @scheme[exn:fail:sandbox-terminated-reason]).}
@defparam[sandbox-memory-limit limit (or/c exact-nonnegative-integer? #f)]{ @defparam[sandbox-memory-limit limit (or/c nonnegative-number? #f)]{
A parameter that determines the total memory limit on the sandbox. A parameter that determines the total memory limit on the sandbox in
When this limit is exceeded, the sandbox is terminated. This value is megabytes (it can hold a rational or a floating point number). When
used when the sandbox is created and the limit cannot be changed this limit is exceeded, the sandbox is terminated. This value is used
afterwards. See @scheme[sandbox-eval-limits] for per-evaluation when the sandbox is created and the limit cannot be changed
limits and a description of how the two limits work together.} afterwards. It defaults to 30mb. See @scheme[sandbox-eval-limits]
for per-evaluation limits and a description of how the two limits work
together.
Note that (when memory accounting is enabled) memory is attributed to
the highest custodian that refers to it. This means that if you
inspect a value that sandboxed evaluation returns outside of the
sandbox, your own custodian will be charged for it. To ensure that it
is charged back to the sandbox, you should remove references to such
values when the code is done inspecting it.
This policy has an impact on how the sandbox memory limit interacts
with the the per-expression limit specified by
@scheme[sandbox-eval-limits]: values that are reachable from the
sandbox, as well as from the interaction will count against the
sandbox limit. For example, in the last interaction of this code,
@schemeblock[
(define e (make-evaluator 'scheme/base))
(e '(define a 1))
(e '(for ([i (in-range 20)]) (set! a (cons (make-bytes 500000) a))))
]
the memory blocks are allocated within the interaction limit, but
since they're chained to the defined variable, they're also reachable
from the sandbox --- so they will count against the sandbox memory
limit but not against the interaction limit (more precisely, no more
than one block counts against the interaction limit).}
@defparam[sandbox-eval-limits limits @defparam[sandbox-eval-limits limits
(or/c (list/c (or/c exact-nonnegative-integer? #f) (or/c (list/c (or/c nonnegative-number? #f)
(or/c exact-nonnegative-integer? #f)) (or/c nonnegative-number? #f))
#f)]{ #f)]{
A parameter that determines the default limits on @italic{each} use of A parameter that determines the default limits on @italic{each} use of
a @scheme[make-evaluator] function, including the initial evaluation a @scheme[make-evaluator] function, including the initial evaluation
of the input program. Its value should be a list of two numbers; of the input program. Its value should be a list of two numbers;
where the first is a timeout value in seconds, and the second is a where the first is a timeout value in seconds, and the second is a
memory limit in megabytes. Either one can be @scheme[#f] for memory limit in megabytes (note that they don't have to be integers).
disabling the corresponding limit; alternately, the parameter can be Either one can be @scheme[#f] for disabling the corresponding limit;
set to @scheme[#f] to disable all per-evaluation limits (useful in alternately, the parameter can be set to @scheme[#f] to disable all
case more limit kinds are available in future versions). The default per-evaluation limits (useful in case more limit kinds are available
is @scheme[(list 30 20)]. in future versions). The default is @scheme[(list 30 20)].
Note that these limits apply to the creation of the sandbox Note that these limits apply to the creation of the sandbox
environment too --- even @scheme[(make-evaluator 'scheme/base)] can environment too --- even @scheme[(make-evaluator 'scheme/base)] can
@ -582,7 +642,11 @@ an evaluator, and the default parameter value is
A parameter that determines the procedure used to create the code A parameter that determines the procedure used to create the code
inspector for sandboxed evaluation. The procedure is called when inspector for sandboxed evaluation. The procedure is called when
initializing an evaluator, and the default parameter value is initializing an evaluator, and the default parameter value is
@scheme[make-inspector].} @scheme[make-inspector]. The @scheme[current-load/use-compiled]
handler is setup to still allow loading of bytecode files under the
original code inspector when @scheme[sandbox-path-permissions] allows
it through a @scheme['read-bytecode] mode symbol, to make it possible
to load libraries.}
@defparam[sandbox-make-logger make (-> logger?)]{ @defparam[sandbox-make-logger make (-> logger?)]{

4
collects/scribblings/reference/security-guards.scrbl
View File

@ -37,8 +37,8 @@ host platform.
(or/c (integer-in 1 65535) #f) (or/c (integer-in 1 65535) #f)
(or/c 'server 'client) (or/c 'server 'client)
. -> . any)] . -> . any)]
[link (or/c (symbol? path? path? . -> . any) #f) [link-guard (or/c (symbol? path? path? . -> . any) #f)
#f]) #f])
security-guard?]{ security-guard?]{
Creates a new security guard as child of @scheme[parent]. Creates a new security guard as child of @scheme[parent].

2
collects/string-constants/english-string-constants.ss
View File

@ -862,7 +862,7 @@ please adhere to these guidelines:
(force-quit-menu-item-help-string "Uses custodian-shutdown-all to abort the current evaluation") (force-quit-menu-item-help-string "Uses custodian-shutdown-all to abort the current evaluation")
(limit-memory-menu-item-label "Limit Memory...") (limit-memory-menu-item-label "Limit Memory...")
(limit-memory-msg-1 "The limit will take effect the next time the program") (limit-memory-msg-1 "The limit will take effect the next time the program")
(limit-memory-msg-2 "is Run, and it must be at least 100 megabytes.") (limit-memory-msg-2 "is Run, and it must be at least one megabyte.")
(limit-memory-unlimited "Unlimited") (limit-memory-unlimited "Unlimited")
(limit-memory-limited "Limited") (limit-memory-limited "Limited")
(limit-memory-megabytes "Megabytes") (limit-memory-megabytes "Megabytes")

2
collects/string-constants/french-string-constants.ss
View File

@ -859,7 +859,7 @@
(force-quit-menu-item-help-string "Utilise custodian-shutdown-all pour terminer toute l'évaluation courante") (force-quit-menu-item-help-string "Utilise custodian-shutdown-all pour terminer toute l'évaluation courante")
(limit-memory-menu-item-label "Limiter la mémoire...") (limit-memory-menu-item-label "Limiter la mémoire...")
(limit-memory-msg-1 "La limite prendra effet à la prochaine exécution du programme.") (limit-memory-msg-1 "La limite prendra effet à la prochaine exécution du programme.")
(limit-memory-msg-2 "Elle doit être d'au moins 100 megaoctets.") (limit-memory-msg-2 "Elle doit être d'au moins 1 megaoctet.")
(limit-memory-unlimited "Illimitée") (limit-memory-unlimited "Illimitée")
(limit-memory-limited "Limitée") (limit-memory-limited "Limitée")
(limit-memory-megabytes "Megaoctets") (limit-memory-megabytes "Megaoctets")

2
collects/string-constants/german-string-constants.ss
View File

@ -763,7 +763,7 @@
(force-quit-menu-item-help-string "Benutzt custodian-shutdown-all, um die Auswertung abzubrechen") (force-quit-menu-item-help-string "Benutzt custodian-shutdown-all, um die Auswertung abzubrechen")
(limit-memory-menu-item-label "Speicherverbrauch einschränken...") (limit-memory-menu-item-label "Speicherverbrauch einschränken...")
(limit-memory-msg-1 "Das Limit wird beim nächsten Programmstart aktiv") (limit-memory-msg-1 "Das Limit wird beim nächsten Programmstart aktiv")
(limit-memory-msg-2 "und muß mindestens 100 Megabytes betragen.") (limit-memory-msg-2 "und muß mindestens 1 Megabyte betragen.")
(limit-memory-unlimited "nicht einschränken") (limit-memory-unlimited "nicht einschränken")
(limit-memory-limited "einschränken") (limit-memory-limited "einschränken")
(limit-memory-megabytes "Megabytes") (limit-memory-megabytes "Megabytes")

2
collects/string-constants/japanese-string-constants.ss
View File

@ -805,7 +805,7 @@ please adhere to these guidelines:
(kill-menu-item-help-string "現在の評価を強制終了します") (kill-menu-item-help-string "現在の評価を強制終了します")
(limit-memory-menu-item-label "メモリを制限する...") (limit-memory-menu-item-label "メモリを制限する...")
(limit-memory-msg-1 "ここで指定したメモリ制限値は、プログラムを次に実行するときに有効になります。") (limit-memory-msg-1 "ここで指定したメモリ制限値は、プログラムを次に実行するときに有効になります。")
(limit-memory-msg-2 "制限値は 100MB 以上にしてください。") (limit-memory-msg-2 "制限値は 1MB 以上にしてください。")
(limit-memory-unlimited "制限しない") (limit-memory-unlimited "制限しない")
(limit-memory-limited "制限する") (limit-memory-limited "制限する")
(limit-memory-megabytes "MB") (limit-memory-megabytes "MB")

2
collects/string-constants/simplified-chinese-string-constants.ss
View File

@ -780,7 +780,7 @@
(force-quit-menu-item-help-string "使用custodian-shutdown-all退出当前计算") (force-quit-menu-item-help-string "使用custodian-shutdown-all退出当前计算")
(limit-memory-menu-item-label "限制内存使用...") (limit-memory-menu-item-label "限制内存使用...")
(limit-memory-msg-1 "内存限制会在下一次运行") (limit-memory-msg-1 "内存限制会在下一次运行")
(limit-memory-msg-2 "时生效。内存限制最低值为100megabytes.") (limit-memory-msg-2 "时生效。内存限制最低值为1megabyte.")
(limit-memory-unlimited "无限制") (limit-memory-unlimited "无限制")
(limit-memory-limited "限制") (limit-memory-limited "限制")
(limit-memory-megabytes "Megabytes") (limit-memory-megabytes "Megabytes")

2
collects/string-constants/traditional-chinese-string-constants.ss
View File

@ -779,7 +779,7 @@
(force-quit-menu-item-help-string "使用custodian-shutdown-all退出当前计算") (force-quit-menu-item-help-string "使用custodian-shutdown-all退出当前计算")
(limit-memory-menu-item-label "限制内存使用...") (limit-memory-menu-item-label "限制内存使用...")
(limit-memory-msg-1 "内存限制会在下一次运行") (limit-memory-msg-1 "内存限制会在下一次运行")
(limit-memory-msg-2 "时生效。内存限制最低值为100megabytes.") (limit-memory-msg-2 "时生效。内存限制最低值为1megabyte.")
(limit-memory-unlimited "无限制") (limit-memory-unlimited "无限制")
(limit-memory-limited "限制") (limit-memory-limited "限制")
(limit-memory-megabytes "Megabytes") (limit-memory-megabytes "Megabytes")

189
collects/tests/mzscheme/sandbox.ss
View File

@ -148,11 +148,11 @@
=err> "out of time" =err> "out of time"
(when (custodian-memory-accounting-available?) (when (custodian-memory-accounting-available?)
(t --top-- (t --top--
(set! ev (parameterize ([sandbox-eval-limits '(0.25 2)]) (set! ev (parameterize ([sandbox-eval-limits '(2 2)])
(make-evaluator 'scheme/base (make-evaluator 'scheme/base
'(define a (for/list ([i (in-range 10)]) '(define a (for/list ([i (in-range 10)])
(collect-garbage) (collect-garbage)
(make-string 1000)))))) (make-bytes 500000))))))
=err> "out of memory")) =err> "out of memory"))
;; i/o ;; i/o
@ -275,59 +275,94 @@
;; limited FS access, allowed for requires ;; limited FS access, allowed for requires
--top-- --top--
(let* ([tmp (find-system-path 'temp-dir)] (let* ([tmp (make-temporary-file "sandboxtest~a" 'directory)]
[schemelib (path->string (collection-path "scheme"))] [strpath (lambda xs (path->string (apply build-path xs)))]
[list-lib (path->string (build-path schemelib "list.ss"))] [schemelib (strpath (collection-path "scheme"))]
[test-lib (path->string (build-path tmp "sandbox-test.ss"))]) [list-lib (strpath schemelib "list.ss")]
(t --top-- [list-zo (strpath schemelib "compiled" "list_ss.zo")]
(set! ev (make-evaluator 'scheme/base)) [test-lib (strpath tmp "sandbox-test.ss")]
--eval-- [test-zo (strpath tmp "compiled" "sandbox-test_ss.zo")]
;; reading from collects is allowed [test2-lib (strpath tmp "sandbox-test2.ss")]
(list (directory-list ,schemelib)) [test2-zo (strpath tmp "compiled" "sandbox-test2_ss.zo")])
(file-exists? ,list-lib) => #t (t --top--
(input-port? (open-input-file ,list-lib)) => #t (set! ev (make-evaluator 'scheme/base))
;; writing is forbidden --eval--
(open-output-file ,list-lib) =err> "`write' access denied" ;; reading from collects is allowed
;; reading from other places is forbidden (list? (directory-list ,schemelib))
(directory-list ,tmp) =err> "`read' access denied" (file-exists? ,list-lib) => #t
;; no network too (input-port? (open-input-file ,list-lib)) => #t
(require scheme/tcp) ;; writing is forbidden
(tcp-listen 12345) =err> "network access denied" (open-output-file ,list-lib) =err> "`write' access denied"
--top-- ;; reading from other places is forbidden
;; reading from a specified require is fine (directory-list ,tmp) =err> "`read' access denied"
(with-output-to-file test-lib ;; no network too
(lambda () (require scheme/tcp)
(printf "~s\n" '(module sandbox-test scheme/base (tcp-listen 12345) =err> "network access denied"
(define x 123) (provide x)))) --top--
#:exists 'replace) ;; reading from a specified require is fine
(set! ev (make-evaluator 'scheme/base #:requires `(,test-lib))) (with-output-to-file test-lib
--eval-- (lambda ()
x => 123 (printf "~s\n" '(module sandbox-test scheme/base
(length (with-input-from-file ,test-lib read)) => 5 (define x 123) (provide x)))))
;; the directory is still not kosher (set! ev (make-evaluator 'scheme/base #:requires `(,test-lib)))
(directory-list ,tmp) =err> "`read' access denied" --eval--
--top-- x => 123
;; should work also for module evaluators (length (with-input-from-file ,test-lib read)) => 5
;; --> NO! Shouldn't make user code require whatever it wants ;; the directory is still not kosher
;; (set! ev (make-evaluator `(module foo scheme/base (directory-list ,tmp) =err> "`read' access denied"
;; (require (file ,test-lib))))) --top--
;; --eval-- ;; should work also for module evaluators
;; x => 123 ;; --> NO! Shouldn't make user code require whatever it wants
;; (length (with-input-from-file ,test-lib read)) => 5 ;; (set! ev (make-evaluator `(module foo scheme/base
;; ;; the directory is still not kosher ;; (require (file ,test-lib)))))
;; (directory-list tmp) =err> "file access denied" ;; --eval--
--top-- ;; x => 123
;; explicitly allow access to tmp ;; (length (with-input-from-file ,test-lib read)) => 5
(set! ev (parameterize ([sandbox-path-permissions ;; ;; the directory is still not kosher
`((read ,tmp) ;; (directory-list tmp) =err> "file access denied"
,@(sandbox-path-permissions))]) --top--
(make-evaluator 'scheme/base))) ;; explicitly allow access to tmp, and write access to a single file
--eval-- (make-directory (build-path tmp "compiled"))
(length (with-input-from-file ,test-lib read)) => 5 (set! ev (parameterize ([sandbox-path-permissions
(list? (directory-list ,tmp)) `((read ,tmp)
(open-output-file ,(build-path tmp "blah")) =err> "access denied" (write ,test-zo)
(delete-directory ,(build-path tmp "blah")) =err> "access denied") ,@(sandbox-path-permissions))])
(delete-file test-lib)) (make-evaluator 'scheme/base)))
--eval--
(length (with-input-from-file ,test-lib read)) => 5
(list? (directory-list ,tmp))
(open-output-file ,(build-path tmp "blah")) =err> "access denied"
(delete-directory ,(build-path tmp "blah")) =err> "access denied"
(list? (directory-list ,schemelib))
;; we can read/write/delete list-zo, but we can't load bytecode from
;; it due to the code inspector
(copy-file ,list-zo ,test-zo) => (void)
(copy-file ,test-zo ,list-zo) =err> "access denied"
(load/use-compiled ,test-lib) => (void)
(require 'list) =err> "access from an uncertified context"
(delete-file ,test-zo) => (void)
(delete-file ,test-lib) =err> "`delete' access denied"
--top--
;; a more explicit test of bytcode loading, allowing rw access to the
;; complete tmp directory, but read-bytecode only for test2-lib
(set! ev (parameterize ([sandbox-path-permissions
`((write ,tmp)
(read-bytecode ,test2-lib)
,@(sandbox-path-permissions))])
(make-evaluator 'scheme/base)))
--eval--
(define (cp from to)
(when (file-exists? to) (delete-file to))
(copy-file from to))
(cp ,list-lib ,test-lib) (cp ,list-zo ,test-zo)
(cp ,list-lib ,test2-lib) (cp ,list-zo ,test2-zo)
;; bytecode from test-lib is bad, even when we can read/write to it
(load/use-compiled ,test-zo)
(require 'list) =err> "access from an uncertified context"
;; bytecode from test2-lib is explicitly allowed
(load/use-compiled ,test2-lib)
(require 'list) => (void))
((dynamic-require 'scheme/file 'delete-directory/files) tmp))
;; languages and requires ;; languages and requires
--top-- --top--
@ -388,30 +423,17 @@
--top-- --top--
(set! ev (parameterize ([sandbox-output 'bytes] (set! ev (parameterize ([sandbox-output 'bytes]
[sandbox-error-output current-output-port] [sandbox-error-output current-output-port]
[sandbox-memory-limit 5] [sandbox-memory-limit 2]
[sandbox-eval-limits '(0.25 1/2)]) [sandbox-eval-limits '(0.25 1)])
(make-evaluator 'scheme/base))) (make-evaluator 'scheme/base)))
;; GCing is needed to allow these to happen ;; GCing is needed to allow these to happen (note: the memory limit is very
--eval-- (display (make-bytes 400000 65)) (collect-garbage) ;; tight here, this test usually fails if the sandbox library is not
--top-- (bytes-length (get-output ev)) => 400000 ;; compiled)
--eval-- (display (make-bytes 400000 65)) (collect-garbage) (let ([t (lambda ()
--top-- (bytes-length (get-output ev)) => 400000 (t --eval-- (display (make-bytes 400000 65)) (collect-garbage)
--eval-- (display (make-bytes 400000 65)) (collect-garbage) --top-- (bytes-length (get-output ev)) => 400000))])
--top-- (bytes-length (get-output ev)) => 400000 ;; can go arbitrarily high here
--eval-- (display (make-bytes 400000 65)) (collect-garbage) (for ([i (in-range 20)]) (t)))
--top-- (bytes-length (get-output ev)) => 400000
--eval-- (display (make-bytes 400000 65)) (collect-garbage)
--top-- (bytes-length (get-output ev)) => 400000
--eval-- (display (make-bytes 400000 65)) (collect-garbage)
--top-- (bytes-length (get-output ev)) => 400000
--eval-- (display (make-bytes 400000 65)) (collect-garbage)
--top-- (bytes-length (get-output ev)) => 400000
--eval-- (display (make-bytes 400000 65)) (collect-garbage)
--top-- (bytes-length (get-output ev)) => 400000
--eval-- (display (make-bytes 400000 65)) (collect-garbage)
--top-- (bytes-length (get-output ev)) => 400000
--eval-- (display (make-bytes 400000 65)) (collect-garbage)
--top-- (bytes-length (get-output ev)) => 400000
;; test that killing the custodian works fine ;; test that killing the custodian works fine
;; first try it without limits (limits imply a nested thread/custodian) ;; first try it without limits (limits imply a nested thread/custodian)
@ -466,9 +488,14 @@
--eval-- --eval--
(define a '()) (define a '())
(define b 1) (define b 1)
(for ([i (in-range 20)]) (length
(set! a (cons (make-bytes 500000) a)) (for/fold ([v null]) ([i (in-range 20)])
(collect-garbage)) ;; increases size of sandbox: it's reachable from it (outside of
;; this evaluation) because `a' is defined there
(set! a (cons (make-bytes 500000) a))
(collect-garbage)
;; increases size of the current evaluation
(cons (make-bytes 500000) v)))
=err> "out of memory" =err> "out of memory"
b => 1)) b => 1))

18
collects/tests/mzscheme/testing.ss
View File

@ -77,17 +77,13 @@ transcript.
(define number-of-exn-tests 0) (define number-of-exn-tests 0)
(define (load-in-sandbox file) (define (load-in-sandbox file)
(let ([e (parameterize ([(dynamic-require 'scheme/sandbox 'sandbox-security-guard) (define-syntax-rule (S id) (dynamic-require 'scheme/sandbox 'id))
(current-security-guard)] (let ([e ((S call-with-trusted-sandbox-configuration)
[(dynamic-require 'scheme/sandbox 'sandbox-input) (parameterize ([(S sandbox-input) current-input-port]
current-input-port] [(S sandbox-output) current-output-port]
[(dynamic-require 'scheme/sandbox 'sandbox-output) [(S sandbox-error-output) current-error-port]
current-output-port] [(S sandbox-memory-limit) 100]) ; 100mb per box
[(dynamic-require 'scheme/sandbox 'sandbox-error-output) ((S make-evaluator) '(begin) #:requires (list 'scheme))))])
current-error-port]
[(dynamic-require 'scheme/sandbox 'sandbox-eval-limits)
#f])
((dynamic-require 'scheme/sandbox 'make-evaluator) '(begin) #:requires (list 'scheme)))])
(e `(load-relative "testing.ss")) (e `(load-relative "testing.ss"))
(e `(define real-error-port (quote ,real-error-port))) (e `(define real-error-port (quote ,real-error-port)))
(e `(define Section-prefix ,Section-prefix)) (e `(define Section-prefix ,Section-prefix))

3
doc/release-notes/mzscheme/HISTORY.txt
View File

@ -1,3 +1,6 @@
Version 4.1.3.6
Memory accounting changed to bias charges to parent instead of children
Version 4.1.3.3 Version 4.1.3.3
Added compile-context-preservation-enabled Added compile-context-preservation-enabled
Added exception-backtrace support for x86_84+JIT Added exception-backtrace support for x86_84+JIT

109
src/foreign/foreign.c
View File

@ -810,9 +810,16 @@ typedef union _ForeignAny {
/* Type objects */ /* Type objects */
/* This struct is used for both user types and primitive types (including /* This struct is used for both user types and primitive types (including
* struct types). If it is a primitive type then basetype will be NULL, and * struct types). If it is a user type then basetype will be another ctype,
* otherwise,
* - if it's a primitive type, then basetype will be a symbol naming that type
* - if it's a struct, then basetype will be the list of ctypes that
* made this struct
* scheme_to_c will have the &ffi_type pointer, and c_to_scheme will have an * scheme_to_c will have the &ffi_type pointer, and c_to_scheme will have an
* integer (a label value) for non-struct type. */ * integer (a label value) for non-struct type. (Note that the
* integer is not really needed, since it is possible to identify the
* type by the basetype field.)
*/
/* ctype structure definition */ /* ctype structure definition */
static Scheme_Type ctype_tag; static Scheme_Type ctype_tag;
typedef struct ctype_struct { typedef struct ctype_struct {
@ -849,8 +856,8 @@ END_XFORM_SKIP;
#endif #endif
#define CTYPE_BASETYPE(x) (((ctype_struct*)(x))->basetype) #define CTYPE_BASETYPE(x) (((ctype_struct*)(x))->basetype)
#define CTYPE_PRIMP(x) (NULL == (CTYPE_BASETYPE(x))) #define CTYPE_USERP(x) (CTYPE_BASETYPE(x) != NULL && SCHEME_CTYPEP(CTYPE_BASETYPE(x)))
#define CTYPE_USERP(x) (!(CTYPE_PRIMP(x))) #define CTYPE_PRIMP(x) (!CTYPE_USERP(x))
#define CTYPE_PRIMTYPE(x) ((ffi_type*)(((ctype_struct*)(x))->scheme_to_c)) #define CTYPE_PRIMTYPE(x) ((ffi_type*)(((ctype_struct*)(x))->scheme_to_c))
#define CTYPE_PRIMLABEL(x) ((long)(((ctype_struct*)(x))->c_to_scheme)) #define CTYPE_PRIMLABEL(x) ((long)(((ctype_struct*)(x))->c_to_scheme))
#define CTYPE_USER_S2C(x) (((ctype_struct*)(x))->scheme_to_c) #define CTYPE_USER_S2C(x) (((ctype_struct*)(x))->scheme_to_c)
@ -861,12 +868,9 @@ END_XFORM_SKIP;
#define MYNAME "ctype-basetype" #define MYNAME "ctype-basetype"
static Scheme_Object *foreign_ctype_basetype(int argc, Scheme_Object *argv[]) static Scheme_Object *foreign_ctype_basetype(int argc, Scheme_Object *argv[])
{ {
Scheme_Object *base;
if (!SCHEME_CTYPEP(argv[0])) if (!SCHEME_CTYPEP(argv[0]))
scheme_wrong_type(MYNAME, "ctype", 0, argc, argv); scheme_wrong_type(MYNAME, "ctype", 0, argc, argv);
base = CTYPE_BASETYPE(argv[0]); return CTYPE_BASETYPE(argv[0]);
if (NULL == base) return scheme_false;
else return base;
} }
#undef MYNAME #undef MYNAME
@ -1046,7 +1050,7 @@ static Scheme_Object *foreign_make_cstruct_type(int argc, Scheme_Object *argv[])
scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK"); scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK");
type = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); type = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
type->so.type = ctype_tag; type->so.type = ctype_tag;
type->basetype = (NULL); type->basetype = (argv[0]);
type->scheme_to_c = ((Scheme_Object*)libffi_type); type->scheme_to_c = ((Scheme_Object*)libffi_type);
type->c_to_scheme = ((Scheme_Object*)FOREIGN_struct); type->c_to_scheme = ((Scheme_Object*)FOREIGN_struct);
scheme_register_finalizer(type, free_libffi_type, libffi_type, NULL, NULL); scheme_register_finalizer(type, free_libffi_type, libffi_type, NULL, NULL);
@ -1166,12 +1170,11 @@ END_XFORM_SKIP;
static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src, static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src,
int delta, int args_loc) int delta, int args_loc)
{ {
Scheme_Object *res, *base; Scheme_Object *res;
if (!SCHEME_CTYPEP(type)) if (!SCHEME_CTYPEP(type))
scheme_wrong_type("C->Scheme", "C-type", 0, 1, &type); scheme_wrong_type("C->Scheme", "C-type", 0, 1, &type);
base = CTYPE_BASETYPE(type); if (CTYPE_USERP(type)) {
if (base != NULL) { res = C2SCHEME(CTYPE_BASETYPE(type), src, delta, args_loc);
res = C2SCHEME(base, src, delta, args_loc);
if (SCHEME_FALSEP(CTYPE_USER_C2S(type))) if (SCHEME_FALSEP(CTYPE_USER_C2S(type)))
return res; return res;
else else
@ -2347,7 +2350,7 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
offset = 0; offset = 0;
p = SCHEME2C(SCHEME_CAR(itypes), &(ivals[i]), 0, argv[i], &basetype, p = SCHEME2C(SCHEME_CAR(itypes), &(ivals[i]), 0, argv[i], &basetype,
&offset, 0); &offset, 0);
if (p != NULL) { if ((p != NULL) || offset) {
avalues[i] = p; avalues[i] = p;
ivals[i].x_fixnum = basetype; /* remember the base type */ ivals[i].x_fixnum = basetype; /* remember the base type */
} else { } else {
@ -2370,7 +2373,7 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
/* We finished with all possible mallocs, clear up the avalues and offsets /* We finished with all possible mallocs, clear up the avalues and offsets
* mess */ * mess */
for (i=0; i<nargs; i++) { for (i=0; i<nargs; i++) {
if (avalues[i] == NULL) /* if this was a non-pointer... */ if ((avalues[i] == NULL) && !offsets[i]) /* if this was a non-pointer... */
avalues[i] = &(ivals[i]); /* ... set the avalues pointer */ avalues[i] = &(ivals[i]); /* ... set the avalues pointer */
else if (ivals[i].x_fixnum != FOREIGN_struct) { /* if *not* a struct... */ else if (ivals[i].x_fixnum != FOREIGN_struct) { /* if *not* a struct... */
/* ... set the ivals pointer (pointer type doesn't matter) and avalues */ /* ... set the ivals pointer (pointer type doesn't matter) and avalues */
@ -2632,6 +2635,7 @@ void scheme_init_foreign(Scheme_Env *env)
{ {
Scheme_Env *menv; Scheme_Env *menv;
ctype_struct *t; ctype_struct *t;
Scheme_Object *s;
menv = scheme_primitive_module(scheme_intern_symbol("#%foreign"), env); menv = scheme_primitive_module(scheme_intern_symbol("#%foreign"), env);
ffi_lib_tag = scheme_make_type("<ffi-lib>"); ffi_lib_tag = scheme_make_type("<ffi-lib>");
ffi_obj_tag = scheme_make_type("<ffi-obj>"); ffi_obj_tag = scheme_make_type("<ffi-obj>");
@ -2749,153 +2753,178 @@ void scheme_init_foreign(Scheme_Env *env)
scheme_make_prim_w_arity(foreign_ffi_call, "ffi-call", 3, 4), menv); scheme_make_prim_w_arity(foreign_ffi_call, "ffi-call", 3, 4), menv);
scheme_add_global("ffi-callback", scheme_add_global("ffi-callback",
scheme_make_prim_w_arity(foreign_ffi_callback, "ffi-callback", 3, 4), menv); scheme_make_prim_w_arity(foreign_ffi_callback, "ffi-callback", 3, 4), menv);
s = scheme_intern_symbol("void");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag; t->so.type = ctype_tag;
t->basetype = (NULL); t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_void)); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_void));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_void); t->c_to_scheme = ((Scheme_Object*)FOREIGN_void);
scheme_add_global("_void", (Scheme_Object*)t, menv); scheme_add_global("_void", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("int8");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag; t->so.type = ctype_tag;
t->basetype = (NULL); t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint8)); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint8));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_int8); t->c_to_scheme = ((Scheme_Object*)FOREIGN_int8);
scheme_add_global("_int8", (Scheme_Object*)t, menv); scheme_add_global("_int8", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("uint8");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag; t->so.type = ctype_tag;
t->basetype = (NULL); t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint8)); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint8));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_uint8); t->c_to_scheme = ((Scheme_Object*)FOREIGN_uint8);
scheme_add_global("_uint8", (Scheme_Object*)t, menv); scheme_add_global("_uint8", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("int16");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag; t->so.type = ctype_tag;
t->basetype = (NULL); t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint16)); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint16));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_int16); t->c_to_scheme = ((Scheme_Object*)FOREIGN_int16);
scheme_add_global("_int16", (Scheme_Object*)t, menv); scheme_add_global("_int16", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("uint16");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag; t->so.type = ctype_tag;
t->basetype = (NULL); t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint16)); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint16));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_uint16); t->c_to_scheme = ((Scheme_Object*)FOREIGN_uint16);
scheme_add_global("_uint16", (Scheme_Object*)t, menv); scheme_add_global("_uint16", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("int32");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag; t->so.type = ctype_tag;
t->basetype = (NULL); t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint32)); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint32));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_int32); t->c_to_scheme = ((Scheme_Object*)FOREIGN_int32);
scheme_add_global("_int32", (Scheme_Object*)t, menv); scheme_add_global("_int32", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("uint32");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag; t->so.type = ctype_tag;
t->basetype = (NULL); t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint32)); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint32));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_uint32); t->c_to_scheme = ((Scheme_Object*)FOREIGN_uint32);
scheme_add_global("_uint32", (Scheme_Object*)t, menv); scheme_add_global("_uint32", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("int64");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag; t->so.type = ctype_tag;
t->basetype = (NULL); t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint64)); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint64));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_int64); t->c_to_scheme = ((Scheme_Object*)FOREIGN_int64);
scheme_add_global("_int64", (Scheme_Object*)t, menv); scheme_add_global("_int64", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("uint64");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag; t->so.type = ctype_tag;
t->basetype = (NULL); t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint64)); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint64));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_uint64); t->c_to_scheme = ((Scheme_Object*)FOREIGN_uint64);
scheme_add_global("_uint64", (Scheme_Object*)t, menv); scheme_add_global("_uint64", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("fixint");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag; t->so.type = ctype_tag;
t->basetype = (NULL); t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint32)); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint32));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_fixint); t->c_to_scheme = ((Scheme_Object*)FOREIGN_fixint);
scheme_add_global("_fixint", (Scheme_Object*)t, menv); scheme_add_global("_fixint", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("ufixint");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag; t->so.type = ctype_tag;
t->basetype = (NULL); t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint32)); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint32));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_ufixint); t->c_to_scheme = ((Scheme_Object*)FOREIGN_ufixint);
scheme_add_global("_ufixint", (Scheme_Object*)t, menv); scheme_add_global("_ufixint", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("fixnum");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag; t->so.type = ctype_tag;
t->basetype = (NULL); t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_smzlong)); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_smzlong));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_fixnum); t->c_to_scheme = ((Scheme_Object*)FOREIGN_fixnum);
scheme_add_global("_fixnum", (Scheme_Object*)t, menv); scheme_add_global("_fixnum", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("ufixnum");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag; t->so.type = ctype_tag;
t->basetype = (NULL); t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_umzlong)); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_umzlong));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_ufixnum); t->c_to_scheme = ((Scheme_Object*)FOREIGN_ufixnum);
scheme_add_global("_ufixnum", (Scheme_Object*)t, menv); scheme_add_global("_ufixnum", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("float");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag; t->so.type = ctype_tag;
t->basetype = (NULL); t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_float)); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_float));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_float); t->c_to_scheme = ((Scheme_Object*)FOREIGN_float);
scheme_add_global("_float", (Scheme_Object*)t, menv); scheme_add_global("_float", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("double");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag; t->so.type = ctype_tag;
t->basetype = (NULL); t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_double)); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_double));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_double); t->c_to_scheme = ((Scheme_Object*)FOREIGN_double);
scheme_add_global("_double", (Scheme_Object*)t, menv); scheme_add_global("_double", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("double*");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag; t->so.type = ctype_tag;
t->basetype = (NULL); t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_double)); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_double));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_doubleS); t->c_to_scheme = ((Scheme_Object*)FOREIGN_doubleS);
scheme_add_global("_double*", (Scheme_Object*)t, menv); scheme_add_global("_double*", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("bool");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag; t->so.type = ctype_tag;
t->basetype = (NULL); t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint)); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_bool); t->c_to_scheme = ((Scheme_Object*)FOREIGN_bool);
scheme_add_global("_bool", (Scheme_Object*)t, menv); scheme_add_global("_bool", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("string/ucs-4");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag; t->so.type = ctype_tag;
t->basetype = (NULL); t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer)); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_string_ucs_4); t->c_to_scheme = ((Scheme_Object*)FOREIGN_string_ucs_4);
scheme_add_global("_string/ucs-4", (Scheme_Object*)t, menv); scheme_add_global("_string/ucs-4", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("string/utf-16");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag; t->so.type = ctype_tag;
t->basetype = (NULL); t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer)); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_string_utf_16); t->c_to_scheme = ((Scheme_Object*)FOREIGN_string_utf_16);
scheme_add_global("_string/utf-16", (Scheme_Object*)t, menv); scheme_add_global("_string/utf-16", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("bytes");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag; t->so.type = ctype_tag;
t->basetype = (NULL); t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer)); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_bytes); t->c_to_scheme = ((Scheme_Object*)FOREIGN_bytes);
scheme_add_global("_bytes", (Scheme_Object*)t, menv); scheme_add_global("_bytes", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("path");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag; t->so.type = ctype_tag;
t->basetype = (NULL); t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer)); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_path); t->c_to_scheme = ((Scheme_Object*)FOREIGN_path);
scheme_add_global("_path", (Scheme_Object*)t, menv); scheme_add_global("_path", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("symbol");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag; t->so.type = ctype_tag;
t->basetype = (NULL); t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer)); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_symbol); t->c_to_scheme = ((Scheme_Object*)FOREIGN_symbol);
scheme_add_global("_symbol", (Scheme_Object*)t, menv); scheme_add_global("_symbol", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("pointer");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag; t->so.type = ctype_tag;
t->basetype = (NULL); t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer)); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_pointer); t->c_to_scheme = ((Scheme_Object*)FOREIGN_pointer);
scheme_add_global("_pointer", (Scheme_Object*)t, menv); scheme_add_global("_pointer", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("scheme");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag; t->so.type = ctype_tag;
t->basetype = (NULL); t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer)); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_scheme); t->c_to_scheme = ((Scheme_Object*)FOREIGN_scheme);
scheme_add_global("_scheme", (Scheme_Object*)t, menv); scheme_add_global("_scheme", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("fpointer");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag; t->so.type = ctype_tag;
t->basetype = (NULL); t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer)); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_fpointer); t->c_to_scheme = ((Scheme_Object*)FOREIGN_fpointer);
scheme_add_global("_fpointer", (Scheme_Object*)t, menv); scheme_add_global("_fpointer", (Scheme_Object*)t, menv);

59
src/foreign/foreign.ssc
View File

@ -10,6 +10,8 @@ exec mzpp -s "---begin" -o `echo "$0" | sed 's/ssc$/c/'` "$0"
** to make changes, edit that file and ** to make changes, edit that file and
** run it to generate an updated version ** run it to generate an updated version
** of this file. ** of this file.
** NOTE: This is no longer true, foreign.ssc needs to be updated to work with
** the scribble/text preprocessor instead.
********************************************/ ********************************************/
{:(load "ssc-utils.ss"):} {:(load "ssc-utils.ss"):}
@ -445,7 +447,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
(define *type-counter* 0) (define *type-counter* 0)
(define (describe-type stype cname ftype ctype pred s->c c->s offset) (define (describe-type type stype cname ftype ctype pred s->c c->s offset)
(set! *type-counter* (add1 *type-counter*)) (set! *type-counter* (add1 *type-counter*))
(~ "#define FOREIGN_"cname" ("*type-counter*")" \\ (~ "#define FOREIGN_"cname" ("*type-counter*")" \\
"/* Type Name: "stype (and (not (equal? cname stype)) "/* Type Name: "stype (and (not (equal? cname stype))
@ -466,7 +468,10 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
" * C->Scheme: "(cond [(not c->s) "-none-"] " * C->Scheme: "(cond [(not c->s) "-none-"]
[(procedure? c->s) (c->s "<C>")] [(procedure? c->s) (c->s "<C>")]
[else (list c->s"(<C>)")]) \\ [else (list c->s"(<C>)")]) \\
" */" \\)) " */" \\
;; no need for these, at least for now:
;; "static Scheme_Object *"cname"_sym;"\\
))
(define (make-ctype type args) (define (make-ctype type args)
(define (prop p . default) (define (prop p . default)
@ -491,7 +496,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
[s->c (prop 's->c (and macro (list "SCHEME_"macro"_VAL")))] [s->c (prop 's->c (and macro (list "SCHEME_"macro"_VAL")))]
[c->s (prop 'c->s)] [c->s (prop 'c->s)]
[offset (prop 'offset #f)]) [offset (prop 'offset #f)])
(describe-type stype cname ftype ctype pred s->c c->s offset) (describe-type type stype cname ftype ctype pred s->c c->s offset)
`(,type (stype ,stype) (cname ,cname) (ftype ,ftype) (ctype ,ctype) `(,type (stype ,stype) (cname ,cname) (ftype ,ftype) (ctype ,ctype)
(macro ,macro) (pred ,pred) (s->c ,s->c) (c->s ,c->s) (offset ,offset)))) (macro ,macro) (pred ,pred) (s->c ,s->c) (c->s ,c->s) (offset ,offset))))
@ -726,17 +731,24 @@ typedef union _ForeignAny {
/* Type objects */ /* Type objects */
/* This struct is used for both user types and primitive types (including /* This struct is used for both user types and primitive types (including
* struct types). If it is a primitive type then basetype will be NULL, and * struct types). If it is a user type then basetype will be another ctype,
* otherwise,
* - if it's a primitive type, then basetype will be a symbol naming that type
* - if it's a struct, then basetype will be the list of ctypes that
* made this struct
* scheme_to_c will have the &ffi_type pointer, and c_to_scheme will have an * scheme_to_c will have the &ffi_type pointer, and c_to_scheme will have an
* integer (a label value) for non-struct type. */ * integer (a label value) for non-struct type. (Note that the
* integer is not really needed, since it is possible to identify the
* type by the basetype field.)
*/
{:(cdefstruct ctype {:(cdefstruct ctype
(basetype "Scheme_Object*") (basetype "Scheme_Object*")
(scheme_to_c "Scheme_Object*") (scheme_to_c "Scheme_Object*")
(c_to_scheme "Scheme_Object*")):} (c_to_scheme "Scheme_Object*")):}
#define CTYPE_BASETYPE(x) (((ctype_struct*)(x))->basetype) #define CTYPE_BASETYPE(x) (((ctype_struct*)(x))->basetype)
#define CTYPE_PRIMP(x) (NULL == (CTYPE_BASETYPE(x))) #define CTYPE_USERP(x) (CTYPE_BASETYPE(x) != NULL && SCHEME_CTYPEP(CTYPE_BASETYPE(x)))
#define CTYPE_USERP(x) (!(CTYPE_PRIMP(x))) #define CTYPE_PRIMP(x) (!CTYPE_USERP(x))
#define CTYPE_PRIMTYPE(x) ((ffi_type*)(((ctype_struct*)(x))->scheme_to_c)) #define CTYPE_PRIMTYPE(x) ((ffi_type*)(((ctype_struct*)(x))->scheme_to_c))
#define CTYPE_PRIMLABEL(x) ((long)(((ctype_struct*)(x))->c_to_scheme)) #define CTYPE_PRIMLABEL(x) ((long)(((ctype_struct*)(x))->c_to_scheme))
#define CTYPE_USER_S2C(x) (((ctype_struct*)(x))->scheme_to_c) #define CTYPE_USER_S2C(x) (((ctype_struct*)(x))->scheme_to_c)
@ -745,12 +757,9 @@ typedef union _ForeignAny {
/* Returns #f for primitive types. */ /* Returns #f for primitive types. */
{:(cdefine ctype-basetype 1):} {:(cdefine ctype-basetype 1):}
{ {
Scheme_Object *base;
if (!SCHEME_CTYPEP(argv[0])) if (!SCHEME_CTYPEP(argv[0]))
scheme_wrong_type(MYNAME, "ctype", 0, argc, argv); scheme_wrong_type(MYNAME, "ctype", 0, argc, argv);
base = CTYPE_BASETYPE(argv[0]); return CTYPE_BASETYPE(argv[0]);
if (NULL == base) return scheme_false;
else return base;
} }
{:(cdefine ctype-scheme->c 1):} {:(cdefine ctype-scheme->c 1):}
@ -892,7 +901,7 @@ ffi_abi sym_to_abi(char *who, Scheme_Object *sym)
dummy = &libffi_type; dummy = &libffi_type;
if (ffi_prep_cif(&cif, abi, 1, &ffi_type_void, dummy) != FFI_OK) if (ffi_prep_cif(&cif, abi, 1, &ffi_type_void, dummy) != FFI_OK)
scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK"); scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK");
{:(cmake-object "type" ctype "NULL" {:(cmake-object "type" ctype "argv[0]"
"(Scheme_Object*)libffi_type" "(Scheme_Object*)libffi_type"
"(Scheme_Object*)FOREIGN_struct"):} "(Scheme_Object*)FOREIGN_struct"):}
scheme_register_finalizer(type, free_libffi_type, libffi_type, NULL, NULL); scheme_register_finalizer(type, free_libffi_type, libffi_type, NULL, NULL);
@ -974,12 +983,11 @@ ffi_abi sym_to_abi(char *who, Scheme_Object *sym)
static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src, static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src,
int delta, int args_loc) int delta, int args_loc)
{ {
Scheme_Object *res, *base; Scheme_Object *res;
if (!SCHEME_CTYPEP(type)) if (!SCHEME_CTYPEP(type))
scheme_wrong_type("C->Scheme", "C-type", 0, 1, &type); scheme_wrong_type("C->Scheme", "C-type", 0, 1, &type);
base = CTYPE_BASETYPE(type); if (CTYPE_USERP(type)) {
if (base != NULL) { res = C2SCHEME(CTYPE_BASETYPE(type), src, delta, args_loc);
res = C2SCHEME(base, src, delta, args_loc);
if (SCHEME_FALSEP(CTYPE_USER_C2S(type))) if (SCHEME_FALSEP(CTYPE_USER_C2S(type)))
return res; return res;
else else
@ -1677,6 +1685,9 @@ static Scheme_Object *do_memop(const char *who, int mode,
len, 0); len, 0);
} }
/* *** Calling Scheme code while the GC is working leads to subtle bugs, so
*** this is implemented now in Scheme using will executors. */
/* internal: apply Scheme finalizer */ /* internal: apply Scheme finalizer */
void do_scm_finalizer(void *p, void *finalizer) void do_scm_finalizer(void *p, void *finalizer)
{ {
@ -1707,9 +1718,6 @@ void do_ptr_finalizer(void *p, void *finalizer)
/* (Only needed in cases where pointer aliases might be created.) */ /* (Only needed in cases where pointer aliases might be created.) */
/* /*
*** Calling Scheme code while the GC is working leads to subtle bugs, so
*** this is implemented now in Scheme using will executors.
{:"(defsymbols pointer)":} {:"(defsymbols pointer)":}
{:"(cdefine register-finalizer 2 3)":} {:"(cdefine register-finalizer 2 3)":}
{ {
@ -1789,7 +1797,7 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
offset = 0; offset = 0;
p = SCHEME2C(SCHEME_CAR(itypes), &(ivals[i]), 0, argv[i], &basetype, p = SCHEME2C(SCHEME_CAR(itypes), &(ivals[i]), 0, argv[i], &basetype,
&offset, 0); &offset, 0);
if (p != NULL) { if ((p != NULL) || offset) {
avalues[i] = p; avalues[i] = p;
ivals[i].x_fixnum = basetype; /* remember the base type */ ivals[i].x_fixnum = basetype; /* remember the base type */
} else { } else {
@ -1812,7 +1820,7 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
/* We finished with all possible mallocs, clear up the avalues and offsets /* We finished with all possible mallocs, clear up the avalues and offsets
* mess */ * mess */
for (i=0; i<nargs; i++) { for (i=0; i<nargs; i++) {
if (avalues[i] == NULL) /* if this was a non-pointer... */ if ((avalues[i] == NULL) && !offsets[i]) /* if this was a non-pointer... */
avalues[i] = &(ivals[i]); /* ... set the avalues pointer */ avalues[i] = &(ivals[i]); /* ... set the avalues pointer */
else if (ivals[i].x_fixnum != FOREIGN_struct) { /* if *not* a struct... */ else if (ivals[i].x_fixnum != FOREIGN_struct) { /* if *not* a struct... */
/* ... set the ivals pointer (pointer type doesn't matter) and avalues */ /* ... set the ivals pointer (pointer type doesn't matter) and avalues */
@ -1961,7 +1969,7 @@ typedef struct closure_and_cif_struct {
void free_cl_cif_args(void *ignored, void *p) void free_cl_cif_args(void *ignored, void *p)
{ {
/* /*
scheme_warning("Releaseing cl+cif+args %V %V (%d)", scheme_warning("Releasing cl+cif+args %V %V (%d)",
ignored, ignored,
(((closure_and_cif*)p)->data), (((closure_and_cif*)p)->data),
SAME_OBJ(ignored,(((closure_and_cif*)p)->data))); SAME_OBJ(ignored,(((closure_and_cif*)p)->data)));
@ -2066,6 +2074,7 @@ void scheme_init_foreign(Scheme_Env *env)
{ {
Scheme_Env *menv; Scheme_Env *menv;
ctype_struct *t; ctype_struct *t;
Scheme_Object *s;
menv = scheme_primitive_module(scheme_intern_symbol("#%foreign"), env); menv = scheme_primitive_module(scheme_intern_symbol("#%foreign"), env);
{:(for-each (lambda (x) {:(for-each (lambda (x)
(~ (cadr x)"_tag = scheme_make_type(\"<"(car x)">\");")) (~ (cadr x)"_tag = scheme_make_type(\"<"(car x)">\");"))
@ -2090,7 +2099,11 @@ void scheme_init_foreign(Scheme_Env *env)
(cadr x)", \""(car x)"\", "(caddr x)", "(cadddr x)"), menv);")) (cadr x)", \""(car x)"\", "(caddr x)", "(cadddr x)"), menv);"))
(reverse! cfunctions)) (reverse! cfunctions))
(for-each-type (for-each-type
(cmake-object "t" ctype "NULL" ;; no need for these, at least for now:
;; (~ "MZ_REGISTER_STATIC("cname"_sym);" \\
;; cname"_sym = scheme_intern_symbol(\""stype"\");")
(~ "s = scheme_intern_symbol(\""stype"\");")
(cmake-object "t" ctype "s"
(list "(Scheme_Object*)(void*)(&ffi_type_"ftype")") (list "(Scheme_Object*)(void*)(&ffi_type_"ftype")")
(list "(Scheme_Object*)FOREIGN_"cname)) (list "(Scheme_Object*)FOREIGN_"cname))
(~ "scheme_add_global(\"_"stype"\", (Scheme_Object*)t, menv);")):} (~ "scheme_add_global(\"_"stype"\", (Scheme_Object*)t, menv);")):}

2
src/mred/Makefile.in
View File

@ -351,6 +351,7 @@ install-wx_mac-cgc:
$(ICP) -r PLT_MrEd.framework/Versions/$(FWVERSION)/Resources $(MRFWDIR)/Versions/$(FWVERSION)/Resources $(ICP) -r PLT_MrEd.framework/Versions/$(FWVERSION)/Resources $(MRFWDIR)/Versions/$(FWVERSION)/Resources
/usr/bin/install_name_tool -change "@executable_path/../../../PLT_MrEd.framework/Versions/$(FWVERSION)/PLT_MrEd" "@FRAMEWORK_PREFIX@PLT_MrEd.framework/Versions/$(FWVERSION)/PLT_MrEd" "$(prefix)/MrEd@CGC_CAP_INSTALLED@.app/Contents/MacOS/MrEd@CGC_CAP_INSTALLED@" /usr/bin/install_name_tool -change "@executable_path/../../../PLT_MrEd.framework/Versions/$(FWVERSION)/PLT_MrEd" "@FRAMEWORK_PREFIX@PLT_MrEd.framework/Versions/$(FWVERSION)/PLT_MrEd" "$(prefix)/MrEd@CGC_CAP_INSTALLED@.app/Contents/MacOS/MrEd@CGC_CAP_INSTALLED@"
$(MZSCHEME) -cu "$(srcdir)/../mzscheme/collects-path.ss" "$(prefix)/MrEd@CGC_CAP_INSTALLED@.app/Contents/MacOS/MrEd@CGC_CAP_INSTALLED@" ../../../collects $(MZSCHEME) -cu "$(srcdir)/../mzscheme/collects-path.ss" "$(prefix)/MrEd@CGC_CAP_INSTALLED@.app/Contents/MacOS/MrEd@CGC_CAP_INSTALLED@" ../../../collects
/usr/bin/strip -S "$(prefix)/MrEd@CGC_CAP_INSTALLED@.app/Contents/MacOS/MrEd@CGC_CAP_INSTALLED@"
install-wx_mac-cgc-final: install-wx_mac-cgc-final:
ln -s Versions/$(FWVERSION)/PLT_MrEd $(MRFWDIR)/ ln -s Versions/$(FWVERSION)/PLT_MrEd $(MRFWDIR)/
@ -364,6 +365,7 @@ install-wx_mac-3m:
$(ICP) -r "PLT_MrEd.framework/Versions/$(FWVERSION)_3m/Resources" "$(MRFWDIR)/Versions/$(FWVERSION)_3m/Resources" $(ICP) -r "PLT_MrEd.framework/Versions/$(FWVERSION)_3m/Resources" "$(MRFWDIR)/Versions/$(FWVERSION)_3m/Resources"
/usr/bin/install_name_tool -change "@executable_path/../../../PLT_MrEd.framework/Versions/$(FWVERSION)_3m/PLT_MrEd" "@FRAMEWORK_PREFIX@PLT_MrEd.framework/Versions/$(FWVERSION)_3m/PLT_MrEd" "$(prefix)/MrEd@MMM_CAP_INSTALLED@.app/Contents/MacOS/MrEd@MMM_CAP_INSTALLED@" /usr/bin/install_name_tool -change "@executable_path/../../../PLT_MrEd.framework/Versions/$(FWVERSION)_3m/PLT_MrEd" "@FRAMEWORK_PREFIX@PLT_MrEd.framework/Versions/$(FWVERSION)_3m/PLT_MrEd" "$(prefix)/MrEd@MMM_CAP_INSTALLED@.app/Contents/MacOS/MrEd@MMM_CAP_INSTALLED@"
$(MZSCHEME) -cu "$(srcdir)/../mzscheme/collects-path.ss" "$(prefix)/MrEd@MMM_CAP_INSTALLED@.app/Contents/MacOS/MrEd@MMM_CAP_INSTALLED@" "../../../collects" $(MZSCHEME) -cu "$(srcdir)/../mzscheme/collects-path.ss" "$(prefix)/MrEd@MMM_CAP_INSTALLED@.app/Contents/MacOS/MrEd@MMM_CAP_INSTALLED@" "../../../collects"
/usr/bin/strip -S "$(prefix)/MrEd@MMM_CAP_INSTALLED@.app/Contents/MacOS/MrEd@MMM_CAP_INSTALLED@"
install-wx_mac-3m-final: install-wx_mac-3m-final:
ln -s Versions/$(FWVERSION)_3m/PLT_MrEd $(MRFWDIR)/ ln -s Versions/$(FWVERSION)_3m/PLT_MrEd $(MRFWDIR)/

3
src/mzscheme/Makefile.in
View File

@ -271,6 +271,7 @@ unix-install:
cd ..; rm -f "$(DESTDIR)$(bindir)/mzscheme@CGC_INSTALLED@" cd ..; rm -f "$(DESTDIR)$(bindir)/mzscheme@CGC_INSTALLED@"
cd ..; rm -f "$(DESTDIR)$(bindir)/mzscheme@MMM_INSTALLED@" cd ..; rm -f "$(DESTDIR)$(bindir)/mzscheme@MMM_INSTALLED@"
cd ..; cp mzscheme/starter "$(DESTDIR)$(libpltdir)/starter" cd ..; cp mzscheme/starter "$(DESTDIR)$(libpltdir)/starter"
cd ..; strip -S "$(DESTDIR)$(libpltdir)/starter"
cd ..; echo 'CC=@CC@' > "$(BUILDINFO)" cd ..; echo 'CC=@CC@' > "$(BUILDINFO)"
cd ..; echo 'CFLAGS=@CFLAGS@ @PREFLAGS@ @COMPFLAGS@' >> "$(BUILDINFO)" cd ..; echo 'CFLAGS=@CFLAGS@ @PREFLAGS@ @COMPFLAGS@' >> "$(BUILDINFO)"
cd ..; echo 'OPTIONS=@OPTIONS@' >> "$(BUILDINFO)" cd ..; echo 'OPTIONS=@OPTIONS@' >> "$(BUILDINFO)"
@ -316,6 +317,7 @@ osx-install-cgc:
mkdir -p "$(MZFWDIR)/Versions/$(FWVERSION)" mkdir -p "$(MZFWDIR)/Versions/$(FWVERSION)"
cp $(MZFW) $(MZFWDIR)/Versions/$(FWVERSION)/ cp $(MZFW) $(MZFWDIR)/Versions/$(FWVERSION)/
/usr/bin/install_name_tool -change "@executable_path/PLT_MzScheme.framework/Versions/$(FWVERSION)/PLT_MzScheme" "@FRAMEWORK_PREFIX@PLT_MzScheme.framework/Versions/$(FWVERSION)/PLT_MzScheme" "$(bindir)/mzscheme@CGC_INSTALLED@" /usr/bin/install_name_tool -change "@executable_path/PLT_MzScheme.framework/Versions/$(FWVERSION)/PLT_MzScheme" "@FRAMEWORK_PREFIX@PLT_MzScheme.framework/Versions/$(FWVERSION)/PLT_MzScheme" "$(bindir)/mzscheme@CGC_INSTALLED@"
/usr/bin/strip -S "$(bindir)/mzscheme@CGC_INSTALLED@"
osx-install-cgc-final: osx-install-cgc-final:
$(MAKE) unix-install-cgc-final $(MAKE) unix-install-cgc-final
@ -326,6 +328,7 @@ osx-install-3m:
mkdir -p "$(MZFWDIR)/Versions/$(FWVERSION)_3m" mkdir -p "$(MZFWDIR)/Versions/$(FWVERSION)_3m"
cp $(MZFWMMM) $(MZFWDIR)/Versions/$(FWVERSION)_3m/ cp $(MZFWMMM) $(MZFWDIR)/Versions/$(FWVERSION)_3m/
/usr/bin/install_name_tool -change "@executable_path/PLT_MzScheme.framework/Versions/$(FWVERSION)_3m/PLT_MzScheme" "@FRAMEWORK_PREFIX@PLT_MzScheme.framework/Versions/$(FWVERSION)_3m/PLT_MzScheme" "$(bindir)/mzscheme@MMM_INSTALLED@" /usr/bin/install_name_tool -change "@executable_path/PLT_MzScheme.framework/Versions/$(FWVERSION)_3m/PLT_MzScheme" "@FRAMEWORK_PREFIX@PLT_MzScheme.framework/Versions/$(FWVERSION)_3m/PLT_MzScheme" "$(bindir)/mzscheme@MMM_INSTALLED@"
/usr/bin/strip -S "$(bindir)/mzscheme@MMM_INSTALLED@"
osx-install-3m-final: osx-install-3m-final:
$(MAKE) unix-install-3m-final $(MAKE) unix-install-3m-final

2
src/mzscheme/gc2/Makefile.in
View File

@ -312,7 +312,7 @@ main.@LTO@: $(XSRCDIR)/main.c
$(CC) $(CFLAGS) -c $(XSRCDIR)/main.c -o main.@LTO@ $(CC) $(CFLAGS) -c $(XSRCDIR)/main.c -o main.@LTO@
gc2.@LTO@: $(srcdir)/gc2.c $(srcdir)/newgc.c $(srcdir)/gc2.h \ gc2.@LTO@: $(srcdir)/gc2.c $(srcdir)/newgc.c $(srcdir)/gc2.h \
$(srcdir)/newgc.h $(srcdir)/blame_the_child.c \ $(srcdir)/newgc.h $(srcdir)/mem_account.c \
$(srcdir)/sighand.c \ $(srcdir)/sighand.c \
$(srcdir)/vm_osx.c $(srcdir)/vm_mmap.c $(srcdir)/vm_osk.c $(srcdir)/vm.c\ $(srcdir)/vm_osx.c $(srcdir)/vm_mmap.c $(srcdir)/vm_osk.c $(srcdir)/vm.c\
$(srcdir)/vm_memalign.c $(srcdir)/alloc_cache.c \ $(srcdir)/vm_memalign.c $(srcdir)/alloc_cache.c \

7
src/mzscheme/gc2/gc2.h
View File

@ -371,6 +371,13 @@ GC2_EXTERN void GC_fixup_variable_stack(void **var_stack,
The `stack_mem' argument indicates the start of the allocated memory The `stack_mem' argument indicates the start of the allocated memory
that contains `var_stack'. It is used for backtraces. */ that contains `var_stack'. It is used for backtraces. */
GC2_EXTERN int GC_merely_accounting();
/*
Can be called by a mark or fixup traversal proc to determine whether
the traversal is merely for accounting, in which case some marking
can be skipped if the corresponding data should be charged to a
different object. */
GC2_EXTERN void GC_write_barrier(void *p); GC2_EXTERN void GC_write_barrier(void *p);
/* /*
Explicit write barrier to ensure that a write-barrier signal is not Explicit write barrier to ensure that a write-barrier signal is not

15
src/mzscheme/gc2/blame_the_child.c → src/mzscheme/gc2/mem_account.c
View File

@ -1,11 +1,11 @@
/*****************************************************************************/ /*****************************************************************************/
/* blame-the-child accounting */ /* memory accounting */
/*****************************************************************************/ /*****************************************************************************/
#ifdef NEWGC_BTC_ACCOUNT #ifdef NEWGC_BTC_ACCOUNT
#include "../src/schpriv.h" #include "../src/schpriv.h"
/* BTC_ prefixed functions are called by newgc.c */ /* BTC_ prefixed functions are called by newgc.c */
/* btc_ prefixed functions are internal to blame_the_child.c */ /* btc_ prefixed functions are internal to mem_account.c */
static const int btc_redirect_thread = 511; static const int btc_redirect_thread = 511;
static const int btc_redirect_custodian = 510; static const int btc_redirect_custodian = 510;
@ -430,13 +430,12 @@ static void BTC_do_accounting(NewGC *gc)
if(owner_table[i]) if(owner_table[i])
owner_table[i]->memory_use = 0; owner_table[i]->memory_use = 0;
/* the end of the custodian list is where we want to start */ /* start with root: */
while(SCHEME_PTR1_VAL(box)) { while (cur->parent && SCHEME_PTR1_VAL(cur->parent)) {
cur = (Scheme_Custodian*)SCHEME_PTR1_VAL(box); cur = SCHEME_PTR1_VAL(cur->parent);
box = cur->global_next;
} }
/* walk backwards for the order we want */ /* walk forward for the order we want (blame parents instead of children) */
while(cur) { while(cur) {
int owner = custodian_to_owner_set(gc, cur); int owner = custodian_to_owner_set(gc, cur);
@ -448,7 +447,7 @@ static void BTC_do_accounting(NewGC *gc)
GCDEBUG((DEBUGOUTF, "Propagating accounting marks\n")); GCDEBUG((DEBUGOUTF, "Propagating accounting marks\n"));
propagate_accounting_marks(gc); propagate_accounting_marks(gc);
box = cur->global_prev; cur = box ? SCHEME_PTR1_VAL(box) : NULL; box = cur->global_next; cur = box ? SCHEME_PTR1_VAL(box) : NULL;
} }
gc->in_unsafe_allocation_mode = 0; gc->in_unsafe_allocation_mode = 0;

12
src/mzscheme/gc2/newgc.c
View File

@ -93,7 +93,7 @@ inline static int is_master_gc(NewGC *gc) {
/* particular collector you want. */ /* particular collector you want. */
/*****************************************************************************/ /*****************************************************************************/
/* This turns on blame-the-child automatic memory accounting */ /* This turns on automatic memory accounting */
/* #define NEWGC_BTC_ACCOUNT */ /* #define NEWGC_BTC_ACCOUNT */
/* #undef NEWGC_BTC_ACCOUNT */ /* #undef NEWGC_BTC_ACCOUNT */
@ -1365,11 +1365,11 @@ inline static void reset_pointer_stack(void)
} }
/*****************************************************************************/ /*****************************************************************************/
/* BLAME THE CHILD */ /* MEMORY ACCOUNTING */
/*****************************************************************************/ /*****************************************************************************/
#ifdef NEWGC_BTC_ACCOUNT #ifdef NEWGC_BTC_ACCOUNT
# include "blame_the_child.c" # include "mem_account.c"
#else #else
# define clean_up_thread_list() /* */ # define clean_up_thread_list() /* */
#endif #endif
@ -1404,6 +1404,12 @@ void GC_register_new_thread(void *t, void *c)
#endif #endif
} }
int GC_merely_accounting()
{
NewGC *gc = GC_get_GC();
return gc->doing_memory_accounting;
}
/*****************************************************************************/ /*****************************************************************************/
/* administration / initialization */ /* administration / initialization */
/*****************************************************************************/ /*****************************************************************************/

38
src/mzscheme/src/mzmark.c
View File

@ -923,8 +923,10 @@ static int cont_proc_MARK(void *p) {
MARK_cjs(&c->cjs); MARK_cjs(&c->cjs);
MARK_stack_state(&c->ss); MARK_stack_state(&c->ss);
gcMARK(c->barrier_prompt); gcMARK(c->barrier_prompt);
gcMARK(c->runstack_start); if (!GC_merely_accounting()) {
gcMARK(c->runstack_saved); gcMARK(c->runstack_start);
gcMARK(c->runstack_saved);
}
gcMARK(c->prompt_id); gcMARK(c->prompt_id);
gcMARK(c->prompt_buf); gcMARK(c->prompt_buf);
@ -961,8 +963,10 @@ static int cont_proc_FIXUP(void *p) {
FIXUP_cjs(&c->cjs); FIXUP_cjs(&c->cjs);
FIXUP_stack_state(&c->ss); FIXUP_stack_state(&c->ss);
gcFIXUP(c->barrier_prompt); gcFIXUP(c->barrier_prompt);
gcFIXUP(c->runstack_start); if (!GC_merely_accounting()) {
gcFIXUP(c->runstack_saved); gcFIXUP(c->runstack_start);
gcFIXUP(c->runstack_saved);
}
gcFIXUP(c->prompt_id); gcFIXUP(c->prompt_id);
gcFIXUP(c->prompt_buf); gcFIXUP(c->prompt_buf);
@ -1600,12 +1604,16 @@ static int thread_val_MARK(void *p) {
gcMARK(pr->init_config); gcMARK(pr->init_config);
gcMARK(pr->init_break_cell); gcMARK(pr->init_break_cell);
{ if (!pr->runstack_owner
|| !GC_merely_accounting()
|| (*pr->runstack_owner == pr)) {
Scheme_Object **rs = pr->runstack_start; Scheme_Object **rs = pr->runstack_start;
gcMARK( pr->runstack_start); gcMARK( pr->runstack_start);
pr->runstack = pr->runstack_start + (pr->runstack - rs); if (pr->runstack != pr->runstack_start + (pr->runstack - rs))
pr->runstack = pr->runstack_start + (pr->runstack - rs);
gcMARK(pr->runstack_saved);
} }
gcMARK(pr->runstack_saved);
gcMARK(pr->runstack_owner); gcMARK(pr->runstack_owner);
gcMARK(pr->runstack_swapped); gcMARK(pr->runstack_swapped);
pr->spare_runstack = NULL; /* just in case */ pr->spare_runstack = NULL; /* just in case */
@ -1706,12 +1714,16 @@ static int thread_val_FIXUP(void *p) {
gcFIXUP(pr->init_config); gcFIXUP(pr->init_config);
gcFIXUP(pr->init_break_cell); gcFIXUP(pr->init_break_cell);
{ if (!pr->runstack_owner
|| !GC_merely_accounting()
|| (*pr->runstack_owner == pr)) {
Scheme_Object **rs = pr->runstack_start; Scheme_Object **rs = pr->runstack_start;
gcFIXUP_TYPED_NOW(Scheme_Object **, pr->runstack_start); gcFIXUP_TYPED_NOW(Scheme_Object **, pr->runstack_start);
pr->runstack = pr->runstack_start + (pr->runstack - rs); if (pr->runstack != pr->runstack_start + (pr->runstack - rs))
pr->runstack = pr->runstack_start + (pr->runstack - rs);
gcFIXUP(pr->runstack_saved);
} }
gcFIXUP(pr->runstack_saved);
gcFIXUP(pr->runstack_owner); gcFIXUP(pr->runstack_owner);
gcFIXUP(pr->runstack_swapped); gcFIXUP(pr->runstack_swapped);
pr->spare_runstack = NULL; /* just in case */ pr->spare_runstack = NULL; /* just in case */
@ -1858,7 +1870,8 @@ static int prompt_val_SIZE(void *p) {
static int prompt_val_MARK(void *p) { static int prompt_val_MARK(void *p) {
Scheme_Prompt *pr = (Scheme_Prompt *)p; Scheme_Prompt *pr = (Scheme_Prompt *)p;
gcMARK(pr->boundary_overflow_id); gcMARK(pr->boundary_overflow_id);
gcMARK(pr->runstack_boundary_start); if (!GC_merely_accounting())
gcMARK(pr->runstack_boundary_start);
gcMARK(pr->tag); gcMARK(pr->tag);
gcMARK(pr->id); gcMARK(pr->id);
return return
@ -1868,7 +1881,8 @@ static int prompt_val_MARK(void *p) {
static int prompt_val_FIXUP(void *p) { static int prompt_val_FIXUP(void *p) {
Scheme_Prompt *pr = (Scheme_Prompt *)p; Scheme_Prompt *pr = (Scheme_Prompt *)p;
gcFIXUP(pr->boundary_overflow_id); gcFIXUP(pr->boundary_overflow_id);
gcFIXUP(pr->runstack_boundary_start); if (!GC_merely_accounting())
gcFIXUP(pr->runstack_boundary_start);
gcFIXUP(pr->tag); gcFIXUP(pr->tag);
gcFIXUP(pr->id); gcFIXUP(pr->id);
return return

19
src/mzscheme/src/mzmarksrc.c
View File

@ -355,8 +355,10 @@ cont_proc {
MARK_cjs(&c->cjs); MARK_cjs(&c->cjs);
MARK_stack_state(&c->ss); MARK_stack_state(&c->ss);
gcMARK(c->barrier_prompt); gcMARK(c->barrier_prompt);
gcMARK(c->runstack_start); if (!GC_merely_accounting()) {
gcMARK(c->runstack_saved); gcMARK(c->runstack_start);
gcMARK(c->runstack_saved);
}
gcMARK(c->prompt_id); gcMARK(c->prompt_id);
gcMARK(c->prompt_buf); gcMARK(c->prompt_buf);
@ -615,12 +617,16 @@ thread_val {
gcMARK(pr->init_config); gcMARK(pr->init_config);
gcMARK(pr->init_break_cell); gcMARK(pr->init_break_cell);
{ if (!pr->runstack_owner
|| !GC_merely_accounting()
|| (*pr->runstack_owner == pr)) {
Scheme_Object **rs = pr->runstack_start; Scheme_Object **rs = pr->runstack_start;
gcFIXUP_TYPED_NOW(Scheme_Object **, pr->runstack_start); gcFIXUP_TYPED_NOW(Scheme_Object **, pr->runstack_start);
pr->runstack = pr->runstack_start + (pr->runstack - rs); if (pr->runstack != pr->runstack_start + (pr->runstack - rs))
pr->runstack = pr->runstack_start + (pr->runstack - rs);
gcMARK(pr->runstack_saved);
} }
gcMARK(pr->runstack_saved);
gcMARK(pr->runstack_owner); gcMARK(pr->runstack_owner);
gcMARK(pr->runstack_swapped); gcMARK(pr->runstack_swapped);
pr->spare_runstack = NULL; /* just in case */ pr->spare_runstack = NULL; /* just in case */
@ -738,7 +744,8 @@ prompt_val {
mark: mark:
Scheme_Prompt *pr = (Scheme_Prompt *)p; Scheme_Prompt *pr = (Scheme_Prompt *)p;
gcMARK(pr->boundary_overflow_id); gcMARK(pr->boundary_overflow_id);
gcMARK(pr->runstack_boundary_start); if (!GC_merely_accounting())
gcMARK(pr->runstack_boundary_start);
gcMARK(pr->tag); gcMARK(pr->tag);
gcMARK(pr->id); gcMARK(pr->id);
size: size:

18
src/mzscheme/src/salloc.c
View File

@ -1509,6 +1509,7 @@ static void print_tagged_value(const char *prefix,
void *v, int xtagged, unsigned long diff, int max_w, void *v, int xtagged, unsigned long diff, int max_w,
const char *suffix) const char *suffix)
{ {
char buffer[256];
char *type, *sep, diffstr[30]; char *type, *sep, diffstr[30];
long len; long len;
@ -1520,7 +1521,6 @@ static void print_tagged_value(const char *prefix,
type = scheme_write_to_string_w_max((Scheme_Object *)v, &len, max_w); type = scheme_write_to_string_w_max((Scheme_Object *)v, &len, max_w);
if (!scheme_strncmp(type, "#<thread", 8) if (!scheme_strncmp(type, "#<thread", 8)
&& ((type[8] == '>') || (type[8] == ':'))) { && ((type[8] == '>') || (type[8] == ':'))) {
char buffer[256];
char *run, *sus, *kill, *clean, *deq, *all, *t2; char *run, *sus, *kill, *clean, *deq, *all, *t2;
int state = ((Scheme_Thread *)v)->running, len2; int state = ((Scheme_Thread *)v)->running, len2;
@ -1541,7 +1541,6 @@ static void print_tagged_value(const char *prefix,
len += len2; len += len2;
type = t2; type = t2;
} else if (!scheme_strncmp(type, "#<continuation>", 15)) { } else if (!scheme_strncmp(type, "#<continuation>", 15)) {
char buffer[256];
char *t2; char *t2;
int len2; int len2;
@ -1555,6 +1554,19 @@ static void print_tagged_value(const char *prefix,
: "<anonymous>") : "<anonymous>")
: "NULL")); : "NULL"));
len2 = strlen(buffer);
t2 = (char *)scheme_malloc_atomic(len + len2 + 1);
memcpy(t2, type, len);
memcpy(t2 + len, buffer, len2 + 1);
len += len2;
type = t2;
} else if (!scheme_strncmp(type, "#<custodian>", 13)) {
char *t2;
int len2;
sprintf(buffer, "[%d]",
((Scheme_Custodian *)v)->elems);
len2 = strlen(buffer); len2 = strlen(buffer);
t2 = (char *)scheme_malloc_atomic(len + len2 + 1); t2 = (char *)scheme_malloc_atomic(len + len2 + 1);
memcpy(t2, type, len); memcpy(t2, type, len);
@ -1562,7 +1574,6 @@ static void print_tagged_value(const char *prefix,
len += len2; len += len2;
type = t2; type = t2;
} else if (!scheme_strncmp(type, "#<namespace", 11)) { } else if (!scheme_strncmp(type, "#<namespace", 11)) {
char buffer[256];
char *t2; char *t2;
int len2; int len2;
@ -1596,7 +1607,6 @@ static void print_tagged_value(const char *prefix,
type = t2; type = t2;
} else if (!scheme_strncmp(type, "#<hash-table>", 13) } else if (!scheme_strncmp(type, "#<hash-table>", 13)
|| !scheme_strncmp(type, "#<hash-table:", 13)) { || !scheme_strncmp(type, "#<hash-table:", 13)) {
char buffer[256];
char *t2; char *t2;
int len2; int len2;
int htype, size, count; int htype, size, count;

4
src/mzscheme/src/schpriv.h
View File

@ -424,8 +424,8 @@ extern int scheme_overflow_count;
struct Scheme_Custodian { struct Scheme_Custodian {
Scheme_Object so; Scheme_Object so;
char shut_down, has_limit; char shut_down, has_limit, recorded;
int count, alloc; int count, alloc, elems;
Scheme_Object ***boxes; Scheme_Object ***boxes;
Scheme_Custodian_Reference **mrefs; Scheme_Custodian_Reference **mrefs;
Scheme_Close_Custodian_Client **closers; Scheme_Close_Custodian_Client **closers;

46
src/mzscheme/src/thread.c
View File

@ -900,6 +900,28 @@ static Scheme_Object *current_memory_use(int argc, Scheme_Object *args[])
/* custodians */ /* custodians */
/*========================================================================*/ /*========================================================================*/
static void adjust_limit_table(Scheme_Custodian *c)
{
/* If a custodian has a limit and any object or children, then it
must not be collected and merged with its parent. To prevent
collection, we register the custodian in the `limite_custodians'
table. */
if (c->has_limit) {
if (c->elems || CUSTODIAN_FAM(c->children)) {
if (!c->recorded) {
c->recorded = 1;
if (!limited_custodians)
limited_custodians = scheme_make_hash_table(SCHEME_hash_ptr);
scheme_hash_set(limited_custodians, (Scheme_Object *)c, scheme_true);
}
} else if (c->recorded) {
c->recorded = 0;
if (limited_custodians)
scheme_hash_set(limited_custodians, (Scheme_Object *)c, NULL);
}
}
}
static Scheme_Object *custodian_require_mem(int argc, Scheme_Object *args[]) static Scheme_Object *custodian_require_mem(int argc, Scheme_Object *args[])
{ {
long lim; long lim;
@ -975,13 +997,11 @@ static Scheme_Object *custodian_limit_mem(int argc, Scheme_Object *args[])
} }
} }
if (!limited_custodians)
limited_custodians = scheme_make_hash_table(SCHEME_hash_ptr);
scheme_hash_set(limited_custodians, args[0], scheme_true);
((Scheme_Custodian *)args[0])->has_limit = 1; ((Scheme_Custodian *)args[0])->has_limit = 1;
adjust_limit_table((Scheme_Custodian *)args[0]);
if (argc > 2) { if (argc > 2) {
scheme_hash_set(limited_custodians, args[2], scheme_true);
((Scheme_Custodian *)args[2])->has_limit = 1; ((Scheme_Custodian *)args[2])->has_limit = 1;
adjust_limit_table((Scheme_Custodian *)args[2]);
} }
#ifdef NEWGC_BTC_ACCOUNT #ifdef NEWGC_BTC_ACCOUNT
@ -1075,6 +1095,9 @@ static void add_managed_box(Scheme_Custodian *m,
m->data[i] = data; m->data[i] = data;
m->mrefs[i] = mref; m->mrefs[i] = mref;
m->elems++;
adjust_limit_table(m);
return; return;
} }
} }
@ -1086,6 +1109,9 @@ static void add_managed_box(Scheme_Custodian *m,
m->data[m->count] = data; m->data[m->count] = data;
m->mrefs[m->count] = mref; m->mrefs[m->count] = mref;
m->elems++;
adjust_limit_table(m);
m->count++; m->count++;
} }
@ -1112,6 +1138,8 @@ static void remove_managed(Scheme_Custodian_Reference *mr, Scheme_Object *o,
if (old_data) if (old_data)
*old_data = m->data[i]; *old_data = m->data[i];
m->data[i] = NULL; m->data[i] = NULL;
--m->elems;
adjust_limit_table(m);
break; break;
} }
} }
@ -1164,6 +1192,8 @@ static void adjust_custodian_family(void *mgr, void *skip_move)
m = next; m = next;
} }
adjust_limit_table(parent);
/* Add remaining managed items to parent: */ /* Add remaining managed items to parent: */
if (!skip_move) { if (!skip_move) {
for (i = 0; i < r->count; i++) { for (i = 0; i < r->count; i++) {
@ -1221,6 +1251,9 @@ void insert_custodian(Scheme_Custodian *m, Scheme_Custodian *parent)
CUSTODIAN_FAM(m->global_next) = NULL; CUSTODIAN_FAM(m->global_next) = NULL;
CUSTODIAN_FAM(m->global_prev) = NULL; CUSTODIAN_FAM(m->global_prev) = NULL;
} }
if (parent)
adjust_limit_table(parent);
} }
Scheme_Custodian *scheme_make_custodian(Scheme_Custodian *parent) Scheme_Custodian *scheme_make_custodian(Scheme_Custodian *parent)
@ -1483,6 +1516,7 @@ Scheme_Thread *scheme_do_close_managed(Scheme_Custodian *m, Scheme_Exit_Closer_F
m->count = 0; m->count = 0;
m->alloc = 0; m->alloc = 0;
m->elems = 0;
m->boxes = NULL; m->boxes = NULL;
m->closers = NULL; m->closers = NULL;
m->data = NULL; m->data = NULL;
@ -1496,9 +1530,7 @@ Scheme_Thread *scheme_do_close_managed(Scheme_Custodian *m, Scheme_Exit_Closer_F
/* Remove this custodian from its parent */ /* Remove this custodian from its parent */
adjust_custodian_family(m, m); adjust_custodian_family(m, m);
if (m->has_limit) { adjust_limit_table(m);
scheme_hash_set(limited_custodians, (Scheme_Object *)m, NULL);
}
m = next_m; m = next_m;
} }

2
src/wxxt/contrib/xpm/lib/CrBufFrI.c
View File

@ -36,7 +36,7 @@
\*****************************************************************************/ \*****************************************************************************/
#include "xpmP.h" #include "xpmP.h"
#if defined(SYSV) || defined(SVR4) || defined(VMS) #if defined(SYSV) || defined(SVR4) || defined(VMS) || defined(__GNUC__)
#include <string.h> #include <string.h>
#else #else
#include <strings.h> #include <strings.h>

2
src/wxxt/contrib/xpm/lib/CrDatFrI.c
View File

@ -33,7 +33,7 @@
\*****************************************************************************/ \*****************************************************************************/
#include "xpmP.h" #include "xpmP.h"
#if defined(SYSV) || defined(SVR4) || defined(VMS) #if defined(SYSV) || defined(SVR4) || defined(VMS) || defined(__GNUC__)
#include <string.h> #include <string.h>
#else #else
#include <strings.h> #include <strings.h>

5
src/wxxt/contrib/xpm/lib/WrFFrBuf.c
View File

@ -33,6 +33,11 @@
\*****************************************************************************/ \*****************************************************************************/
#include "xpmP.h" #include "xpmP.h"
#if defined(SYSV) || defined(SVR4) || defined(VMS) || defined(__GNUC__)
#include <string.h>
#else
#include <strings.h>
#endif
int int
XpmWriteFileFromBuffer(filename, buffer) XpmWriteFileFromBuffer(filename, buffer)

5
src/wxxt/contrib/xpm/lib/WrFFrI.c
View File

@ -33,6 +33,11 @@
\*****************************************************************************/ \*****************************************************************************/
#include "xpmP.h" #include "xpmP.h"
#if defined(SYSV) || defined(SVR4) || defined(VMS) || defined(__GNUC__)
#include <string.h>
#else
#include <strings.h>
#endif
LFUNC(WriteFile, int, (FILE *file, XpmImage *image, char *name, LFUNC(WriteFile, int, (FILE *file, XpmImage *image, char *name,
XpmInfo *info)); XpmInfo *info));

5
src/wxxt/contrib/xpm/lib/create.c
View File

@ -40,6 +40,11 @@
#include "xpmP.h" #include "xpmP.h"
#include <ctype.h> #include <ctype.h>
#if defined(SYSV) || defined(SVR4) || defined(VMS) || defined(__GNUC__)
#include <string.h>
#else
#include <strings.h>
#endif
LFUNC(xpmVisualType, int, (Visual *visual)); LFUNC(xpmVisualType, int, (Visual *visual));

5
src/wxxt/contrib/xpm/lib/data.c
View File

@ -39,6 +39,11 @@ static char *RCS_Version = "$XpmVersion: 3.4g $";
#include "xpmP.h" #include "xpmP.h"
#include <ctype.h> #include <ctype.h>
#if defined(SYSV) || defined(SVR4) || defined(VMS) || defined(__GNUC__)
#include <string.h>
#else
#include <strings.h>
#endif
LFUNC(ParseComment, int, (xpmData * mdata)); LFUNC(ParseComment, int, (xpmData * mdata));

5
src/wxxt/contrib/xpm/lib/hashtab.c
View File

@ -34,6 +34,11 @@
\*****************************************************************************/ \*****************************************************************************/
#include "xpmP.h" #include "xpmP.h"
#if defined(SYSV) || defined(SVR4) || defined(VMS) || defined(__GNUC__)
#include <string.h>
#else
#include <strings.h>
#endif
LFUNC(AtomMake, xpmHashAtom, (char *name, void *data)); LFUNC(AtomMake, xpmHashAtom, (char *name, void *data));
LFUNC(HashTableGrows, int, (xpmHashTable * table)); LFUNC(HashTableGrows, int, (xpmHashTable * table));

5
src/wxxt/contrib/xpm/lib/parse.c
View File

@ -40,6 +40,11 @@
#include "xpmP.h" #include "xpmP.h"
#include <ctype.h> #include <ctype.h>
#if defined(SYSV) || defined(SVR4) || defined(VMS) || defined(__GNUC__)
#include <string.h>
#else
#include <strings.h>
#endif
LFUNC(ParseValues, int, (xpmData *data, unsigned int *width, LFUNC(ParseValues, int, (xpmData *data, unsigned int *width,
unsigned int *height, unsigned int *ncolors, unsigned int *height, unsigned int *ncolors,

2
src/wxxt/contrib/xpm/lib/rgb.c
View File

@ -44,7 +44,7 @@
#include "xpmP.h" #include "xpmP.h"
#include <ctype.h> #include <ctype.h>
#if defined(SYSV) || defined(SVR4) || defined(VMS) #if defined(SYSV) || defined(SVR4) || defined(VMS) || defined(__GNUC__)
#include <string.h> #include <string.h>
#else #else
#include <strings.h> #include <strings.h>

6
src/wxxt/src/DeviceContexts/WindowDC.cc
View File

@ -2867,6 +2867,10 @@ void wxWindowDC::Initialize(wxWindowDC_Xinit* init)
void wxWindowDC::Destroy(void) void wxWindowDC::Destroy(void)
{ {
#ifdef WX_USE_CAIRO
ReleaseCairoDev();
#endif
if (PEN_GC) XFreeGC(DPY, PEN_GC); if (PEN_GC) XFreeGC(DPY, PEN_GC);
if (BRUSH_GC) XFreeGC(DPY, BRUSH_GC); if (BRUSH_GC) XFreeGC(DPY, BRUSH_GC);
if (TEXT_GC) XFreeGC(DPY, TEXT_GC); if (TEXT_GC) XFreeGC(DPY, TEXT_GC);
@ -3726,7 +3730,7 @@ void wxWindowDC::InitCairoDev()
void wxWindowDC::ReleaseCairoDev() void wxWindowDC::ReleaseCairoDev()
{ {
if (X->cairo_dev) { if (X->cairo_dev) {
cairo_destroy(CAIRO_DEV); cairo_destroy_it(CAIRO_DEV);
X->cairo_dev = 0; X->cairo_dev = 0;
} }
} }

2
src/wxxt/src/wx_cairo.h
View File

@ -24,6 +24,7 @@ typedef cairo_matrix_t cairo_matrix_p;
# define cairo_default_matrix(dev) cairo_identity_matrix(dev) # define cairo_default_matrix(dev) cairo_identity_matrix(dev)
# undef cairo_init_clip # undef cairo_init_clip
# define cairo_init_clip(dev) cairo_reset_clip(dev) # define cairo_init_clip(dev) cairo_reset_clip(dev)
# define cairo_destroy_it(c) (cairo_surface_destroy(cairo_get_target(c)), cairo_destroy(c))
# else # else
/* Old Cairo API (0.5 and up) */ /* Old Cairo API (0.5 and up) */
typedef cairo_matrix_t *cairo_matrix_p; typedef cairo_matrix_t *cairo_matrix_p;
@ -31,5 +32,6 @@ typedef cairo_matrix_t *cairo_matrix_p;
# define cairo__set_matrix(CAIRO_DEV, m) cairo_set_matrix(CAIRO_DEV, m) # define cairo__set_matrix(CAIRO_DEV, m) cairo_set_matrix(CAIRO_DEV, m)
# define cairo_set_create_xlib(dev, display, drawable, vis, w, h) \ # define cairo_set_create_xlib(dev, display, drawable, vis, w, h) \
dev = cairo_create(); cairo_set_target_drawable(dev, wxAPP_DISPLAY, DRAWABLE) dev = cairo_create(); cairo_set_target_drawable(dev, wxAPP_DISPLAY, DRAWABLE)
# define cairo_destroy_it(c) cairo_destroy(c)
# endif # endif
#endif #endif