diff --git a/collects/drscheme/private/main.ss b/collects/drscheme/private/main.ss index f42f04ab56..55ca8ff9d6 100644 --- a/collects/drscheme/private/main.ss +++ b/collects/drscheme/private/main.ss @@ -94,10 +94,10 @@ (number? (car 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) (integer? x) - (x . >= . (* 1024 1024 100))))) + (x . >= . (* 1024 1024 1))))) (preferences:set-default 'drscheme:recent-language-names null diff --git a/collects/drscheme/private/rep.ss b/collects/drscheme/private/rep.ss index 08442e7a83..8b15e0b73b 100644 --- a/collects/drscheme/private/rep.ss +++ b/collects/drscheme/private/rep.ss @@ -867,7 +867,7 @@ TODO (memory-killed-thread #f) (user-custodian #f) (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-namespace-box (make-weak-box #f)) (user-eventspace-main-thread #f) @@ -925,7 +925,7 @@ TODO (field (need-interaction-cleanup? #f)) (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 (string-constant evaluation-terminated) (string-append @@ -953,7 +953,7 @@ TODO )]) (when (equal? ans 3) (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)) (insert-warning "\nInteractions disabled"))) diff --git a/collects/drscheme/private/unit.ss b/collects/drscheme/private/unit.ss index b523730f1f..9e943f22bf 100644 --- a/collects/drscheme/private/unit.ss +++ b/collects/drscheme/private/unit.ss @@ -3292,10 +3292,10 @@ module browser threading seems wrong. (when num (cond [(eq? num #t) - (preferences:set 'drscheme:memory-limit #f) + (preferences:set 'drscheme:child-only-memory-limit #f) (send interactions-text set-custodian-limit #f)] [else - (preferences:set 'drscheme:memory-limit + (preferences:set 'drscheme:child-only-memory-limit (* 1024 1024 num)) (send interactions-text set-custodian-limit (* 1024 1024 num))]))))])) @@ -3844,7 +3844,7 @@ module browser threading seems wrong. [parent hp] [init-value (if current-limit (format "~a" current-limit) - "128")] + "64")] [stretchable-width #f] [min-width 100] [callback @@ -3886,7 +3886,7 @@ module browser threading seems wrong. (let* ([n (string->number (send txt get-text))]) (and n (integer? n) - (100 . <= . n)))) + (1 . <= . n)))) (define (background sd) (let ([txt (send tb get-editor)]) diff --git a/collects/html/html.scrbl b/collects/html/html.scrbl index 22f81481ce..9b7564591b 100644 --- a/collects/html/html.scrbl +++ b/collects/html/html.scrbl @@ -4,8 +4,9 @@ (for-label html) (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 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?]) (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?]).} +@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[""] + element may only contain a @scheme[""] and @scheme[""] + element. Defaults to @scheme[#f]. +} @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[ (module html-example scheme diff --git a/collects/mzlib/foreign.ss b/collects/mzlib/foreign.ss index 8c7ccf7610..8737faa41c 100644 --- a/collects/mzlib/foreign.ss +++ b/collects/mzlib/foreign.ss @@ -1500,7 +1500,7 @@ ;; Used by set-ffi-obj! to get the actual value so it can be kept around (define (get-lowlevel-object x type) (let ([basetype (ctype-basetype type)]) - (if basetype + (if (ctype? basetype) (let ([s->c (ctype-scheme->c type)]) (get-lowlevel-object (if s->c (s->c x) x) basetype)) (values x type)))) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 642f4a8d72..12fc3fd4b8 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "14dec2008") +#lang scheme/base (provide stamp) (define stamp "18dec2008") diff --git a/collects/scheme/sandbox.ss b/collects/scheme/sandbox.ss index 4091527e49..32039f1e3f 100644 --- a/collects/scheme/sandbox.ss +++ b/collects/scheme/sandbox.ss @@ -25,10 +25,13 @@ sandbox-make-logger sandbox-memory-limit sandbox-eval-limits + sandbox-eval-handlers + call-with-trusted-sandbox-configuration evaluator-alive? kill-evaluator break-evaluator set-eval-limits + set-eval-handler put-input get-output get-error-output @@ -39,6 +42,8 @@ call-in-nested-thread* call-with-limits with-limits + call-with-custodian-shutdown + call-with-killing-threads exn:fail:sandbox-terminated? exn:fail:sandbox-terminated-reason exn:fail:resource? @@ -58,11 +63,23 @@ (define sandbox-output (make-parameter #f)) (define sandbox-error-output (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-propagate-breaks (make-parameter #t)) (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 (make-parameter `(,(mz/mr make-base-namespace make-gui-namespace) #| no modules here by default |#))) @@ -94,9 +111,14 @@ [(string? path) (string->path 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) - (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 ;; matches also subdirs (if it's a directory) @@ -117,6 +139,29 @@ (map (lambda (perm) (list (car perm) (path->bregexp (cadr perm)))) 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 (make-parameter (lambda (what . xs) (error what "network access denied: ~e" xs)))) @@ -127,16 +172,17 @@ orig-security (lambda (what path modes) (when path - (let ([needed (car (or (for/or ([p (in-list permission-order)]) - (memq p modes)) - (error 'default-sandbox-guard - "unknown access modes: ~e" modes)))] - [bpath (parameterize ([current-security-guard orig-security]) - (path->bytes (simplify-path* path)))]) - (unless (ormap (lambda (perm) - (and (perm<=? needed (car perm)) - (regexp-match (cadr perm) bpath))) - (sandbox-path-permissions)) + (let ([spath (parameterize ([current-security-guard orig-security]) + (simplify-path* path))] + [maxperm + ;; assumes that the modes are valid (ie, in the above list) + (cond [(null? modes) (error 'default-sandbox-guard + "got empty mode list for ~e and ~e" + what path)] + [(null? (cdr modes)) (car modes)] ; common case + [else (foldl (lambda (x max) (if (perm<=? max x) x max)) + (car modes) (cdr modes))])]) + (unless (check-sandbox-path-permissions spath maxperm) (error what "`~a' access denied for ~a" (string-append* (add-between (map symbol->string modes) "+")) path))))) @@ -168,8 +214,8 @@ (append (map (lambda (p) `(read ,(path->bytes p))) paths) (module-specs->path-permissions require-perms)))) -;; computes permissions that are needed for require specs (`read' for all -;; files and "compiled" subdirs, `exists' for the base-dir) +;; computes permissions that are needed for require specs (`read-bytecode' for +;; all files and "compiled" subdirs, `exists' for the base-dir) (define (module-specs->path-permissions mods) (define paths (module-specs->non-lib-paths mods)) (define bases @@ -180,8 +226,8 @@ (let ([base (simplify-path* base)]) (loop (cdr paths) (if (member base bases) bases (cons base bases)))))))) - (append (map (lambda (p) `(read ,p)) paths) - (map (lambda (b) `(read ,(build-path b "compiled"))) bases) + (append (map (lambda (p) `(read-bytecode ,p)) paths) + (map (lambda (b) `(read-bytecode ,(build-path b "compiled"))) bases) (map (lambda (b) `(exists ,b)) bases))) ;; takes a module-spec list and returns all module paths that are needed @@ -273,7 +319,8 @@ (define-values (cust cust-box) (if (and mb memory-accounting?) (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 (current-custodian) #f))) (parameterize ([current-custodian cust]) @@ -282,7 +329,9 @@ ;; time limit (when sec (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))]) (call-with-values thunk (lambda vs (list* values vs)))))) ;; The thread might be killed by the timer thread, so don't let @@ -317,6 +366,28 @@ [(with-limits sec mb 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 ---------------------------------------------------------------- (define (literal-identifier=? x y) @@ -510,12 +581,14 @@ (define-evaluator-messenger kill-evaluator 'kill) (define-evaluator-messenger break-evaluator 'break) (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 get-output 'output) (define-evaluator-messenger get-error-output 'error-output) (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 (make-terminated reason) @@ -526,6 +599,7 @@ (define (make-evaluator* init-hook allow program-maker) (define orig-code-inspector (current-code-inspector)) + (define orig-security-guard (current-security-guard)) (define orig-cust (current-custodian)) (define memory-cust (make-custodian orig-cust)) (define memory-cust-box (make-custodian-box memory-cust #t)) @@ -539,24 +613,33 @@ (define output #f) (define error-output #f) (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-done-evt #t) ; set in the same place (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) (unless terminated? (set! terminated? (make-terminated - (cond [(eq? reason #t) ; => guess - (if (custodian-box-value user-cust-box) - 'thread-killed - 'custodian-shutdown)] - [reason reason] ; => explicit - ;; otherwise it's an indication of an internal error - [else "internal error: no termination reason"]))))) - (define (limit-thunk thunk) - (let* ([sec (and limits (car limits))] - [mb (and limits (cadr limits))]) - (if (or sec mb) (lambda () (call-with-limits sec mb thunk)) thunk))) + (cond + ;; #f is used as an indication of an internal error, when we + ;; don't know why the sandbox is killed + [(not reason) "internal error: no termination reason"] + ;; explicit reason given + [(not (eq? reason #t)) reason] + ;; reason = #t => guess the reason + [(not (custodian-box-value memory-cust-box)) 'out-of-memory] + [(not (custodian-box-value user-cust-box)) 'custodian-shutdown] + [(thread-dead? user-thread) 'thread-killed] + [else "internal error: cannot guess termination reason"]))))) (define (user-kill) (when user-thread (let ([t user-thread]) @@ -565,6 +648,10 @@ (custodian-shutdown-all user-cust) (kill-thread t))) ; just in case (void)) + (define (terminate+kill! reason raise?) + (terminated! reason) + (user-kill) + (when raise? (raise terminated?))) (define (user-break) (when user-thread (break-thread user-thread))) (define (user-process) @@ -578,6 +665,7 @@ limit-thunk (and coverage? (lambda (es+get) (set! uncovered es+get)))) (channel-put result-ch 'ok)) + (set! eval-handler (cadr (sandbox-eval-handlers))) ; interactions handler ;; finally wait for interaction expressions (let ([n 0]) (let loop () @@ -587,36 +675,34 @@ (with-handlers ([void (lambda (exn) (channel-put result-ch (cons 'exn exn)))]) (define run - (limit-thunk (if (evaluator-message? expr) - (lambda () - (apply (evaluator-message-msg expr) - (evaluator-message-args expr))) - (lambda () + (if (evaluator-message? expr) + (case (evaluator-message-msg expr) + [(thunk) (limit-thunk (car (evaluator-message-args expr)))] + [(thunk*) (car (evaluator-message-args expr))] + [else (error 'sandbox "internal error (bad message)")]) + (limit-thunk (lambda () (set! n (add1 n)) (eval* (input->code (list expr) 'eval n)))))) (channel-put result-ch (cons 'vals (call-with-values run list)))) (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) ;; the thread will usually be running, but it might be killed outside of ;; the sandboxed environment, for example, if you do something like ;; (kill-thread (ev '(current-thread))) when there are no per-expression ;; limits (since then you get a different thread, which is already dead). (when (and user-thread (thread-dead? user-thread)) - (terminated! #t)) + (terminate+kill! #t #t)) (cond [terminated? => raise] [(not user-thread) (error 'sandbox "internal error (user-thread is #f)")] [else (channel-put input-ch expr) - (let ([r (let loop () - (with-handlers ([(if (sandbox-propagate-breaks) - 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?)] + (let ([r (get-user-result)]) + (cond [(eof-object? r) (terminate+kill! #t #t)] [(eq? (car r) 'exn) (raise (cdr r))] [else (apply values (cdr r))]))])) (define get-uncovered @@ -631,7 +717,7 @@ (filter (lambda (x) (equal? src (syntax-source x))) uncovered) uncovered))])) (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 (case-lambda [() (input-putter input)] @@ -645,16 +731,16 @@ (if (evaluator-message? expr) (let ([msg (evaluator-message-msg expr)]) (case msg - [(alive?) (and user-thread (not (thread-dead? user-thread)))] - [(kill) (terminated! 'evaluator-killed) (user-kill)] - [(break) (user-break)] - [(limits) (set! limits (evaluator-message-args expr))] - [(input) (apply input-putter (evaluator-message-args expr))] - [(output) (output-getter output)] + [(alive?) (and user-thread (not (thread-dead? user-thread)))] + [(kill) (terminate+kill! 'evaluator-killed #f)] + [(break) (user-break)] + [(limits) (set! limits (evaluator-message-args expr))] + [(handler) (set! eval-handler (car (evaluator-message-args expr)))] + [(input) (apply input-putter (evaluator-message-args expr))] + [(output) (output-getter output)] [(error-output) (output-getter error-output)] [(uncovered) (apply get-uncovered (evaluator-message-args expr))] - [(thunk) (user-eval (make-evaluator-message - (car (evaluator-message-args expr)) '()))] + [(thunk thunk*) (user-eval expr)] [else (error 'evaluator "internal error, bad message: ~e" msg)])) (user-eval expr))) (define (make-output what out set-out! allow-link?) @@ -679,7 +765,9 @@ ;; set global memory limit (when (and memory-accounting? (sandbox-memory-limit)) (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 (;; create a sandbox context first [current-custodian user-cust] @@ -707,33 +795,41 @@ (append (sandbox-override-collection-paths) (current-library-collection-paths)))] [sandbox-path-permissions - (append (map (lambda (p) `(read ,p)) - (current-library-collection-paths)) - (compute-permissions allow) - (sandbox-path-permissions))] + `(,@(map (lambda (p) `(read-bytecode ,p)) + (current-library-collection-paths)) + (exists ,(find-system-path 'addon-dir)) + ,@(compute-permissions allow) + ,@(sandbox-path-permissions))] ;; general info [current-command-line-arguments '#()] ;; restrict the sandbox context from this point [current-security-guard (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-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 - ;; byte-code is loaded, and avoiding using protected moduel bindings, like - ;; the foreign library's `unsafe!'. We don't need the first because we - ;; control it indirectly through the security guard, so this handler makes - ;; sure that byte-code is loaded using the original inspector. + ;; byte-code is loaded, and avoiding using protected module bindings, like + ;; the foreign library's `unsafe!'. We control the first through the path + ;; permissions -- using the 'read-bytecode permissionn level, so this + ;; handler just checks for that permission then goes on to load the file + ;; using the original inspector. [current-load/use-compiled (let ([handler (current-load/use-compiled)]) (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))))] + [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 ;; is an unused parameter. Also note that creating an eventspace ;; starts a thread that will eventually run the callback code (which @@ -742,10 +838,9 @@ ;; it will not use the new namespace. [current-eventspace (make-eventspace)]) (let ([t (bg-run->thread (run-in-bg user-process))]) - (set! user-done-evt - (handle-evt t (lambda (_) (terminated! #t) (user-kill) eof))) + (set! user-done-evt (handle-evt t (lambda (_) (terminate+kill! #t #t)))) (set! user-thread t)) - (let ([r (channel-get result-ch)]) + (let ([r (get-user-result)]) (if (eq? r 'ok) ;; initial program executed ok, so return an evaluator evaluator diff --git a/collects/scribble/eval.ss b/collects/scribble/eval.ss index 34c67f645c..bfac65d473 100644 --- a/collects/scribble/eval.ss +++ b/collects/scribble/eval.ss @@ -239,18 +239,16 @@ [else stx])) (define (make-base-eval) - (parameterize ([sandbox-security-guard (current-security-guard)] - [sandbox-output 'string] - [sandbox-error-output 'string] - [sandbox-eval-limits #f] - [sandbox-memory-limit #f] - [sandbox-make-inspector current-inspector]) - (make-evaluator '(begin (require scheme/base))))) + (call-with-trusted-sandbox-configuration + (lambda () + (parameterize ([sandbox-output 'string] + [sandbox-error-output 'string]) + (make-evaluator '(begin (require scheme/base))))))) (define (close-eval e) (kill-evaluator e) "") - + (define (do-plain-eval ev s catching-exns?) (call-with-values (lambda () ((scribble-eval-handler) diff --git a/collects/scribblings/foreign/types.scrbl b/collects/scribblings/foreign/types.scrbl index d9cdf24faf..aae66609a6 100644 --- a/collects/scribblings/foreign/types.scrbl +++ b/collects/scribblings/foreign/types.scrbl @@ -20,9 +20,11 @@ along with conversion functions to and from the existing types. [c-to-scheme (or/c #f (any/c . -> . any))]) ctype?]{ -Creates a new @tech{C type} value, with the given conversions -functions. The conversion functions can be @scheme[#f] meaning that -there is no conversion for the corresponding direction. If both +Creates a new @tech{C type} value whose representation for foreign +code is the same as @scheme[type]'s. The given conversions functions +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.} @@ -338,7 +340,7 @@ values: @itemize[ 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 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 useful if the box is held for a dynamic extent that corresponds to 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 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. 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 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[ (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 -`@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 its accessors and mutators, as well as any function that is defined to take an @cpp{A} pointer: diff --git a/collects/scribblings/foreign/unexported.scrbl b/collects/scribblings/foreign/unexported.scrbl index 10d2189c01..a4631b9343 100644 --- a/collects/scribblings/foreign/unexported.scrbl +++ b/collects/scribblings/foreign/unexported.scrbl @@ -39,8 +39,9 @@ These values can also be used as C pointer objects.} [(ctype-c->scheme [type ctype?]) procedure?])]{ Accessors for the components of a C type object, made by -@scheme[make-ctype]. The @scheme[ctype-basetype] selector returns -@scheme[#f] for primitive types (including cstruct types).} +@scheme[make-ctype]. The @scheme[ctype-basetype] selector returns a +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?] diff --git a/collects/scribblings/reference/custodians.scrbl b/collects/scribblings/reference/custodians.scrbl index 69e5a66a76..32d5ecaa1f 100644 --- a/collects/scribblings/reference/custodians.scrbl +++ b/collects/scribblings/reference/custodians.scrbl @@ -57,19 +57,19 @@ or indirectly). If @scheme[cust] is not strictly subordinate to @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, 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?] [need-amt exact-nonnegative-integer?] [stop-cust custodian?]) void?]{ -Registers a require check if PLT Scheme is compiled with support for -per-custodian memory accounting, otherwise the +Registers a required-memory check if PLT Scheme is compiled with +support for per-custodian memory accounting, otherwise the @exnraise[exn:fail:unsupported]. 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?] [stop-cust custodian? limit-cust]) void?]{ -Registers a limit check if PLT Scheme is compiled with support for -per-custodian memory accounting, otherwise the +Registers a limited-memory check if PLT Scheme is compiled with +support for per-custodian memory accounting, otherwise the @exnraise[exn:fail:unsupported]. 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 collection, except that it may also be checked during 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 @scheme[custodian-limit-memory] must be much lower than the total diff --git a/collects/scribblings/reference/eval-model.scrbl b/collects/scribblings/reference/eval-model.scrbl index 4cd934cbe6..4e073ec0e3 100644 --- a/collects/scribblings/reference/eval-model.scrbl +++ b/collects/scribblings/reference/eval-model.scrbl @@ -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, and the choice can change after each collection; objects reachable from both a custodian and its descendant, however, are reliably -charged to the descendant. Reachability for per-custodian accounting -does not include weak references, references to threads managed by -non-descendant custodians, references to non-descendant custodians, or -references to custodian boxes for non-descendant custodians. +charged to the custodian and not to the descendants, unless the +custodian can reach the objects only through a descendant custodian or +a descendant's thread. Reachability for per-custodian accounting does +not include weak references, references to threads managed by other +custodians, references to other custodians, or references to custodian +boxes for other custodians. diff --git a/collects/scribblings/reference/sandbox.scrbl b/collects/scribblings/reference/sandbox.scrbl index 229f638c82..a9ef74c6a3 100644 --- a/collects/scribblings/reference/sandbox.scrbl +++ b/collects/scribblings/reference/sandbox.scrbl @@ -16,12 +16,11 @@ The @schememodname[scheme/sandbox] module provides utilities for creating ``sandboxed'' evaluators, which are configured in a particular way and can have restricted resources (memory and time), -filesystem access, and network access. The common use case for this -module is for a restricted sandboxed environment, so the defaults are -set up to make it safe. For other uses you will likely need to change -mane of these settings. +filesystem and network access, and much. Sandboxed evaluators can be +configured through numerous parameters --- and the defaults are set +for the common use case where sandboxes are very limited. -@defproc*[([(make-evaluator [language (or/c module-path? +@defproc*[([(make-evaluator [language (or/c module-path? (list/c 'special symbol?) (cons/c 'begin list?))] [input-program any/c] ... @@ -260,9 +259,29 @@ either @scheme['time] or @scheme['memory].} @section{Customizing Evaluators} -The evaluators that @scheme[make-evaluator] creates can be customized -via several parameters. These parameters affect newly created -evaluators; changing them has no effect on already-running evaluators. +The sandboxed evaluators that @scheme[make-evaluator] creates can be +customized via many parameters. Most of the configuration parameters +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)]{ @@ -443,7 +462,7 @@ specifications in @scheme[sandbox-path-permissions], and it uses @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?)))]{ 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. The access mode symbol is one of: @scheme['execute], @scheme['write], -@scheme['delete], @scheme['read], or @scheme['exists]. These symbols are -in decreasing order: each implies access for the following modes too -(e.g., @scheme['read] allows reading or checking for existence). +@scheme['delete], @scheme['read], or @scheme['exists]. These symbols +are in decreasing order: each implies access for the following modes +too (e.g., @scheme['read] allows reading or checking for existence). 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 @@ -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., @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 -augmented by @scheme['read] permissions that make it possible to use -collection libraries (including +augmented by @scheme['read-bytecode] permissions that make it possible +to use collection libraries (including @scheme[sandbox-override-collection-paths]). See @scheme[make-evalautor] for more information.} @@ -490,29 +525,54 @@ appropriate error message (see @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. -When this limit is exceeded, the sandbox is terminated. This value is -used when the sandbox is created and the limit cannot be changed -afterwards. See @scheme[sandbox-eval-limits] for per-evaluation -limits and a description of how the two limits work together.} +A parameter that determines the total memory limit on the sandbox in +megabytes (it can hold a rational or a floating point number). When +this limit is exceeded, the sandbox is terminated. This value is used +when the sandbox is created and the limit cannot be changed +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 - (or/c (list/c (or/c exact-nonnegative-integer? #f) - (or/c exact-nonnegative-integer? #f)) + (or/c (list/c (or/c nonnegative-number? #f) + (or/c nonnegative-number? #f)) #f)]{ A parameter that determines the default limits on @italic{each} use of a @scheme[make-evaluator] function, including the initial evaluation 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 -memory limit in megabytes. Either one can be @scheme[#f] for -disabling the corresponding limit; alternately, the parameter can be -set to @scheme[#f] to disable all per-evaluation limits (useful in -case more limit kinds are available in future versions). The default -is @scheme[(list 30 20)]. +memory limit in megabytes (note that they don't have to be integers). +Either one can be @scheme[#f] for disabling the corresponding limit; +alternately, the parameter can be set to @scheme[#f] to disable all +per-evaluation limits (useful in case more limit kinds are available +in future versions). The default is @scheme[(list 30 20)]. Note that these limits apply to the creation of the sandbox 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 inspector for sandboxed evaluation. The procedure is called when 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?)]{ diff --git a/collects/scribblings/reference/security-guards.scrbl b/collects/scribblings/reference/security-guards.scrbl index 9296307650..164a437cd9 100644 --- a/collects/scribblings/reference/security-guards.scrbl +++ b/collects/scribblings/reference/security-guards.scrbl @@ -37,8 +37,8 @@ host platform. (or/c (integer-in 1 65535) #f) (or/c 'server 'client) . -> . any)] - [link (or/c (symbol? path? path? . -> . any) #f) - #f]) + [link-guard (or/c (symbol? path? path? . -> . any) #f) + #f]) security-guard?]{ Creates a new security guard as child of @scheme[parent]. diff --git a/collects/string-constants/english-string-constants.ss b/collects/string-constants/english-string-constants.ss index 4278e0fb52..efeed1ebf2 100644 --- a/collects/string-constants/english-string-constants.ss +++ b/collects/string-constants/english-string-constants.ss @@ -862,7 +862,7 @@ please adhere to these guidelines: (force-quit-menu-item-help-string "Uses custodian-shutdown-all to abort the current evaluation") (limit-memory-menu-item-label "Limit Memory...") (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-limited "Limited") (limit-memory-megabytes "Megabytes") diff --git a/collects/string-constants/french-string-constants.ss b/collects/string-constants/french-string-constants.ss index 7cb51c1c99..017ee9b754 100644 --- a/collects/string-constants/french-string-constants.ss +++ b/collects/string-constants/french-string-constants.ss @@ -859,7 +859,7 @@ (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-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-limited "Limitée") (limit-memory-megabytes "Megaoctets") diff --git a/collects/string-constants/german-string-constants.ss b/collects/string-constants/german-string-constants.ss index b3112612d7..94dce2899e 100644 --- a/collects/string-constants/german-string-constants.ss +++ b/collects/string-constants/german-string-constants.ss @@ -763,7 +763,7 @@ (force-quit-menu-item-help-string "Benutzt custodian-shutdown-all, um die Auswertung abzubrechen") (limit-memory-menu-item-label "Speicherverbrauch einschränken...") (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-limited "einschränken") (limit-memory-megabytes "Megabytes") diff --git a/collects/string-constants/japanese-string-constants.ss b/collects/string-constants/japanese-string-constants.ss index 3f3c64b0a2..376c2d2b48 100644 --- a/collects/string-constants/japanese-string-constants.ss +++ b/collects/string-constants/japanese-string-constants.ss @@ -805,7 +805,7 @@ please adhere to these guidelines: (kill-menu-item-help-string "現在の評価を強制終了します") (limit-memory-menu-item-label "メモリを制限する...") (limit-memory-msg-1 "ここで指定したメモリ制限値は、プログラムを次に実行するときに有効になります。") - (limit-memory-msg-2 "制限値は 100MB 以上にしてください。") + (limit-memory-msg-2 "制限値は 1MB 以上にしてください。") (limit-memory-unlimited "制限しない") (limit-memory-limited "制限する") (limit-memory-megabytes "MB") diff --git a/collects/string-constants/simplified-chinese-string-constants.ss b/collects/string-constants/simplified-chinese-string-constants.ss index 68d0b2d1e3..7a53c24015 100644 --- a/collects/string-constants/simplified-chinese-string-constants.ss +++ b/collects/string-constants/simplified-chinese-string-constants.ss @@ -780,7 +780,7 @@ (force-quit-menu-item-help-string "使用custodian-shutdown-all退出当前计算") (limit-memory-menu-item-label "限制内存使用...") (limit-memory-msg-1 "内存限制会在下一次运行") - (limit-memory-msg-2 "时生效。内存限制最低值为100megabytes.") + (limit-memory-msg-2 "时生效。内存限制最低值为1megabyte.") (limit-memory-unlimited "无限制") (limit-memory-limited "限制") (limit-memory-megabytes "Megabytes") diff --git a/collects/string-constants/traditional-chinese-string-constants.ss b/collects/string-constants/traditional-chinese-string-constants.ss index edfb95a6e0..5ae4839493 100644 --- a/collects/string-constants/traditional-chinese-string-constants.ss +++ b/collects/string-constants/traditional-chinese-string-constants.ss @@ -779,7 +779,7 @@ (force-quit-menu-item-help-string "使用custodian-shutdown-all退出当前计算") (limit-memory-menu-item-label "限制内存使用...") (limit-memory-msg-1 "内存限制会在下一次运行") - (limit-memory-msg-2 "时生效。内存限制最低值为100megabytes.") + (limit-memory-msg-2 "时生效。内存限制最低值为1megabyte.") (limit-memory-unlimited "无限制") (limit-memory-limited "限制") (limit-memory-megabytes "Megabytes") diff --git a/collects/tests/mzscheme/sandbox.ss b/collects/tests/mzscheme/sandbox.ss index 855d14c798..58f1cf7eee 100644 --- a/collects/tests/mzscheme/sandbox.ss +++ b/collects/tests/mzscheme/sandbox.ss @@ -148,11 +148,11 @@ =err> "out of time" (when (custodian-memory-accounting-available?) (t --top-- - (set! ev (parameterize ([sandbox-eval-limits '(0.25 2)]) + (set! ev (parameterize ([sandbox-eval-limits '(2 2)]) (make-evaluator 'scheme/base '(define a (for/list ([i (in-range 10)]) (collect-garbage) - (make-string 1000)))))) + (make-bytes 500000)))))) =err> "out of memory")) ;; i/o @@ -275,59 +275,94 @@ ;; limited FS access, allowed for requires --top-- - (let* ([tmp (find-system-path 'temp-dir)] - [schemelib (path->string (collection-path "scheme"))] - [list-lib (path->string (build-path schemelib "list.ss"))] - [test-lib (path->string (build-path tmp "sandbox-test.ss"))]) - (t --top-- - (set! ev (make-evaluator 'scheme/base)) - --eval-- - ;; reading from collects is allowed - (list (directory-list ,schemelib)) - (file-exists? ,list-lib) => #t - (input-port? (open-input-file ,list-lib)) => #t - ;; writing is forbidden - (open-output-file ,list-lib) =err> "`write' access denied" - ;; reading from other places is forbidden - (directory-list ,tmp) =err> "`read' access denied" - ;; no network too - (require scheme/tcp) - (tcp-listen 12345) =err> "network access denied" - --top-- - ;; reading from a specified require is fine - (with-output-to-file test-lib - (lambda () - (printf "~s\n" '(module sandbox-test scheme/base - (define x 123) (provide x)))) - #:exists 'replace) - (set! ev (make-evaluator 'scheme/base #:requires `(,test-lib))) - --eval-- - x => 123 - (length (with-input-from-file ,test-lib read)) => 5 - ;; the directory is still not kosher - (directory-list ,tmp) =err> "`read' access denied" - --top-- - ;; should work also for module evaluators - ;; --> NO! Shouldn't make user code require whatever it wants - ;; (set! ev (make-evaluator `(module foo scheme/base - ;; (require (file ,test-lib))))) - ;; --eval-- - ;; x => 123 - ;; (length (with-input-from-file ,test-lib read)) => 5 - ;; ;; the directory is still not kosher - ;; (directory-list tmp) =err> "file access denied" - --top-- - ;; explicitly allow access to tmp - (set! ev (parameterize ([sandbox-path-permissions - `((read ,tmp) - ,@(sandbox-path-permissions))]) - (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") - (delete-file test-lib)) + (let* ([tmp (make-temporary-file "sandboxtest~a" 'directory)] + [strpath (lambda xs (path->string (apply build-path xs)))] + [schemelib (strpath (collection-path "scheme"))] + [list-lib (strpath schemelib "list.ss")] + [list-zo (strpath schemelib "compiled" "list_ss.zo")] + [test-lib (strpath tmp "sandbox-test.ss")] + [test-zo (strpath tmp "compiled" "sandbox-test_ss.zo")] + [test2-lib (strpath tmp "sandbox-test2.ss")] + [test2-zo (strpath tmp "compiled" "sandbox-test2_ss.zo")]) + (t --top-- + (set! ev (make-evaluator 'scheme/base)) + --eval-- + ;; reading from collects is allowed + (list? (directory-list ,schemelib)) + (file-exists? ,list-lib) => #t + (input-port? (open-input-file ,list-lib)) => #t + ;; writing is forbidden + (open-output-file ,list-lib) =err> "`write' access denied" + ;; reading from other places is forbidden + (directory-list ,tmp) =err> "`read' access denied" + ;; no network too + (require scheme/tcp) + (tcp-listen 12345) =err> "network access denied" + --top-- + ;; reading from a specified require is fine + (with-output-to-file test-lib + (lambda () + (printf "~s\n" '(module sandbox-test scheme/base + (define x 123) (provide x))))) + (set! ev (make-evaluator 'scheme/base #:requires `(,test-lib))) + --eval-- + x => 123 + (length (with-input-from-file ,test-lib read)) => 5 + ;; the directory is still not kosher + (directory-list ,tmp) =err> "`read' access denied" + --top-- + ;; should work also for module evaluators + ;; --> NO! Shouldn't make user code require whatever it wants + ;; (set! ev (make-evaluator `(module foo scheme/base + ;; (require (file ,test-lib))))) + ;; --eval-- + ;; x => 123 + ;; (length (with-input-from-file ,test-lib read)) => 5 + ;; ;; the directory is still not kosher + ;; (directory-list tmp) =err> "file access denied" + --top-- + ;; explicitly allow access to tmp, and write access to a single file + (make-directory (build-path tmp "compiled")) + (set! ev (parameterize ([sandbox-path-permissions + `((read ,tmp) + (write ,test-zo) + ,@(sandbox-path-permissions))]) + (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 --top-- @@ -388,30 +423,17 @@ --top-- (set! ev (parameterize ([sandbox-output 'bytes] [sandbox-error-output current-output-port] - [sandbox-memory-limit 5] - [sandbox-eval-limits '(0.25 1/2)]) + [sandbox-memory-limit 2] + [sandbox-eval-limits '(0.25 1)]) (make-evaluator 'scheme/base))) - ;; GCing is needed to allow these to happen - --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 - --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 + ;; GCing is needed to allow these to happen (note: the memory limit is very + ;; tight here, this test usually fails if the sandbox library is not + ;; compiled) + (let ([t (lambda () + (t --eval-- (display (make-bytes 400000 65)) (collect-garbage) + --top-- (bytes-length (get-output ev)) => 400000))]) + ;; can go arbitrarily high here + (for ([i (in-range 20)]) (t))) ;; test that killing the custodian works fine ;; first try it without limits (limits imply a nested thread/custodian) @@ -466,9 +488,14 @@ --eval-- (define a '()) (define b 1) - (for ([i (in-range 20)]) - (set! a (cons (make-bytes 500000) a)) - (collect-garbage)) + (length + (for/fold ([v null]) ([i (in-range 20)]) + ;; 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" b => 1)) diff --git a/collects/tests/mzscheme/testing.ss b/collects/tests/mzscheme/testing.ss index 318d9fdf8b..cb60a31e5a 100644 --- a/collects/tests/mzscheme/testing.ss +++ b/collects/tests/mzscheme/testing.ss @@ -77,17 +77,13 @@ transcript. (define number-of-exn-tests 0) (define (load-in-sandbox file) - (let ([e (parameterize ([(dynamic-require 'scheme/sandbox 'sandbox-security-guard) - (current-security-guard)] - [(dynamic-require 'scheme/sandbox 'sandbox-input) - current-input-port] - [(dynamic-require 'scheme/sandbox 'sandbox-output) - current-output-port] - [(dynamic-require 'scheme/sandbox 'sandbox-error-output) - current-error-port] - [(dynamic-require 'scheme/sandbox 'sandbox-eval-limits) - #f]) - ((dynamic-require 'scheme/sandbox 'make-evaluator) '(begin) #:requires (list 'scheme)))]) + (define-syntax-rule (S id) (dynamic-require 'scheme/sandbox 'id)) + (let ([e ((S call-with-trusted-sandbox-configuration) + (parameterize ([(S sandbox-input) current-input-port] + [(S sandbox-output) current-output-port] + [(S sandbox-error-output) current-error-port] + [(S sandbox-memory-limit) 100]) ; 100mb per box + ((S make-evaluator) '(begin) #:requires (list 'scheme))))]) (e `(load-relative "testing.ss")) (e `(define real-error-port (quote ,real-error-port))) (e `(define Section-prefix ,Section-prefix)) diff --git a/doc/release-notes/mzscheme/HISTORY.txt b/doc/release-notes/mzscheme/HISTORY.txt index 68435a0adb..ea4c3098fd 100644 --- a/doc/release-notes/mzscheme/HISTORY.txt +++ b/doc/release-notes/mzscheme/HISTORY.txt @@ -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 Added compile-context-preservation-enabled Added exception-backtrace support for x86_84+JIT diff --git a/src/foreign/foreign.c b/src/foreign/foreign.c index 3a7628ca28..6d97a28770 100644 --- a/src/foreign/foreign.c +++ b/src/foreign/foreign.c @@ -810,9 +810,16 @@ typedef union _ForeignAny { /* Type objects */ /* 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 - * 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 */ static Scheme_Type ctype_tag; typedef struct ctype_struct { @@ -849,8 +856,8 @@ END_XFORM_SKIP; #endif #define CTYPE_BASETYPE(x) (((ctype_struct*)(x))->basetype) -#define CTYPE_PRIMP(x) (NULL == (CTYPE_BASETYPE(x))) -#define CTYPE_USERP(x) (!(CTYPE_PRIMP(x))) +#define CTYPE_USERP(x) (CTYPE_BASETYPE(x) != NULL && SCHEME_CTYPEP(CTYPE_BASETYPE(x))) +#define CTYPE_PRIMP(x) (!CTYPE_USERP(x)) #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_USER_S2C(x) (((ctype_struct*)(x))->scheme_to_c) @@ -861,12 +868,9 @@ END_XFORM_SKIP; #define MYNAME "ctype-basetype" static Scheme_Object *foreign_ctype_basetype(int argc, Scheme_Object *argv[]) { - Scheme_Object *base; if (!SCHEME_CTYPEP(argv[0])) scheme_wrong_type(MYNAME, "ctype", 0, argc, argv); - base = CTYPE_BASETYPE(argv[0]); - if (NULL == base) return scheme_false; - else return base; + return CTYPE_BASETYPE(argv[0]); } #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"); type = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); type->so.type = ctype_tag; - type->basetype = (NULL); + type->basetype = (argv[0]); type->scheme_to_c = ((Scheme_Object*)libffi_type); type->c_to_scheme = ((Scheme_Object*)FOREIGN_struct); 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, int delta, int args_loc) { - Scheme_Object *res, *base; + Scheme_Object *res; if (!SCHEME_CTYPEP(type)) scheme_wrong_type("C->Scheme", "C-type", 0, 1, &type); - base = CTYPE_BASETYPE(type); - if (base != NULL) { - res = C2SCHEME(base, src, delta, args_loc); + if (CTYPE_USERP(type)) { + res = C2SCHEME(CTYPE_BASETYPE(type), src, delta, args_loc); if (SCHEME_FALSEP(CTYPE_USER_C2S(type))) return res; else @@ -2347,7 +2350,7 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[]) offset = 0; p = SCHEME2C(SCHEME_CAR(itypes), &(ivals[i]), 0, argv[i], &basetype, &offset, 0); - if (p != NULL) { + if ((p != NULL) || offset) { avalues[i] = p; ivals[i].x_fixnum = basetype; /* remember the base type */ } 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 * mess */ for (i=0; i"); ffi_obj_tag = scheme_make_type(""); @@ -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_add_global("ffi-callback", 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->so.type = ctype_tag; - t->basetype = (NULL); + t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_void)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_void); scheme_add_global("_void", (Scheme_Object*)t, menv); + s = scheme_intern_symbol("int8"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; - t->basetype = (NULL); + t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint8)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_int8); scheme_add_global("_int8", (Scheme_Object*)t, menv); + s = scheme_intern_symbol("uint8"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; - t->basetype = (NULL); + t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint8)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_uint8); scheme_add_global("_uint8", (Scheme_Object*)t, menv); + s = scheme_intern_symbol("int16"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; - t->basetype = (NULL); + t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint16)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_int16); scheme_add_global("_int16", (Scheme_Object*)t, menv); + s = scheme_intern_symbol("uint16"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; - t->basetype = (NULL); + t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint16)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_uint16); scheme_add_global("_uint16", (Scheme_Object*)t, menv); + s = scheme_intern_symbol("int32"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; - t->basetype = (NULL); + t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint32)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_int32); scheme_add_global("_int32", (Scheme_Object*)t, menv); + s = scheme_intern_symbol("uint32"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; - t->basetype = (NULL); + t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint32)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_uint32); scheme_add_global("_uint32", (Scheme_Object*)t, menv); + s = scheme_intern_symbol("int64"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; - t->basetype = (NULL); + t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint64)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_int64); scheme_add_global("_int64", (Scheme_Object*)t, menv); + s = scheme_intern_symbol("uint64"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; - t->basetype = (NULL); + t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint64)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_uint64); scheme_add_global("_uint64", (Scheme_Object*)t, menv); + s = scheme_intern_symbol("fixint"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; - t->basetype = (NULL); + t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint32)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_fixint); scheme_add_global("_fixint", (Scheme_Object*)t, menv); + s = scheme_intern_symbol("ufixint"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; - t->basetype = (NULL); + t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint32)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_ufixint); scheme_add_global("_ufixint", (Scheme_Object*)t, menv); + s = scheme_intern_symbol("fixnum"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; - t->basetype = (NULL); + t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_smzlong)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_fixnum); scheme_add_global("_fixnum", (Scheme_Object*)t, menv); + s = scheme_intern_symbol("ufixnum"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; - t->basetype = (NULL); + t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_umzlong)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_ufixnum); scheme_add_global("_ufixnum", (Scheme_Object*)t, menv); + s = scheme_intern_symbol("float"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; - t->basetype = (NULL); + t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_float)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_float); scheme_add_global("_float", (Scheme_Object*)t, menv); + s = scheme_intern_symbol("double"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; - t->basetype = (NULL); + t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_double)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_double); scheme_add_global("_double", (Scheme_Object*)t, menv); + s = scheme_intern_symbol("double*"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; - t->basetype = (NULL); + t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_double)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_doubleS); scheme_add_global("_double*", (Scheme_Object*)t, menv); + s = scheme_intern_symbol("bool"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; - t->basetype = (NULL); + t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_bool); 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->so.type = ctype_tag; - t->basetype = (NULL); + t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_string_ucs_4); 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->so.type = ctype_tag; - t->basetype = (NULL); + t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_string_utf_16); 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->so.type = ctype_tag; - t->basetype = (NULL); + t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_bytes); scheme_add_global("_bytes", (Scheme_Object*)t, menv); + s = scheme_intern_symbol("path"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; - t->basetype = (NULL); + t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_path); scheme_add_global("_path", (Scheme_Object*)t, menv); + s = scheme_intern_symbol("symbol"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; - t->basetype = (NULL); + t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_symbol); scheme_add_global("_symbol", (Scheme_Object*)t, menv); + s = scheme_intern_symbol("pointer"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; - t->basetype = (NULL); + t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_pointer); scheme_add_global("_pointer", (Scheme_Object*)t, menv); + s = scheme_intern_symbol("scheme"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; - t->basetype = (NULL); + t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_scheme); scheme_add_global("_scheme", (Scheme_Object*)t, menv); + s = scheme_intern_symbol("fpointer"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; - t->basetype = (NULL); + t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_fpointer); scheme_add_global("_fpointer", (Scheme_Object*)t, menv); diff --git a/src/foreign/foreign.ssc b/src/foreign/foreign.ssc index dd544ad838..50a0ce63ac 100755 --- a/src/foreign/foreign.ssc +++ b/src/foreign/foreign.ssc @@ -10,6 +10,8 @@ exec mzpp -s "---begin" -o `echo "$0" | sed 's/ssc$/c/'` "$0" ** to make changes, edit that file and ** run it to generate an updated version ** 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"):} @@ -445,7 +447,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) (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*)) (~ "#define FOREIGN_"cname" ("*type-counter*")" \\ "/* 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-"] [(procedure? c->s) (c->s "")] [else (list c->s"()")]) \\ - " */" \\)) + " */" \\ + ;; no need for these, at least for now: + ;; "static Scheme_Object *"cname"_sym;"\\ + )) (define (make-ctype type args) (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")))] [c->s (prop 'c->s)] [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) (macro ,macro) (pred ,pred) (s->c ,s->c) (c->s ,c->s) (offset ,offset)))) @@ -726,17 +731,24 @@ typedef union _ForeignAny { /* Type objects */ /* 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 - * 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 (basetype "Scheme_Object*") (scheme_to_c "Scheme_Object*") (c_to_scheme "Scheme_Object*")):} #define CTYPE_BASETYPE(x) (((ctype_struct*)(x))->basetype) -#define CTYPE_PRIMP(x) (NULL == (CTYPE_BASETYPE(x))) -#define CTYPE_USERP(x) (!(CTYPE_PRIMP(x))) +#define CTYPE_USERP(x) (CTYPE_BASETYPE(x) != NULL && SCHEME_CTYPEP(CTYPE_BASETYPE(x))) +#define CTYPE_PRIMP(x) (!CTYPE_USERP(x)) #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_USER_S2C(x) (((ctype_struct*)(x))->scheme_to_c) @@ -745,12 +757,9 @@ typedef union _ForeignAny { /* Returns #f for primitive types. */ {:(cdefine ctype-basetype 1):} { - Scheme_Object *base; if (!SCHEME_CTYPEP(argv[0])) scheme_wrong_type(MYNAME, "ctype", 0, argc, argv); - base = CTYPE_BASETYPE(argv[0]); - if (NULL == base) return scheme_false; - else return base; + return CTYPE_BASETYPE(argv[0]); } {:(cdefine ctype-scheme->c 1):} @@ -892,7 +901,7 @@ ffi_abi sym_to_abi(char *who, Scheme_Object *sym) dummy = &libffi_type; 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"); - {:(cmake-object "type" ctype "NULL" + {:(cmake-object "type" ctype "argv[0]" "(Scheme_Object*)libffi_type" "(Scheme_Object*)FOREIGN_struct"):} 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, int delta, int args_loc) { - Scheme_Object *res, *base; + Scheme_Object *res; if (!SCHEME_CTYPEP(type)) scheme_wrong_type("C->Scheme", "C-type", 0, 1, &type); - base = CTYPE_BASETYPE(type); - if (base != NULL) { - res = C2SCHEME(base, src, delta, args_loc); + if (CTYPE_USERP(type)) { + res = C2SCHEME(CTYPE_BASETYPE(type), src, delta, args_loc); if (SCHEME_FALSEP(CTYPE_USER_C2S(type))) return res; else @@ -1677,6 +1685,9 @@ static Scheme_Object *do_memop(const char *who, int mode, 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 */ 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.) */ /* - *** Calling Scheme code while the GC is working leads to subtle bugs, so - *** this is implemented now in Scheme using will executors. - {:"(defsymbols pointer)":} {:"(cdefine register-finalizer 2 3)":} { @@ -1789,7 +1797,7 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[]) offset = 0; p = SCHEME2C(SCHEME_CAR(itypes), &(ivals[i]), 0, argv[i], &basetype, &offset, 0); - if (p != NULL) { + if ((p != NULL) || offset) { avalues[i] = p; ivals[i].x_fixnum = basetype; /* remember the base type */ } 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 * mess */ for (i=0; idata), SAME_OBJ(ignored,(((closure_and_cif*)p)->data))); @@ -2066,6 +2074,7 @@ void scheme_init_foreign(Scheme_Env *env) { Scheme_Env *menv; ctype_struct *t; + Scheme_Object *s; menv = scheme_primitive_module(scheme_intern_symbol("#%foreign"), env); {:(for-each (lambda (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);")) (reverse! cfunctions)) (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*)FOREIGN_"cname)) (~ "scheme_add_global(\"_"stype"\", (Scheme_Object*)t, menv);")):} diff --git a/src/mred/Makefile.in b/src/mred/Makefile.in index 8ee1ab36e5..117f958011 100644 --- a/src/mred/Makefile.in +++ b/src/mred/Makefile.in @@ -351,6 +351,7 @@ install-wx_mac-cgc: $(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@" $(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: 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" /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" + /usr/bin/strip -S "$(prefix)/MrEd@MMM_CAP_INSTALLED@.app/Contents/MacOS/MrEd@MMM_CAP_INSTALLED@" install-wx_mac-3m-final: ln -s Versions/$(FWVERSION)_3m/PLT_MrEd $(MRFWDIR)/ diff --git a/src/mzscheme/Makefile.in b/src/mzscheme/Makefile.in index b1c4e1e2a2..cc976ebf4c 100644 --- a/src/mzscheme/Makefile.in +++ b/src/mzscheme/Makefile.in @@ -271,6 +271,7 @@ unix-install: cd ..; rm -f "$(DESTDIR)$(bindir)/mzscheme@CGC_INSTALLED@" cd ..; rm -f "$(DESTDIR)$(bindir)/mzscheme@MMM_INSTALLED@" cd ..; cp mzscheme/starter "$(DESTDIR)$(libpltdir)/starter" + cd ..; strip -S "$(DESTDIR)$(libpltdir)/starter" cd ..; echo 'CC=@CC@' > "$(BUILDINFO)" cd ..; echo 'CFLAGS=@CFLAGS@ @PREFLAGS@ @COMPFLAGS@' >> "$(BUILDINFO)" cd ..; echo 'OPTIONS=@OPTIONS@' >> "$(BUILDINFO)" @@ -316,6 +317,7 @@ osx-install-cgc: mkdir -p "$(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/strip -S "$(bindir)/mzscheme@CGC_INSTALLED@" osx-install-cgc-final: $(MAKE) unix-install-cgc-final @@ -326,6 +328,7 @@ osx-install-3m: mkdir -p "$(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/strip -S "$(bindir)/mzscheme@MMM_INSTALLED@" osx-install-3m-final: $(MAKE) unix-install-3m-final diff --git a/src/mzscheme/gc2/Makefile.in b/src/mzscheme/gc2/Makefile.in index 315209a657..3dce9e6b25 100644 --- a/src/mzscheme/gc2/Makefile.in +++ b/src/mzscheme/gc2/Makefile.in @@ -312,7 +312,7 @@ main.@LTO@: $(XSRCDIR)/main.c $(CC) $(CFLAGS) -c $(XSRCDIR)/main.c -o main.@LTO@ 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)/vm_osx.c $(srcdir)/vm_mmap.c $(srcdir)/vm_osk.c $(srcdir)/vm.c\ $(srcdir)/vm_memalign.c $(srcdir)/alloc_cache.c \ diff --git a/src/mzscheme/gc2/gc2.h b/src/mzscheme/gc2/gc2.h index 04a5be7cbd..a2c2a43a7a 100644 --- a/src/mzscheme/gc2/gc2.h +++ b/src/mzscheme/gc2/gc2.h @@ -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 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); /* Explicit write barrier to ensure that a write-barrier signal is not diff --git a/src/mzscheme/gc2/blame_the_child.c b/src/mzscheme/gc2/mem_account.c similarity index 97% rename from src/mzscheme/gc2/blame_the_child.c rename to src/mzscheme/gc2/mem_account.c index 5b8a21e8c7..c6c6208fbd 100644 --- a/src/mzscheme/gc2/blame_the_child.c +++ b/src/mzscheme/gc2/mem_account.c @@ -1,11 +1,11 @@ /*****************************************************************************/ -/* blame-the-child accounting */ +/* memory accounting */ /*****************************************************************************/ #ifdef NEWGC_BTC_ACCOUNT #include "../src/schpriv.h" /* 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_custodian = 510; @@ -430,13 +430,12 @@ static void BTC_do_accounting(NewGC *gc) if(owner_table[i]) owner_table[i]->memory_use = 0; - /* the end of the custodian list is where we want to start */ - while(SCHEME_PTR1_VAL(box)) { - cur = (Scheme_Custodian*)SCHEME_PTR1_VAL(box); - box = cur->global_next; + /* start with root: */ + while (cur->parent && SCHEME_PTR1_VAL(cur->parent)) { + cur = SCHEME_PTR1_VAL(cur->parent); } - /* walk backwards for the order we want */ + /* walk forward for the order we want (blame parents instead of children) */ while(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")); 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; diff --git a/src/mzscheme/gc2/newgc.c b/src/mzscheme/gc2/newgc.c index f29aecf90d..71c477963a 100644 --- a/src/mzscheme/gc2/newgc.c +++ b/src/mzscheme/gc2/newgc.c @@ -93,7 +93,7 @@ inline static int is_master_gc(NewGC *gc) { /* particular collector you want. */ /*****************************************************************************/ -/* This turns on blame-the-child automatic memory accounting */ +/* This turns on automatic memory accounting */ /* #define 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 -# include "blame_the_child.c" +# include "mem_account.c" #else # define clean_up_thread_list() /* */ #endif @@ -1404,6 +1404,12 @@ void GC_register_new_thread(void *t, void *c) #endif } +int GC_merely_accounting() +{ + NewGC *gc = GC_get_GC(); + return gc->doing_memory_accounting; +} + /*****************************************************************************/ /* administration / initialization */ /*****************************************************************************/ diff --git a/src/mzscheme/src/mzmark.c b/src/mzscheme/src/mzmark.c index d9d1ed3e61..36ae988ed3 100644 --- a/src/mzscheme/src/mzmark.c +++ b/src/mzscheme/src/mzmark.c @@ -923,8 +923,10 @@ static int cont_proc_MARK(void *p) { MARK_cjs(&c->cjs); MARK_stack_state(&c->ss); gcMARK(c->barrier_prompt); - gcMARK(c->runstack_start); - gcMARK(c->runstack_saved); + if (!GC_merely_accounting()) { + gcMARK(c->runstack_start); + gcMARK(c->runstack_saved); + } gcMARK(c->prompt_id); gcMARK(c->prompt_buf); @@ -961,8 +963,10 @@ static int cont_proc_FIXUP(void *p) { FIXUP_cjs(&c->cjs); FIXUP_stack_state(&c->ss); gcFIXUP(c->barrier_prompt); - gcFIXUP(c->runstack_start); - gcFIXUP(c->runstack_saved); + if (!GC_merely_accounting()) { + gcFIXUP(c->runstack_start); + gcFIXUP(c->runstack_saved); + } gcFIXUP(c->prompt_id); gcFIXUP(c->prompt_buf); @@ -1600,12 +1604,16 @@ static int thread_val_MARK(void *p) { gcMARK(pr->init_config); gcMARK(pr->init_break_cell); - { + if (!pr->runstack_owner + || !GC_merely_accounting() + || (*pr->runstack_owner == pr)) { Scheme_Object **rs = 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_swapped); 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_break_cell); - { + if (!pr->runstack_owner + || !GC_merely_accounting() + || (*pr->runstack_owner == pr)) { Scheme_Object **rs = 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_swapped); 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) { Scheme_Prompt *pr = (Scheme_Prompt *)p; gcMARK(pr->boundary_overflow_id); - gcMARK(pr->runstack_boundary_start); + if (!GC_merely_accounting()) + gcMARK(pr->runstack_boundary_start); gcMARK(pr->tag); gcMARK(pr->id); return @@ -1868,7 +1881,8 @@ static int prompt_val_MARK(void *p) { static int prompt_val_FIXUP(void *p) { Scheme_Prompt *pr = (Scheme_Prompt *)p; gcFIXUP(pr->boundary_overflow_id); - gcFIXUP(pr->runstack_boundary_start); + if (!GC_merely_accounting()) + gcFIXUP(pr->runstack_boundary_start); gcFIXUP(pr->tag); gcFIXUP(pr->id); return diff --git a/src/mzscheme/src/mzmarksrc.c b/src/mzscheme/src/mzmarksrc.c index b398e8113f..4ac017da7b 100644 --- a/src/mzscheme/src/mzmarksrc.c +++ b/src/mzscheme/src/mzmarksrc.c @@ -355,8 +355,10 @@ cont_proc { MARK_cjs(&c->cjs); MARK_stack_state(&c->ss); gcMARK(c->barrier_prompt); - gcMARK(c->runstack_start); - gcMARK(c->runstack_saved); + if (!GC_merely_accounting()) { + gcMARK(c->runstack_start); + gcMARK(c->runstack_saved); + } gcMARK(c->prompt_id); gcMARK(c->prompt_buf); @@ -615,12 +617,16 @@ thread_val { gcMARK(pr->init_config); gcMARK(pr->init_break_cell); - { + if (!pr->runstack_owner + || !GC_merely_accounting() + || (*pr->runstack_owner == pr)) { Scheme_Object **rs = 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_swapped); pr->spare_runstack = NULL; /* just in case */ @@ -738,7 +744,8 @@ prompt_val { mark: Scheme_Prompt *pr = (Scheme_Prompt *)p; gcMARK(pr->boundary_overflow_id); - gcMARK(pr->runstack_boundary_start); + if (!GC_merely_accounting()) + gcMARK(pr->runstack_boundary_start); gcMARK(pr->tag); gcMARK(pr->id); size: diff --git a/src/mzscheme/src/salloc.c b/src/mzscheme/src/salloc.c index 26d137189f..7117ccc58d 100644 --- a/src/mzscheme/src/salloc.c +++ b/src/mzscheme/src/salloc.c @@ -1509,6 +1509,7 @@ static void print_tagged_value(const char *prefix, void *v, int xtagged, unsigned long diff, int max_w, const char *suffix) { + char buffer[256]; char *type, *sep, diffstr[30]; 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); if (!scheme_strncmp(type, "#') || (type[8] == ':'))) { - char buffer[256]; char *run, *sus, *kill, *clean, *deq, *all, *t2; int state = ((Scheme_Thread *)v)->running, len2; @@ -1541,7 +1541,6 @@ static void print_tagged_value(const char *prefix, len += len2; type = t2; } else if (!scheme_strncmp(type, "#", 15)) { - char buffer[256]; char *t2; int len2; @@ -1561,8 +1560,20 @@ static void print_tagged_value(const char *prefix, memcpy(t2 + len, buffer, len2 + 1); len += len2; type = t2; + } else if (!scheme_strncmp(type, "#", 13)) { + char *t2; + int len2; + + sprintf(buffer, "[%d]", + ((Scheme_Custodian *)v)->elems); + + 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, "#", 13) || !scheme_strncmp(type, "#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[]) { 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; + adjust_limit_table((Scheme_Custodian *)args[0]); if (argc > 2) { - scheme_hash_set(limited_custodians, args[2], scheme_true); ((Scheme_Custodian *)args[2])->has_limit = 1; + adjust_limit_table((Scheme_Custodian *)args[2]); } #ifdef NEWGC_BTC_ACCOUNT @@ -1075,6 +1095,9 @@ static void add_managed_box(Scheme_Custodian *m, m->data[i] = data; m->mrefs[i] = mref; + m->elems++; + adjust_limit_table(m); + return; } } @@ -1086,6 +1109,9 @@ static void add_managed_box(Scheme_Custodian *m, m->data[m->count] = data; m->mrefs[m->count] = mref; + m->elems++; + adjust_limit_table(m); + m->count++; } @@ -1112,6 +1138,8 @@ static void remove_managed(Scheme_Custodian_Reference *mr, Scheme_Object *o, if (old_data) *old_data = m->data[i]; m->data[i] = NULL; + --m->elems; + adjust_limit_table(m); break; } } @@ -1164,6 +1192,8 @@ static void adjust_custodian_family(void *mgr, void *skip_move) m = next; } + adjust_limit_table(parent); + /* Add remaining managed items to parent: */ if (!skip_move) { 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_prev) = NULL; } + + if (parent) + adjust_limit_table(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->alloc = 0; + m->elems = 0; m->boxes = NULL; m->closers = 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 */ adjust_custodian_family(m, m); - if (m->has_limit) { - scheme_hash_set(limited_custodians, (Scheme_Object *)m, NULL); - } + adjust_limit_table(m); m = next_m; } diff --git a/src/wxxt/contrib/xpm/lib/CrBufFrI.c b/src/wxxt/contrib/xpm/lib/CrBufFrI.c index e7d5da4fa4..3399ba5189 100644 --- a/src/wxxt/contrib/xpm/lib/CrBufFrI.c +++ b/src/wxxt/contrib/xpm/lib/CrBufFrI.c @@ -36,7 +36,7 @@ \*****************************************************************************/ #include "xpmP.h" -#if defined(SYSV) || defined(SVR4) || defined(VMS) +#if defined(SYSV) || defined(SVR4) || defined(VMS) || defined(__GNUC__) #include #else #include diff --git a/src/wxxt/contrib/xpm/lib/CrDatFrI.c b/src/wxxt/contrib/xpm/lib/CrDatFrI.c index e97fed715e..ca898d120a 100644 --- a/src/wxxt/contrib/xpm/lib/CrDatFrI.c +++ b/src/wxxt/contrib/xpm/lib/CrDatFrI.c @@ -33,7 +33,7 @@ \*****************************************************************************/ #include "xpmP.h" -#if defined(SYSV) || defined(SVR4) || defined(VMS) +#if defined(SYSV) || defined(SVR4) || defined(VMS) || defined(__GNUC__) #include #else #include diff --git a/src/wxxt/contrib/xpm/lib/WrFFrBuf.c b/src/wxxt/contrib/xpm/lib/WrFFrBuf.c index 5f47f52f12..d758232745 100644 --- a/src/wxxt/contrib/xpm/lib/WrFFrBuf.c +++ b/src/wxxt/contrib/xpm/lib/WrFFrBuf.c @@ -33,6 +33,11 @@ \*****************************************************************************/ #include "xpmP.h" +#if defined(SYSV) || defined(SVR4) || defined(VMS) || defined(__GNUC__) +#include +#else +#include +#endif int XpmWriteFileFromBuffer(filename, buffer) diff --git a/src/wxxt/contrib/xpm/lib/WrFFrI.c b/src/wxxt/contrib/xpm/lib/WrFFrI.c index 3d6f8a1cd9..7a004d9dce 100644 --- a/src/wxxt/contrib/xpm/lib/WrFFrI.c +++ b/src/wxxt/contrib/xpm/lib/WrFFrI.c @@ -33,6 +33,11 @@ \*****************************************************************************/ #include "xpmP.h" +#if defined(SYSV) || defined(SVR4) || defined(VMS) || defined(__GNUC__) +#include +#else +#include +#endif LFUNC(WriteFile, int, (FILE *file, XpmImage *image, char *name, XpmInfo *info)); diff --git a/src/wxxt/contrib/xpm/lib/create.c b/src/wxxt/contrib/xpm/lib/create.c index 2b30f9df37..ced1e0a254 100644 --- a/src/wxxt/contrib/xpm/lib/create.c +++ b/src/wxxt/contrib/xpm/lib/create.c @@ -40,6 +40,11 @@ #include "xpmP.h" #include +#if defined(SYSV) || defined(SVR4) || defined(VMS) || defined(__GNUC__) +#include +#else +#include +#endif LFUNC(xpmVisualType, int, (Visual *visual)); diff --git a/src/wxxt/contrib/xpm/lib/data.c b/src/wxxt/contrib/xpm/lib/data.c index 1667b485b1..351068a8e0 100644 --- a/src/wxxt/contrib/xpm/lib/data.c +++ b/src/wxxt/contrib/xpm/lib/data.c @@ -39,6 +39,11 @@ static char *RCS_Version = "$XpmVersion: 3.4g $"; #include "xpmP.h" #include +#if defined(SYSV) || defined(SVR4) || defined(VMS) || defined(__GNUC__) +#include +#else +#include +#endif LFUNC(ParseComment, int, (xpmData * mdata)); diff --git a/src/wxxt/contrib/xpm/lib/hashtab.c b/src/wxxt/contrib/xpm/lib/hashtab.c index 790203bfe8..4d76aa5aa3 100644 --- a/src/wxxt/contrib/xpm/lib/hashtab.c +++ b/src/wxxt/contrib/xpm/lib/hashtab.c @@ -34,6 +34,11 @@ \*****************************************************************************/ #include "xpmP.h" +#if defined(SYSV) || defined(SVR4) || defined(VMS) || defined(__GNUC__) +#include +#else +#include +#endif LFUNC(AtomMake, xpmHashAtom, (char *name, void *data)); LFUNC(HashTableGrows, int, (xpmHashTable * table)); diff --git a/src/wxxt/contrib/xpm/lib/parse.c b/src/wxxt/contrib/xpm/lib/parse.c index 3612313189..d847365e5e 100644 --- a/src/wxxt/contrib/xpm/lib/parse.c +++ b/src/wxxt/contrib/xpm/lib/parse.c @@ -40,6 +40,11 @@ #include "xpmP.h" #include +#if defined(SYSV) || defined(SVR4) || defined(VMS) || defined(__GNUC__) +#include +#else +#include +#endif LFUNC(ParseValues, int, (xpmData *data, unsigned int *width, unsigned int *height, unsigned int *ncolors, diff --git a/src/wxxt/contrib/xpm/lib/rgb.c b/src/wxxt/contrib/xpm/lib/rgb.c index 114b30f47d..0984b27764 100644 --- a/src/wxxt/contrib/xpm/lib/rgb.c +++ b/src/wxxt/contrib/xpm/lib/rgb.c @@ -44,7 +44,7 @@ #include "xpmP.h" #include -#if defined(SYSV) || defined(SVR4) || defined(VMS) +#if defined(SYSV) || defined(SVR4) || defined(VMS) || defined(__GNUC__) #include #else #include diff --git a/src/wxxt/src/DeviceContexts/WindowDC.cc b/src/wxxt/src/DeviceContexts/WindowDC.cc index 4945605d65..eac2053b55 100644 --- a/src/wxxt/src/DeviceContexts/WindowDC.cc +++ b/src/wxxt/src/DeviceContexts/WindowDC.cc @@ -2867,6 +2867,10 @@ void wxWindowDC::Initialize(wxWindowDC_Xinit* init) void wxWindowDC::Destroy(void) { +#ifdef WX_USE_CAIRO + ReleaseCairoDev(); +#endif + if (PEN_GC) XFreeGC(DPY, PEN_GC); if (BRUSH_GC) XFreeGC(DPY, BRUSH_GC); if (TEXT_GC) XFreeGC(DPY, TEXT_GC); @@ -3726,7 +3730,7 @@ void wxWindowDC::InitCairoDev() void wxWindowDC::ReleaseCairoDev() { if (X->cairo_dev) { - cairo_destroy(CAIRO_DEV); + cairo_destroy_it(CAIRO_DEV); X->cairo_dev = 0; } } diff --git a/src/wxxt/src/wx_cairo.h b/src/wxxt/src/wx_cairo.h index 776b2a75fa..c90dd6a213 100644 --- a/src/wxxt/src/wx_cairo.h +++ b/src/wxxt/src/wx_cairo.h @@ -24,6 +24,7 @@ typedef cairo_matrix_t cairo_matrix_p; # define cairo_default_matrix(dev) cairo_identity_matrix(dev) # undef cairo_init_clip # 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 /* Old Cairo API (0.5 and up) */ 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_create_xlib(dev, display, drawable, vis, w, h) \ dev = cairo_create(); cairo_set_target_drawable(dev, wxAPP_DISPLAY, DRAWABLE) +# define cairo_destroy_it(c) cairo_destroy(c) # endif #endif