From c62595772fcc6231d4175c54d9a7f0f469a0c4cb Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 15 Dec 2008 01:07:00 +0000 Subject: [PATCH 01/36] Finally enabled using a sub code-inspector properly, with a new 'read-bytecode permission mode. Added tests and (crappily) documented. svn: r12846 --- collects/scheme/sandbox.ss | 97 +++++++++---- collects/scribblings/reference/sandbox.scrbl | 34 ++++- collects/tests/mzscheme/sandbox.ss | 145 ++++++++++++------- 3 files changed, 185 insertions(+), 91 deletions(-) diff --git a/collects/scheme/sandbox.ss b/collects/scheme/sandbox.ss index 4091527e49..64f89865a0 100644 --- a/collects/scheme/sandbox.ss +++ b/collects/scheme/sandbox.ss @@ -94,9 +94,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 +122,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 +155,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 +197,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 +209,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 @@ -526,6 +555,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)) @@ -707,7 +737,7 @@ (append (sandbox-override-collection-paths) (current-library-collection-paths)))] [sandbox-path-permissions - (append (map (lambda (p) `(read ,p)) + (append (map (lambda (p) `(read-bytecode ,p)) (current-library-collection-paths)) (compute-permissions allow) (sandbox-path-permissions))] @@ -716,24 +746,31 @@ ;; restrict the sandbox context from this point [current-security-guard (let ([g (sandbox-security-guard)]) (if (security-guard? g) g (g)))] + [current-logger ((sandbox-make-logger))] + [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 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) + (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 _ (terminated! 'exited) (user-kill)) h))] - [current-inspector ((sandbox-make-inspector))] - [current-logger ((sandbox-make-logger))] - [current-code-inspector (make-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. - [current-load/use-compiled - (let ([handler (current-load/use-compiled)]) - (lambda (path modname) - (parameterize ([current-code-inspector orig-code-inspector]) - (handler path modname))))] ;; 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 diff --git a/collects/scribblings/reference/sandbox.scrbl b/collects/scribblings/reference/sandbox.scrbl index 229f638c82..809e0d930d 100644 --- a/collects/scribblings/reference/sandbox.scrbl +++ b/collects/scribblings/reference/sandbox.scrbl @@ -443,7 +443,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 +453,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 +463,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.} @@ -582,7 +598,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/tests/mzscheme/sandbox.ss b/collects/tests/mzscheme/sandbox.ss index 855d14c798..4077bb651e 100644 --- a/collects/tests/mzscheme/sandbox.ss +++ b/collects/tests/mzscheme/sandbox.ss @@ -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-- @@ -391,7 +426,9 @@ [sandbox-memory-limit 5] [sandbox-eval-limits '(0.25 1/2)]) (make-evaluator 'scheme/base))) - ;; GCing is needed to allow these to happen + ;; GCing is needed to allow these to happen (note: the memory limit is very + ;; tight here, this test usually fails if the sandbox library is not + ;; compiled) --eval-- (display (make-bytes 400000 65)) (collect-garbage) --top-- (bytes-length (get-output ev)) => 400000 --eval-- (display (make-bytes 400000 65)) (collect-garbage) From a2ef8a5aaef1610f1c941de55525327c9690b648 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 15 Dec 2008 02:24:32 +0000 Subject: [PATCH 02/36] allow 'exists access to addon directory svn: r12847 --- collects/scheme/sandbox.ss | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/collects/scheme/sandbox.ss b/collects/scheme/sandbox.ss index 64f89865a0..b8413d0818 100644 --- a/collects/scheme/sandbox.ss +++ b/collects/scheme/sandbox.ss @@ -737,10 +737,11 @@ (append (sandbox-override-collection-paths) (current-library-collection-paths)))] [sandbox-path-permissions - (append (map (lambda (p) `(read-bytecode ,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 From 7107be309cc8a130e78e4ac11d9e6ecaa1a70206 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 15 Dec 2008 08:50:17 +0000 Subject: [PATCH 03/36] Welcome to a new PLT day. svn: r12849 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 642f4a8d72..050b20086b 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 "15dec2008") From fd95ebfe59682b7c2c31af9e8217302fe1df70af Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 15 Dec 2008 14:41:44 +0000 Subject: [PATCH 04/36] allow GC of custodians that have a memory limit but no children svn: r12850 --- src/mzscheme/src/salloc.c | 18 +++++++++++---- src/mzscheme/src/schpriv.h | 4 ++-- src/mzscheme/src/thread.c | 46 ++++++++++++++++++++++++++++++++------ 3 files changed, 55 insertions(+), 13 deletions(-) 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; } From b882de24090057c20d94309639505ede310a6563 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 15 Dec 2008 16:22:41 +0000 Subject: [PATCH 05/36] allow any number for memory limits svn: r12851 --- collects/scheme/sandbox.ss | 7 ++++-- collects/scribblings/reference/sandbox.scrbl | 23 ++++++++++---------- 2 files changed, 17 insertions(+), 13 deletions(-) diff --git a/collects/scheme/sandbox.ss b/collects/scheme/sandbox.ss index b8413d0818..d0decde7cf 100644 --- a/collects/scheme/sandbox.ss +++ b/collects/scheme/sandbox.ss @@ -302,7 +302,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]) @@ -709,7 +710,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] diff --git a/collects/scribblings/reference/sandbox.scrbl b/collects/scribblings/reference/sandbox.scrbl index 809e0d930d..4569f76b6b 100644 --- a/collects/scribblings/reference/sandbox.scrbl +++ b/collects/scribblings/reference/sandbox.scrbl @@ -506,29 +506,30 @@ 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 +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. See @scheme[sandbox-eval-limits] for per-evaluation limits and a description of how the two limits work together.} @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 From ab115fb6e447bf400a864b1b376c6187bd992b87 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 15 Dec 2008 16:26:25 +0000 Subject: [PATCH 06/36] default global limit is 30mb svn: r12852 --- collects/scheme/sandbox.ss | 2 +- collects/scribblings/reference/sandbox.scrbl | 5 +++-- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/collects/scheme/sandbox.ss b/collects/scheme/sandbox.ss index d0decde7cf..d8129d0977 100644 --- a/collects/scheme/sandbox.ss +++ b/collects/scheme/sandbox.ss @@ -58,7 +58,7 @@ (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)) diff --git a/collects/scribblings/reference/sandbox.scrbl b/collects/scribblings/reference/sandbox.scrbl index 4569f76b6b..79d0056261 100644 --- a/collects/scribblings/reference/sandbox.scrbl +++ b/collects/scribblings/reference/sandbox.scrbl @@ -512,8 +512,9 @@ 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. See @scheme[sandbox-eval-limits] for per-evaluation -limits and a description of how the two limits work together.} +afterwards. It defaults to 30mb. See @scheme[sandbox-eval-limits] +for per-evaluation limits and a description of how the two limits work +together.} @defparam[sandbox-eval-limits limits From 45e4684e4fe3fa5eac22d415cd765ec6e046884e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 15 Dec 2008 17:09:33 +0000 Subject: [PATCH 07/36] memory accounting: blame the parent instead of the child svn: r12853 --- collects/scheme/sandbox.ss | 2 +- .../scribblings/reference/custodians.scrbl | 21 +++++++++++-------- .../scribblings/reference/eval-model.scrbl | 10 +++++---- doc/release-notes/mzscheme/HISTORY.txt | 3 +++ src/mzscheme/gc2/Makefile.in | 2 +- .../gc2/{blame_the_child.c => mem_account.c} | 14 ++++--------- src/mzscheme/gc2/newgc.c | 6 +++--- 7 files changed, 30 insertions(+), 28 deletions(-) rename src/mzscheme/gc2/{blame_the_child.c => mem_account.c} (97%) diff --git a/collects/scheme/sandbox.ss b/collects/scheme/sandbox.ss index d8129d0977..46c241d02b 100644 --- a/collects/scheme/sandbox.ss +++ b/collects/scheme/sandbox.ss @@ -312,7 +312,7 @@ ;; 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 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/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/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/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..76ca9eaf45 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,7 @@ 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; - } - - /* 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 +442,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..479cb70c87 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 From 0cd1b5fea990b8fd1d2ed001be8bb858429f34d1 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 15 Dec 2008 17:13:44 +0000 Subject: [PATCH 08/36] * reorganize termination code a bit better * use it when the sandbox is being setup, so we catch an out of memory error at that time svn: r12854 --- collects/scheme/sandbox.ss | 60 +++++++++++++++++++++----------------- 1 file changed, 33 insertions(+), 27 deletions(-) diff --git a/collects/scheme/sandbox.ss b/collects/scheme/sandbox.ss index 46c241d02b..a1e2ab7191 100644 --- a/collects/scheme/sandbox.ss +++ b/collects/scheme/sandbox.ss @@ -312,7 +312,9 @@ ;; time limit (when sec (let ([t (current-thread)]) - (thread (lambda () (unless (sync/timeout sec t) (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 @@ -573,21 +575,25 @@ (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 (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))) + (define (terminated! reason) + (unless terminated? + (set! terminated? + (make-terminated + (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]) @@ -596,6 +602,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) @@ -627,27 +637,24 @@ (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 @@ -677,7 +684,7 @@ (let ([msg (evaluator-message-msg expr)]) (case msg [(alive?) (and user-thread (not (thread-dead? user-thread)))] - [(kill) (terminated! 'evaluator-killed) (user-kill)] + [(kill) (terminate+kill! 'evaluator-killed #f)] [(break) (user-break)] [(limits) (set! limits (evaluator-message-args expr))] [(input) (apply input-putter (evaluator-message-args expr))] @@ -773,7 +780,7 @@ [exit-handler (let ([h (sandbox-exit-handler)]) (if (eq? h default-sandbox-exit-handler) - (lambda _ (terminated! 'exited) (user-kill)) + (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 @@ -783,10 +790,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 From 04d0b55134a800f3ecdec1bbde0840d1cbc26f83 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 15 Dec 2008 18:18:06 +0000 Subject: [PATCH 09/36] raise the limit for the problematic test, and compensate by doing more iterations svn: r12855 --- collects/tests/mzscheme/sandbox.ss | 29 +++++++---------------------- 1 file changed, 7 insertions(+), 22 deletions(-) diff --git a/collects/tests/mzscheme/sandbox.ss b/collects/tests/mzscheme/sandbox.ss index 4077bb651e..64690bb356 100644 --- a/collects/tests/mzscheme/sandbox.ss +++ b/collects/tests/mzscheme/sandbox.ss @@ -423,32 +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 20] + [sandbox-eval-limits '(0.25 15)]) (make-evaluator 'scheme/base))) ;; 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) - --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 + (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) From b0758de6f171b2f5cb87e64fe3cbdd21b0049a16 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 15 Dec 2008 18:22:58 +0000 Subject: [PATCH 10/36] clarification on the (new) way memory is charged svn: r12856 --- collects/scribblings/reference/sandbox.scrbl | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/collects/scribblings/reference/sandbox.scrbl b/collects/scribblings/reference/sandbox.scrbl index 79d0056261..9bb614d03f 100644 --- a/collects/scribblings/reference/sandbox.scrbl +++ b/collects/scribblings/reference/sandbox.scrbl @@ -514,7 +514,14 @@ 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.} +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.} @defparam[sandbox-eval-limits limits From 5141289bd72282e246a359279337c8da518ae832 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 15 Dec 2008 18:29:59 +0000 Subject: [PATCH 11/36] * No nested code inspector for scribble sandboxes * No nested inspectors or memory limit for testing sandboxes svn: r12857 --- collects/scribble/eval.ss | 3 ++- collects/tests/mzscheme/testing.ss | 21 ++++++++++----------- 2 files changed, 12 insertions(+), 12 deletions(-) diff --git a/collects/scribble/eval.ss b/collects/scribble/eval.ss index 34c67f645c..5c2b193c2d 100644 --- a/collects/scribble/eval.ss +++ b/collects/scribble/eval.ss @@ -244,7 +244,8 @@ [sandbox-error-output 'string] [sandbox-eval-limits #f] [sandbox-memory-limit #f] - [sandbox-make-inspector current-inspector]) + [sandbox-make-inspector current-inspector] + [sandbox-make-code-inspector current-code-inspector]) (make-evaluator '(begin (require scheme/base))))) (define (close-eval e) diff --git a/collects/tests/mzscheme/testing.ss b/collects/tests/mzscheme/testing.ss index 318d9fdf8b..9ba18ea5c5 100644 --- a/collects/tests/mzscheme/testing.ss +++ b/collects/tests/mzscheme/testing.ss @@ -77,17 +77,16 @@ 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 (parameterize ([(S sandbox-security-guard) (current-security-guard)] + [(S sandbox-input) current-input-port] + [(S sandbox-output) current-output-port] + [(S sandbox-error-output) current-error-port] + [(S sandbox-make-inspector) current-inspector] + [(S sandbox-make-code-inspector) current-code-inspector] + [(S sandbox-memory-limit) 100] ; 100mb per box + [(S sandbox-eval-limits) #f]) + ((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)) From 1855d4fd851345a1db90a8a87704afc104e07915 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 15 Dec 2008 19:59:16 +0000 Subject: [PATCH 12/36] fix a problem in blame-the-parent accounting svn: r12858 --- src/mzscheme/gc2/mem_account.c | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/mzscheme/gc2/mem_account.c b/src/mzscheme/gc2/mem_account.c index 76ca9eaf45..c6c6208fbd 100644 --- a/src/mzscheme/gc2/mem_account.c +++ b/src/mzscheme/gc2/mem_account.c @@ -430,6 +430,11 @@ static void BTC_do_accounting(NewGC *gc) if(owner_table[i]) owner_table[i]->memory_use = 0; + /* start with root: */ + while (cur->parent && SCHEME_PTR1_VAL(cur->parent)) { + cur = SCHEME_PTR1_VAL(cur->parent); + } + /* walk forward for the order we want (blame parents instead of children) */ while(cur) { int owner = custodian_to_owner_set(gc, cur); From dcd1efe385ab6a399fe943f8828e63c08832d83c Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 15 Dec 2008 20:32:06 +0000 Subject: [PATCH 13/36] Updating docs svn: r12859 --- collects/html/html.scrbl | 20 ++++++++++++++++++-- 1 file changed, 18 insertions(+), 2 deletions(-) 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 From 0786da10cb386ee71637baca7a7a804a0cbf8239 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 15 Dec 2008 20:43:28 +0000 Subject: [PATCH 14/36] svn: r12860 --- collects/tests/mzscheme/sandbox.ss | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/tests/mzscheme/sandbox.ss b/collects/tests/mzscheme/sandbox.ss index 64690bb356..92b5a427f2 100644 --- a/collects/tests/mzscheme/sandbox.ss +++ b/collects/tests/mzscheme/sandbox.ss @@ -430,8 +430,8 @@ ;; 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))]) + (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))) From 25b27a8b08dfb06f57eea9ad4f0ce9098ae6c8b5 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 15 Dec 2008 21:15:24 +0000 Subject: [PATCH 15/36] more memory-accounting repairs, so that sandbox tests now pass svn: r12861 --- collects/tests/mzscheme/sandbox.ss | 12 ++++++---- src/mzscheme/gc2/gc2.h | 7 ++++++ src/mzscheme/gc2/newgc.c | 6 +++++ src/mzscheme/src/mzmark.c | 38 ++++++++++++++++++++---------- src/mzscheme/src/mzmarksrc.c | 19 ++++++++++----- 5 files changed, 60 insertions(+), 22 deletions(-) diff --git a/collects/tests/mzscheme/sandbox.ss b/collects/tests/mzscheme/sandbox.ss index 92b5a427f2..73db336351 100644 --- a/collects/tests/mzscheme/sandbox.ss +++ b/collects/tests/mzscheme/sandbox.ss @@ -152,7 +152,7 @@ (make-evaluator 'scheme/base '(define a (for/list ([i (in-range 10)]) (collect-garbage) - (make-string 1000)))))) + (make-string 500000)))))) =err> "out of memory")) ;; i/o @@ -488,9 +488,13 @@ --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: + (set! a (cons (make-bytes 500000) a)) + (collect-garbage) + ;; Increases size of evaluation: + (cons (make-bytes 500000) v))) =err> "out of memory" b => 1)) 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/newgc.c b/src/mzscheme/gc2/newgc.c index 479cb70c87..71c477963a 100644 --- a/src/mzscheme/gc2/newgc.c +++ b/src/mzscheme/gc2/newgc.c @@ -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: From f8dff60a0143aa9a56062d62c165eca9b90bb023 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 15 Dec 2008 21:32:50 +0000 Subject: [PATCH 16/36] adjust limits on tight test, others two, clarified comments svn: r12862 --- collects/tests/mzscheme/sandbox.ss | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/collects/tests/mzscheme/sandbox.ss b/collects/tests/mzscheme/sandbox.ss index 73db336351..8c7ff62a71 100644 --- a/collects/tests/mzscheme/sandbox.ss +++ b/collects/tests/mzscheme/sandbox.ss @@ -152,7 +152,7 @@ (make-evaluator 'scheme/base '(define a (for/list ([i (in-range 10)]) (collect-garbage) - (make-string 500000)))))) + (make-string 200000)))))) =err> "out of memory")) ;; i/o @@ -423,8 +423,8 @@ --top-- (set! ev (parameterize ([sandbox-output 'bytes] [sandbox-error-output current-output-port] - [sandbox-memory-limit 20] - [sandbox-eval-limits '(0.25 15)]) + [sandbox-memory-limit 2] + [sandbox-eval-limits '(0.25 1)]) (make-evaluator 'scheme/base))) ;; 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 @@ -490,10 +490,11 @@ (define b 1) (length (for/fold ([v null]) ([i (in-range 20)]) - ;; Increases size of sandbox: + ;; 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 evaluation: + ;; increases size of the current evaluation (cons (make-bytes 500000) v))) =err> "out of memory" b => 1)) From 43124c2ec505b3a0fad12d311826512e9c860370 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 15 Dec 2008 21:37:55 +0000 Subject: [PATCH 17/36] more adjustments svn: r12863 --- collects/tests/mzscheme/sandbox.ss | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/tests/mzscheme/sandbox.ss b/collects/tests/mzscheme/sandbox.ss index 8c7ff62a71..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 200000)))))) + (make-bytes 500000)))))) =err> "out of memory")) ;; i/o From e5027cb7b092bf590dd1141c57a0decee0e1ea4a Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 15 Dec 2008 22:15:52 +0000 Subject: [PATCH 18/36] added a clarifying example for how limits interact svn: r12864 --- collects/scribblings/reference/sandbox.scrbl | 18 +++++++++++++++++- 1 file changed, 17 insertions(+), 1 deletion(-) diff --git a/collects/scribblings/reference/sandbox.scrbl b/collects/scribblings/reference/sandbox.scrbl index 9bb614d03f..ef33f7ffd4 100644 --- a/collects/scribblings/reference/sandbox.scrbl +++ b/collects/scribblings/reference/sandbox.scrbl @@ -521,7 +521,23 @@ 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.} +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 From 768577fcaa8885c58f4bca9909678b64d52280ac Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 15 Dec 2008 23:15:27 +0000 Subject: [PATCH 19/36] fix-cairo-bitmap-release svn: r12865 --- src/wxxt/src/DeviceContexts/WindowDC.cc | 6 +++++- src/wxxt/src/wx_cairo.h | 2 ++ 2 files changed, 7 insertions(+), 1 deletion(-) 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 From bc81ac95f21aad242abd055ad97f29e117a2db04 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 16 Dec 2008 08:50:15 +0000 Subject: [PATCH 20/36] Welcome to a new PLT day. svn: r12866 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 050b20086b..1d6e8fc546 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "15dec2008") +#lang scheme/base (provide stamp) (define stamp "16dec2008") From 3f9f30fd4a5f4f2015d41b46c05586c9866dbf30 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 16 Dec 2008 16:03:30 +0000 Subject: [PATCH 21/36] strip mac binaries on install svn: r12867 --- src/mred/Makefile.in | 2 ++ src/mzscheme/Makefile.in | 2 ++ 2 files changed, 4 insertions(+) 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..713afe2af2 100644 --- a/src/mzscheme/Makefile.in +++ b/src/mzscheme/Makefile.in @@ -316,6 +316,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 +327,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 From 3e12b87cd3d089010b438b4441a29c9503d64c7e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 16 Dec 2008 16:08:02 +0000 Subject: [PATCH 22/36] strip starter exe (for Unix) on install svn: r12868 --- src/mzscheme/Makefile.in | 1 + 1 file changed, 1 insertion(+) diff --git a/src/mzscheme/Makefile.in b/src/mzscheme/Makefile.in index 713afe2af2..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)" From f74dc2b8c78bd373fc9d20e419b9fb5cb7a6d570 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 16 Dec 2008 20:29:17 +0000 Subject: [PATCH 23/36] Added `call-with-trusted-sandbox-configuration', and used in scribble and in tests. svn: r12871 --- collects/scheme/sandbox.ss | 13 ++++++++ collects/scribble/eval.ss | 15 ++++----- collects/scribblings/reference/sandbox.scrbl | 35 +++++++++++++++----- collects/tests/mzscheme/testing.ss | 15 ++++----- 4 files changed, 52 insertions(+), 26 deletions(-) diff --git a/collects/scheme/sandbox.ss b/collects/scheme/sandbox.ss index a1e2ab7191..5b2424e81f 100644 --- a/collects/scheme/sandbox.ss +++ b/collects/scheme/sandbox.ss @@ -25,6 +25,7 @@ sandbox-make-logger sandbox-memory-limit sandbox-eval-limits + call-with-trusted-sandbox-configuration evaluator-alive? kill-evaluator break-evaluator @@ -63,6 +64,18 @@ (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 (current-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 |#))) diff --git a/collects/scribble/eval.ss b/collects/scribble/eval.ss index 5c2b193c2d..bfac65d473 100644 --- a/collects/scribble/eval.ss +++ b/collects/scribble/eval.ss @@ -239,19 +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] - [sandbox-make-code-inspector current-code-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/reference/sandbox.scrbl b/collects/scribblings/reference/sandbox.scrbl index ef33f7ffd4..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)]{ diff --git a/collects/tests/mzscheme/testing.ss b/collects/tests/mzscheme/testing.ss index 9ba18ea5c5..cb60a31e5a 100644 --- a/collects/tests/mzscheme/testing.ss +++ b/collects/tests/mzscheme/testing.ss @@ -78,15 +78,12 @@ transcript. (define (load-in-sandbox file) (define-syntax-rule (S id) (dynamic-require 'scheme/sandbox 'id)) - (let ([e (parameterize ([(S sandbox-security-guard) (current-security-guard)] - [(S sandbox-input) current-input-port] - [(S sandbox-output) current-output-port] - [(S sandbox-error-output) current-error-port] - [(S sandbox-make-inspector) current-inspector] - [(S sandbox-make-code-inspector) current-code-inspector] - [(S sandbox-memory-limit) 100] ; 100mb per box - [(S sandbox-eval-limits) #f]) - ((S make-evaluator) '(begin) #:requires (list 'scheme)))]) + (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)) From aa749bfe1f82fe0a145462435ca5a1772d7b0d21 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 16 Dec 2008 20:57:52 +0000 Subject: [PATCH 24/36] changed the memory limits in drscheme to match the new way they work svn: r12873 --- collects/drscheme/private/main.ss | 4 ++-- collects/drscheme/private/rep.ss | 6 +++--- collects/drscheme/private/unit.ss | 8 ++++---- collects/string-constants/english-string-constants.ss | 2 +- collects/string-constants/french-string-constants.ss | 2 +- collects/string-constants/german-string-constants.ss | 2 +- collects/string-constants/japanese-string-constants.ss | 2 +- .../simplified-chinese-string-constants.ss | 2 +- .../traditional-chinese-string-constants.ss | 2 +- 9 files changed, 15 insertions(+), 15 deletions(-) diff --git a/collects/drscheme/private/main.ss b/collects/drscheme/private/main.ss index f42f04ab56..5f766ce8f5 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 64) (λ (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..96af29feff 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 (+ (* 1024 1024 32) 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/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") From efd7446b0943f00342a3b4401815ae675dc2d7dc Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 17 Dec 2008 00:04:20 +0000 Subject: [PATCH 25/36] current-exit-handler => exit-handler svn: r12874 --- collects/scheme/sandbox.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scheme/sandbox.ss b/collects/scheme/sandbox.ss index 5b2424e81f..cb8d297294 100644 --- a/collects/scheme/sandbox.ss +++ b/collects/scheme/sandbox.ss @@ -68,7 +68,7 @@ (parameterize ([sandbox-propagate-breaks #t] [sandbox-override-collection-paths '()] [sandbox-security-guard current-security-guard] - [sandbox-exit-handler (current-exit-handler)] + [sandbox-exit-handler (exit-handler)] [sandbox-make-inspector current-inspector] [sandbox-make-code-inspector current-code-inspector] [sandbox-make-logger current-logger] From ed7713751a021a6f57ef89c8bf86194e2fad568d Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 17 Dec 2008 08:50:11 +0000 Subject: [PATCH 26/36] Welcome to a new PLT day. svn: r12875 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 1d6e8fc546..c0fa768946 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "16dec2008") +#lang scheme/base (provide stamp) (define stamp "17dec2008") From 1d85f9ff3c9ea929e26567d0ec65b6fba5bb383a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 17 Dec 2008 13:05:35 +0000 Subject: [PATCH 27/36] patch for better #includes in XPM src from Michal Vyskocil svn: r12876 --- src/wxxt/contrib/xpm/lib/CrBufFrI.c | 2 +- src/wxxt/contrib/xpm/lib/CrDatFrI.c | 2 +- src/wxxt/contrib/xpm/lib/WrFFrBuf.c | 5 +++++ src/wxxt/contrib/xpm/lib/WrFFrI.c | 5 +++++ src/wxxt/contrib/xpm/lib/create.c | 5 +++++ src/wxxt/contrib/xpm/lib/data.c | 5 +++++ src/wxxt/contrib/xpm/lib/hashtab.c | 5 +++++ src/wxxt/contrib/xpm/lib/parse.c | 5 +++++ src/wxxt/contrib/xpm/lib/rgb.c | 2 +- 9 files changed, 33 insertions(+), 3 deletions(-) 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 From 3eb23594983d7ec01998fd49ecd1b40d4b88a6ce Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 17 Dec 2008 15:42:33 +0000 Subject: [PATCH 28/36] change memory limit defaults svn: r12878 --- collects/drscheme/private/main.ss | 2 +- collects/drscheme/private/rep.ss | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/drscheme/private/main.ss b/collects/drscheme/private/main.ss index 5f766ce8f5..55ca8ff9d6 100644 --- a/collects/drscheme/private/main.ss +++ b/collects/drscheme/private/main.ss @@ -94,7 +94,7 @@ (number? (car x)) (number? (cdr x)))))) -(preferences:set-default 'drscheme:child-only-memory-limit (* 1024 1024 64) +(preferences:set-default 'drscheme:child-only-memory-limit (* 1024 1024 128) (λ (x) (or (boolean? x) (integer? x) (x . >= . (* 1024 1024 1))))) diff --git a/collects/drscheme/private/rep.ss b/collects/drscheme/private/rep.ss index 96af29feff..8b15e0b73b 100644 --- a/collects/drscheme/private/rep.ss +++ b/collects/drscheme/private/rep.ss @@ -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 32) custodian-limit))] + (let* ([new-limit (and custodian-limit (+ custodian-limit custodian-limit))] [ans (message-box/custom (string-constant evaluation-terminated) (string-append From ab18970f67ed79761358066dab486abb83871b1e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 17 Dec 2008 20:44:28 +0000 Subject: [PATCH 29/36] fix ffi passing offset null pointer svn: r12879 --- src/foreign/foreign.c | 4 ++-- src/foreign/foreign.ssc | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/foreign/foreign.c b/src/foreign/foreign.c index 3a7628ca28..ae7d050e1e 100644 --- a/src/foreign/foreign.c +++ b/src/foreign/foreign.c @@ -2347,7 +2347,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 +2370,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 Date: Thu, 18 Dec 2008 02:52:45 +0000 Subject: [PATCH 30/36] reference and ffi corrections and clarifications svn: r12880 --- collects/scribblings/foreign/types.scrbl | 16 +++++++++------- .../scribblings/reference/security-guards.scrbl | 4 ++-- 2 files changed, 11 insertions(+), 9 deletions(-) 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/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]. From c71889c7051d47aaa958ebe9e007664f804940e1 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 18 Dec 2008 04:03:21 +0000 Subject: [PATCH 31/36] minor changes to have foreign.c in sync with foreign.ssc svn: r12881 --- src/foreign/foreign.ssc | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/foreign/foreign.ssc b/src/foreign/foreign.ssc index 64b4f58300..b7fd9cc618 100755 --- a/src/foreign/foreign.ssc +++ b/src/foreign/foreign.ssc @@ -1677,6 +1677,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 +1710,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)":} { @@ -1961,7 +1961,7 @@ typedef struct closure_and_cif_struct { void free_cl_cif_args(void *ignored, void *p) { /* - scheme_warning("Releaseing cl+cif+args %V %V (%d)", + scheme_warning("Releasing cl+cif+args %V %V (%d)", ignored, (((closure_and_cif*)p)->data), SAME_OBJ(ignored,(((closure_and_cif*)p)->data))); From 6283205982477aec904affbffa8eab57d239dd31 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 18 Dec 2008 06:48:10 +0000 Subject: [PATCH 32/36] ctype-basetype now holds: * a symbol naming the type for primitive types * a list of ctypes for cstruct types * another ctype for user-defined ctypes svn: r12882 --- collects/mzlib/foreign.ss | 2 +- src/foreign/foreign.c | 105 ++++++++++++++++++++++++-------------- src/foreign/foreign.ssc | 47 +++++++++++------ 3 files changed, 98 insertions(+), 56 deletions(-) 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/src/foreign/foreign.c b/src/foreign/foreign.c index ae7d050e1e..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 @@ -2632,6 +2635,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); ffi_lib_tag = scheme_make_type(""); 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 b7fd9cc618..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 @@ -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);")):} From c1123547e46f192dbc0e3453a34cc8ba3f90ad39 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 18 Dec 2008 06:49:51 +0000 Subject: [PATCH 33/36] document basetype change svn: r12883 --- collects/scribblings/foreign/unexported.scrbl | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) 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?] From 7dc5bd7a740476dc0d43102713c839cc96b0bb99 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 18 Dec 2008 08:50:12 +0000 Subject: [PATCH 34/36] Welcome to a new PLT day. svn: r12884 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index c0fa768946..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 "17dec2008") +#lang scheme/base (provide stamp) (define stamp "18dec2008") From 0c85f221bed628651e8900aafca0a9831b03aad4 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 18 Dec 2008 13:35:49 +0000 Subject: [PATCH 35/36] Added: sandbox-eval-handlers set-eval-handler call-with-custodian-shutdown call-with-killing-threads Added optional `unrestricted?' argument to `call-in-sandbox-context' svn: r12885 --- collects/scheme/sandbox.ss | 66 ++++++++++++++++++++++++++++---------- 1 file changed, 49 insertions(+), 17 deletions(-) diff --git a/collects/scheme/sandbox.ss b/collects/scheme/sandbox.ss index cb8d297294..b35884b4e8 100644 --- a/collects/scheme/sandbox.ss +++ b/collects/scheme/sandbox.ss @@ -25,11 +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 @@ -362,6 +364,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) @@ -555,6 +579,7 @@ (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) @@ -585,13 +610,18 @@ (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))]) - (if (or sec mb) (lambda () (call-with-limits sec mb thunk)) thunk))) + [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? @@ -632,6 +662,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 () @@ -641,13 +672,13 @@ (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 () - (set! n (add1 n)) - (eval* (input->code (list expr) 'eval n)))))) + (restrict-thunk (if (evaluator-message? expr) + (lambda () + (apply (evaluator-message-msg expr) + (evaluator-message-args expr))) + (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) @@ -696,16 +727,17 @@ (if (evaluator-message? expr) (let ([msg (evaluator-message-msg expr)]) (case msg - [(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))] - [(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) (user-eval (make-evaluator-message + (car (evaluator-message-args expr)) '()))] [else (error 'evaluator "internal error, bad message: ~e" msg)])) (user-eval expr))) (define (make-output what out set-out! allow-link?) From 11107f4e22a4d2b1efead7284b1ce4af9ac982e7 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 18 Dec 2008 13:43:59 +0000 Subject: [PATCH 36/36] (Second part of the previous commit) svn: r12886 --- collects/scheme/sandbox.ss | 27 +++++++++++++++------------ 1 file changed, 15 insertions(+), 12 deletions(-) diff --git a/collects/scheme/sandbox.ss b/collects/scheme/sandbox.ss index b35884b4e8..32039f1e3f 100644 --- a/collects/scheme/sandbox.ss +++ b/collects/scheme/sandbox.ss @@ -42,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? @@ -584,8 +586,9 @@ (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) @@ -672,13 +675,14 @@ (with-handlers ([void (lambda (exn) (channel-put result-ch (cons 'exn exn)))]) (define run - (restrict-thunk (if (evaluator-message? expr) - (lambda () - (apply (evaluator-message-msg expr) - (evaluator-message-args expr))) - (lambda () - (set! n (add1 n)) - (eval* (input->code (list expr) 'eval n)))))) + (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) @@ -713,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)] @@ -736,8 +740,7 @@ [(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?)