diff --git a/collects/compiler/embed-unit.ss b/collects/compiler/embed-unit.ss index 3411da22db..9d93cee0f7 100644 --- a/collects/compiler/embed-unit.ss +++ b/collects/compiler/embed-unit.ss @@ -740,7 +740,7 @@ ;; Write a module bundle that can be loaded with 'load' (do not embed it ;; into an executable). The bundle is written to the current output port. - (define (do-write-module-bundle verbose? modules literal-files literal-expressions collects-dest + (define (do-write-module-bundle outp verbose? modules literal-files literal-expressions collects-dest on-extension program-name compiler expand-namespace src-filter get-extra-imports) (let* ([module-paths (map cadr modules)] @@ -778,11 +778,11 @@ ;; Drop elements of `codes' that just record copied libs: (set-box! codes (filter mod-code (unbox codes))) ;; Bind `module' to get started: - (write (compile-using-kernel '(namespace-require '(only '#%kernel module)))) + (write (compile-using-kernel '(namespace-require '(only '#%kernel module))) outp) ;; Install a module name resolver that redirects ;; to the embedded modules - (write (make-module-name-resolver (filter mod-code (unbox codes)))) - (write (compile-using-kernel '(namespace-require ''#%resolver))) + (write (make-module-name-resolver (filter mod-code (unbox codes))) outp) + (write (compile-using-kernel '(namespace-require ''#%resolver)) outp) ;; Write the extension table and copy module code: (let* ([l (reverse (unbox codes))] [extensions (filter (lambda (m) (extension? (mod-code m))) l)] @@ -825,15 +825,17 @@ (path->complete-path p (current-directory)))) (current-directory d))) p)))) - eXtEnSiOn-modules)))) - (write (compile-using-kernel '(namespace-require ''#%extension-table)))) + eXtEnSiOn-modules))) + outp) + (write (compile-using-kernel '(namespace-require ''#%extension-table)) outp)) ;; Runtime-path table: (unless (null? runtimes) (unless table-mod (error 'create-embedding-executable "cannot find module for runtime-path table")) (write (compile-using-kernel `(current-module-declare-name (make-resolved-module-path - ',(mod-full-name table-mod))))) + ',(mod-full-name table-mod)))) + outp) (write `(module runtime-path-table '#%kernel (#%provide table) (define-values (table) @@ -884,7 +886,8 @@ (bytes-append #"................." (path->bytes program-name)))) (mod-runtime-paths nc))) runtimes))]) - rUnTiMe-paths)))))) + rUnTiMe-paths)))) + outp)) ;; Copy module code: (for-each (lambda (nc) @@ -895,26 +898,27 @@ (write (compile-using-kernel `(current-module-declare-name (make-resolved-module-path - ',(mod-full-name nc))))) + ',(mod-full-name nc)))) + outp) (if (src-filter (mod-file nc)) - (with-input-from-file (mod-file nc) - (lambda () - (copy-port (current-input-port) (current-output-port)))) - (write (mod-code nc))))) + (call-with-input-file* (mod-file nc) + (lambda (inp) + (copy-port inp outp))) + (write (mod-code nc) outp)))) l)) - (write (compile-using-kernel '(current-module-declare-name #f))) + (write (compile-using-kernel '(current-module-declare-name #f)) outp) ;; Remove `module' binding before we start running user code: - (write (compile-using-kernel '(namespace-set-variable-value! 'module #f #t))) - (write (compile-using-kernel '(namespace-undefine-variable! 'module))) - (newline) + (write (compile-using-kernel '(namespace-set-variable-value! 'module #f #t)) outp) + (write (compile-using-kernel '(namespace-undefine-variable! 'module)) outp) + (newline outp) (for-each (lambda (f) (when verbose? (fprintf (current-error-port) "Copying from ~s~n" f)) (call-with-input-file* f (lambda (i) - (copy-port i (current-output-port))))) + (copy-port i outp)))) literal-files) - (for-each write literal-expressions))) + (for-each (lambda (v) (write v outp)) literal-expressions))) (define (write-module-bundle #:verbose? [verbose? #f] #:modules [modules null] @@ -927,7 +931,7 @@ (compile expr)))] #:src-filter [src-filter (lambda (filename) #f)] #:get-extra-imports [get-extra-imports (lambda (filename code) null)]) - (do-write-module-bundle verbose? modules literal-files literal-expressions + (do-write-module-bundle (current-output-port) verbose? modules literal-files literal-expressions #f ; collects-dest on-extension "?" ; program-name @@ -1072,8 +1076,9 @@ (path->complete-path orig-exe))]) (update-dll-dir dest (build-path orig-dir dir)))))))) (let ([write-module - (lambda () - (do-write-module-bundle verbose? modules literal-files literal-expressions collects-dest + (lambda (s) + (do-write-module-bundle s + verbose? modules literal-files literal-expressions collects-dest on-extension (file-name-from-path dest) compiler @@ -1085,16 +1090,15 @@ (not unix-starter?)) ;; For Mach-O, we know how to add a proper segment (let ([s (open-output-bytes)]) - (parameterize ([current-output-port s]) - (write-module)) + (write-module s) (let ([s (get-output-bytes s)]) (let ([start (add-plt-segment dest-exe s)]) (values start (+ start (bytes-length s)))))) ;; Other platforms: just add to the end of the file: (let ([start (file-size dest-exe)]) - (with-output-to-file dest-exe write-module - #:exists 'append) + (call-with-output-file* dest-exe write-module + #:exists 'append) (values start (file-size dest-exe))))]) (when verbose? (fprintf (current-error-port) "Setting command line~n")) diff --git a/collects/handin-server/checker.ss b/collects/handin-server/checker.ss index ed589110e2..8d7e7e2b0c 100644 --- a/collects/handin-server/checker.ss +++ b/collects/handin-server/checker.ss @@ -1,6 +1,7 @@ #lang scheme/base -(require (for-syntax scheme/base) "utils.ss" scheme/file scheme/list scheme/class mred) +(require (for-syntax scheme/base) "utils.ss" + scheme/file scheme/list scheme/class mred) (provide (except-out (all-from-out scheme/base) #%module-begin) (all-from-out "utils.ss")) @@ -654,8 +655,21 @@ (define (get-namespace evaluator) (call-in-sandbox-context evaluator (lambda () (current-namespace)))) +;; checks that ids are defined, either as variables or syntaxes (provide !defined) (define-syntax-rule (!defined id ...) + ;; expected to be used only with identifiers + (begin (with-handlers ([exn:fail:contract:variable? + (lambda (_) + (error* "missing binding: ~e" (->disp 'id)))] + [exn:fail:syntax? void]) + (parameterize ([current-namespace (get-namespace (submission-eval))]) + (namespace-variable-value `id))) + ...)) + +;; checks that ids are defined as variables, not syntaxes +(provide !bound) +(define-syntax-rule (!bound id ...) ;; expected to be used only with identifiers (begin (with-handlers ([exn:fail:contract:variable? (lambda (_) @@ -668,6 +682,7 @@ (namespace-variable-value `id))) ...)) +;; checks that ids are defined as syntaxes, not variables (provide !syntax) (define-syntax-rule (!syntax id ...) ;; expected to be used only with identifiers @@ -726,11 +741,10 @@ (define-syntax (!test/exn stx) (syntax-case stx () [(_ test-exp) - #`(unless - (with-handlers ([exn:fail? (lambda (exn) #t)]) - ((submission-eval) `test-exp) - #f) - (error* "expected exception on test expression: ~v" + #`(unless (with-handlers ([exn:fail? (lambda (exn) #t)]) + ((submission-eval) `test-exp) + #f) + (error* "expected exception on test expression: ~v" (->disp 'test-exp)))])) (provide !all-covered) diff --git a/collects/handin-server/scribblings/checker.scrbl b/collects/handin-server/scribblings/checker.scrbl index ea11d2bb44..7eb714f4d2 100644 --- a/collects/handin-server/scribblings/checker.scrbl +++ b/collects/handin-server/scribblings/checker.scrbl @@ -16,7 +16,7 @@ language module---a typical checker that uses it looks like this: @schemeblock[ (module checker (lib "checker.ss" "handin-server") - (check: :language 'intermediate + (check: :language '(special intermediate) :users pairs-or-singles-with-warning :coverage? #t (!procedure Fahrenheit->Celsius 1) @@ -327,16 +327,20 @@ code.} @defform[(!defined id ...)]{ Checks that the given identifiers are defined in the (evaluated) - submission, and throws an error otherwise.} + submission, and throws an error otherwise. The identifiers can be + bound as either a plain value or as a syntax.} -@defform[(!procedure id arity)]{ - - Checks that @scheme[id] is defined, and is bound to a procedure.} +@defform[(!bound id ...)]{ + Checks that the given identifiers are defined in the (evaluated) + submission as a plain value. Throws an error if not, or if an + identifier is bound to a syntax.} @defform[(!syntax id arity)]{ - Checks that @scheme[id] is defined, and is bound as a macro.} +@defform[(!procedure id arity)]{ + Checks that @scheme[id] is defined, and is bound to a procedure.} + @defform[(!procedure* expr arity)]{ Similar to @scheme[!procedure] but omits the defined check, making @@ -350,13 +354,16 @@ code.} integers.} @defform*[((!test expr) + (!test/exn expr) (!test expr result) (!test expr result equal?))]{ The first form checks that the given expression evaluates to a non-@scheme[#f] value in the submission context, throwing an error - otherwise. The second form compares the result of evaluation, - requiring it to be equal to @scheme[result]. The third allows + otherwise. The second form checks that the given expression throws + an @scheme[exn:fail?] error, throwing an error otherwise. + The third form compares the result of evaluation, + requiring it to be equal to @scheme[result]. The fourth allows specifying an equality procedure. Note that the @scheme[result] and @scheme[equal?] forms are @italic{not} evaluated in the submission context.} diff --git a/collects/lang/htdp-reader.ss b/collects/lang/htdp-reader.ss index 0afea114d6..86f1e9f6d8 100644 --- a/collects/lang/htdp-reader.ss +++ b/collects/lang/htdp-reader.ss @@ -41,6 +41,8 @@ `(module ,modname ,spec ,@(map (λ (x) `(require ,x)) (lookup 'teachpacks table)) - ,@(parameterize ([read-case-sensitive (lookup 'read-case-sensitive table)]) + ,@(parameterize ([read-case-sensitive (lookup 'read-case-sensitive table)] + [read-decimal-as-inexact #f] + [read-accept-dot #f]) (get-all-exps source-name port))))))]) read-syntax))) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 03bdd9a5d8..8ae3156285 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "10dec2008") +#lang scheme/base (provide stamp) (define stamp "12dec2008") diff --git a/collects/scheme/sandbox.ss b/collects/scheme/sandbox.ss index 71bceafb46..fcef51338a 100644 --- a/collects/scheme/sandbox.ss +++ b/collects/scheme/sandbox.ss @@ -21,7 +21,9 @@ sandbox-network-guard sandbox-make-inspector sandbox-make-logger + sandbox-memory-limit sandbox-eval-limits + evaluator-alive? kill-evaluator break-evaluator set-eval-limits @@ -52,6 +54,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-eval-limits (make-parameter '(30 20))) ; 30sec, 20mb (define sandbox-propagate-breaks (make-parameter #t)) (define sandbox-coverage-enabled (make-parameter #f)) @@ -149,6 +152,11 @@ (define sandbox-make-logger (make-parameter current-logger)) +(define (compute-permissions paths+require-perms) + (let-values ([(paths require-perms) (partition path? paths+require-perms)]) + (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) (define (module-specs->path-permissions mods) @@ -215,49 +223,73 @@ ;; similar to `call-in-nested-thread', but propagates killing the thread, ;; shutting down the custodian or setting parameters and thread cells; -;; optionally with thunks to call for kill/shutdown. +;; optionally with thunks to call for kill/shutdown instead. (define (call-in-nested-thread* thunk [kill (lambda () (kill-thread (current-thread)))] [shutdown (lambda () (custodian-shutdown-all (current-custodian)))]) (let* ([p #f] - [c (make-custodian)] - [b (make-custodian-box c #t)]) - (with-handlers ([(lambda (_) (not p)) - ;; if the after thunk was not called, then this error is - ;; about the thread dying unnaturally, so propagate - ;; whatever it did - (lambda (_) ((if (custodian-box-value b) kill shutdown)))]) - (dynamic-wind void - (lambda () - (parameterize ([current-custodian c]) - (call-in-nested-thread - (lambda () - (dynamic-wind void thunk - ;; this should always be called unless the thread is killed or - ;; the custodian is shutdown, distinguish the two cases - ;; through the above box - (lambda () - (set! p (current-preserved-thread-cell-values)))))))) - (lambda () (when p (current-preserved-thread-cell-values p))))))) + [c (make-custodian (current-custodian))] + [b (make-custodian-box c #t)] + [break? (break-enabled)]) + (parameterize-break #f + (with-handlers ([(lambda (_) (not p)) + ;; if the after thunk was not called, then this error is + ;; about the thread dying unnaturally, so propagate + ;; whatever it did + (lambda (_) + ((if (custodian-box-value b) kill shutdown)))]) + (dynamic-wind void + (lambda () + (parameterize ([current-custodian c]) + (call-in-nested-thread + (lambda () + (break-enabled break?) + (dynamic-wind void thunk + ;; this should always be called unless the thread is killed + ;; or the custodian is shutdown, distinguish the two cases + ;; through the above box + (lambda () + (set! p (current-preserved-thread-cell-values)))))))) + (lambda () (when p (current-preserved-thread-cell-values p)))))))) (define (call-with-limits sec mb thunk) ;; note that when the thread is killed after using too much memory or time, ;; then all thread-local changes (parameters and thread cells) are discarded (let ([r #f]) - (call-in-nested-thread* - (lambda () - ;; memory limit - (when (and mb memory-accounting?) - (custodian-limit-memory (current-custodian) (* mb 1024 1024))) - ;; time limit - (when sec - (let ([t (current-thread)]) - (thread (lambda () (sleep sec) (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)))))) - (lambda () (unless r (set! r 'kill))) - (lambda () (unless r (set! r 'shut)))) + ;; memory limit, set on a new custodian so if there's an out-of-memory + ;; error, the user's custodian is still alive + (define-values (cust cust-box) + (if (and mb memory-accounting?) + (let ([c (make-custodian (current-custodian))]) + (custodian-limit-memory c (* mb 1024 1024) c) + (values c (make-custodian-box c #t))) + (values (current-custodian) #f))) + (parameterize ([current-custodian cust]) + (call-in-nested-thread* + (lambda () + ;; time limit + (when sec + (let ([t (current-thread)]) + (thread (lambda () (sleep sec) (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 + ;; call-in-nested-thread* kill it -- if user code did so, then just + ;; register the request and kill it below. Do this for a + ;; custodian-shutdown to, just in case. + (lambda () + (unless r (set! r 'kill)) + ;; (kill-thread (current-thread)) + ) + (lambda () + (unless r (set! r 'shut)) + ;; (custodian-shutdown-all (current-custodian)) + ))) + (when (and cust-box (not (custodian-box-value cust-box))) + (if (memq r '(kill shut)) ; should always be 'shut + (set! r 'memory) + (format "cust died with: ~a" r))) ; throw internal error below (case r [(kill) (kill-thread (current-thread))] [(shut) (custodian-shutdown-all (current-custodian))] @@ -317,23 +349,25 @@ ;; (path/string/bytes) value. (define (input->code inps source n) (if (null? inps) - '() - (let ([p (input->port (car inps))]) - (cond [(and p (null? (cdr inps))) - (port-count-lines! p) - (parameterize ([current-input-port p]) - ((sandbox-reader) source))] - [p (error 'input->code "ambiguous inputs: ~e" inps)] - [else (let loop ([inps inps] [n n] [r '()]) - (if (null? inps) - (reverse r) - (loop (cdr inps) (and n (add1 n)) - ;; 1st at line#1, pos#1, 2nd at line#2, pos#2 etc - ;; (starting from the `n' argument) - (cons (datum->syntax - #f (car inps) - (list source n (and n 0) n (and n 1))) - r))))])))) + '() + (let ([p (input->port (car inps))]) + (cond [(and p (null? (cdr inps))) + (port-count-lines! p) + (parameterize ([current-input-port p]) + (begin0 ((sandbox-reader) source) + ;; close a port if we opened it + (unless (eq? p (car inps)) (close-input-port p))))] + [p (error 'input->code "ambiguous inputs: ~e" inps)] + [else (let loop ([inps inps] [n n] [r '()]) + (if (null? inps) + (reverse r) + (loop (cdr inps) (and n (add1 n)) + ;; 1st at line#1, pos#1, 2nd at line#2, pos#2 etc + ;; (starting from the `n' argument) + (cons (datum->syntax + #f (car inps) + (list source n (and n 0) n (and n 1))) + r))))])))) (define ((init-for-language language)) (cond [(or (not (pair? language)) @@ -353,7 +387,7 @@ ;; ;; FIXME: inserting `#%require's here is bad if the language has a ;; `#%module-begin' that processes top-level forms specially. -;; A more general solution would be to create anew module that exports +;; A more general solution would be to create a new module that exports ;; the given language plus all of the given extra requires. ;; ;; We use `#%requre' because, unlike the `require' of scheme/base, @@ -448,6 +482,7 @@ (let ([evmsg (make-evaluator-message msg '())]) (lambda (evaluator) (evaluator evmsg))))])) +(define-evaluator-messenger evaluator-alive? 'alive?) (define-evaluator-messenger kill-evaluator 'kill) (define-evaluator-messenger break-evaluator 'break) (define-evaluator-messenger (set-eval-limits secs mb) 'limits) @@ -457,8 +492,11 @@ (define-evaluator-messenger (get-uncovered-expressions . xs) 'uncovered) (define-evaluator-messenger (call-in-sandbox-context thunk) 'thunk) -(define (make-evaluator* init-hook require-perms program-maker) - (define user-cust (make-custodian)) +(define (make-evaluator* init-hook allow program-maker) + (define orig-cust (current-custodian)) + (define memory-cust (make-custodian orig-cust)) + (define memory-cust-box (make-custodian-box memory-cust #t)) + (define user-cust (make-custodian memory-cust)) (define coverage? (sandbox-coverage-enabled)) (define uncovered #f) (define input-ch (make-channel)) @@ -469,7 +507,6 @@ (define limits (sandbox-eval-limits)) (define user-thread #t) ; set later to the thread (define user-done-evt #t) ; set in the same place - (define orig-cust (current-custodian)) (define (limit-thunk thunk) (let* ([sec (and limits (car limits))] [mb (and limits (cadr limits))]) @@ -523,7 +560,9 @@ (loop))]) (sync user-done-evt result-ch)))) eof)]) - (cond [(eof-object? r) (error 'evaluator "terminated")] + (cond [(eof-object? r) (error 'evaluator "terminated~a" + (if (custodian-box-value memory-cust-box) + "" " (memory exceeded)"))] [(eq? (car r) 'exn) (raise (cdr r))] [else (apply values (cdr r))]))) (define get-uncovered @@ -552,6 +591,7 @@ (if (evaluator-message? expr) (let ([msg (evaluator-message-msg expr)]) (case msg + [(alive?) (and user-thread (not (thread-dead? user-thread)))] [(kill) (user-kill)] [(break) (user-break)] [(limits) (set! limits (evaluator-message-args expr))] @@ -582,6 +622,10 @@ (if bytes? buf (bytes->string/utf-8 buf #\?))))) out)] [else (error 'make-evaluator "bad sandox-~a spec: ~e" what out)])) + ;; set global memory limit + (when (sandbox-memory-limit) + (custodian-limit-memory + memory-cust (* (sandbox-memory-limit) 1024 1024) memory-cust)) (parameterize* ; the order in these matters (;; create a sandbox context first [current-custodian user-cust] @@ -611,7 +655,7 @@ [sandbox-path-permissions (append (map (lambda (p) `(read ,p)) (current-library-collection-paths)) - (module-specs->path-permissions require-perms) + (compute-permissions allow) (sandbox-path-permissions))] ;; general info [current-command-line-arguments '#()] @@ -633,10 +677,10 @@ (set! user-done-evt (handle-evt user-thread (lambda (_) (user-kill) eof))) (let ([r (channel-get result-ch)]) (if (eq? r 'ok) - ;; initial program executed ok, so return an evaluator - evaluator - ;; program didn't execute - (raise r))))) + ;; initial program executed ok, so return an evaluator + evaluator + ;; program didn't execute + (raise r))))) (define (make-evaluator language #:requires [requires null] #:allow-read [allow null] @@ -654,8 +698,7 @@ `(file ,(path->string (simplify-path* r))))) requires))]) (make-evaluator* (init-for-language lang) - (append (extract-required (or (decode-language lang) - lang) + (append (extract-required (or (decode-language lang) lang) reqs) allow) (lambda () (build-program lang reqs input-program))))) @@ -679,5 +722,6 @@ (syntax->datum #'lang) reqlang))] [_else (error 'make-evaluator "expecting a `module' program; got ~e" (syntax->datum (car prog)))]))) - (make-evaluator* void allow make-program)) - + (make-evaluator* void + (if (path? input-program) (cons input-program allow) allow) + make-program)) diff --git a/collects/scribble/eval.ss b/collects/scribble/eval.ss index 309764eb04..34c67f645c 100644 --- a/collects/scribble/eval.ss +++ b/collects/scribble/eval.ss @@ -243,6 +243,7 @@ [sandbox-output 'string] [sandbox-error-output 'string] [sandbox-eval-limits #f] + [sandbox-memory-limit #f] [sandbox-make-inspector current-inspector]) (make-evaluator '(begin (require scheme/base))))) diff --git a/collects/scribble/reader.ss b/collects/scribble/reader.ss index ec37774123..802fe119f6 100644 --- a/collects/scribble/reader.ss +++ b/collects/scribble/reader.ss @@ -65,8 +65,8 @@ (define (internal-error label) (error 'scribble-reader "internal error [~a]" label)) -;; like `regexp-match/fail-without-reading', without extras; the regexp that -;; is used must be anchored -- nothing is dropped +;; like `regexp-try-match', without extras; the regexp that is used +;; must be anchored -- nothing is dropped (define (*regexp-match-peek-positions pattern input-port) #; ; sanity checks, not needed unless this file is edited (unless (and (byte-regexp? pattern) diff --git a/collects/scribblings/reference/sandbox.scrbl b/collects/scribblings/reference/sandbox.scrbl index 0e69330221..c76e0cb376 100644 --- a/collects/scribblings/reference/sandbox.scrbl +++ b/collects/scribblings/reference/sandbox.scrbl @@ -176,8 +176,11 @@ environment: @item{The evaluator works under the @scheme[sandbox-security-guard], which restricts file system and network access.} - @item{Each evaluation is wrapped in a @scheme[call-with-limits]; see - also @scheme[sandbox-eval-limits] and @scheme[set-eval-limits].} + @item{The evaluator is contained in a memory-restricted environment, + and each evaluation is wrapped in a @scheme[call-with-limits] + (when memory accounting is available); see also + @scheme[sandbox-memory-limit], @scheme[sandbox-eval-limits] and + @scheme[set-eval-limits].} ] Note that these limits apply to the creation of the sandbox environment too --- so, for example, if the memory that is required to @@ -466,6 +469,15 @@ default @scheme[sandbox-security-guard]. The default forbids all network connection.} +@defparam[sandbox-memory-limit limit (or/c exact-nonnegative-integer? #f)]{ + +A parameter that determines the total memory limit on the sandbox. +When this limit is exceeded, the sandbox is terminated. This value is +used when the sandbox is created and the limit cannot be changed +afterwards. See @scheme[sandbox-eval-limits] for per-evaluation +limits and a description of how the two limits work together.} + + @defparam[sandbox-eval-limits limits (or/c (list/c (or/c exact-nonnegative-integer? #f) (or/c exact-nonnegative-integer? #f)) @@ -473,12 +485,13 @@ network connection.} 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, 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 limits (useful in case more limit kinds are -available in future versions). The default is @scheme[(list 30 20)]. +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)]. Note that these limits apply to the creation of the sandbox environment too --- even @scheme[(make-evaluator 'scheme/base)] can @@ -488,7 +501,45 @@ you need to catch errors that happen when the sandbox is created. When limits are set, @scheme[call-with-limits] (see below) is wrapped around each use of the evaluator, so consuming too much time or memory results in an exception. Change the limits of a running evaluator -using @scheme[set-eval-limits].} +using @scheme[set-eval-limits]. + +@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.} + +The memory limit that is specified by this parameter applies to each +individual evaluation, but not to the whole sandbox --- that limit is +specified via @scheme[sandbox-memory-limit]. When the global limit is +exceeded, the sandbox is terminated, but when the per-evaluation limit +is exceeded the @exnraise[exn:fail:resource]. For example, say that +you evaluate an expression like +@schemeblock[ + (for ([i (in-range 1000)]) + (set! a (cons (make-bytes 1000000) a)) + (collect-garbage)) +] +then, assuming sufficiently small limits, +@itemize[ + + @item{if a global limit is set but no per-evaluation limit, the + sandbox will eventually be terminated and no further + evaluations possible;} + + @item{if there is a per-evaluation limit, but no global limit, the + evaluation will abort with an error and it can be used again + --- specifically, @scheme[a] will still hold a number of + blocks, and you can evaluate the same expression again which + will add more blocks to it;} + + @item{if both limits are set, with the global one larger than the + per-evaluation limit, then the evaluation will abort and you + will be able to repeat it, but doing so several times will + eventually terminate the sandbox (this will be indicated by + the error message, and by the @scheme[evaluator-alive?] + predicate).} + +]} @defparam[sandbox-make-inspector make (-> inspector?)]{ @@ -510,6 +561,12 @@ evaluator, and the default parameter value is @scheme[current-logger].} The following functions are used to interact with a sandboxed evaluator in addition to using it to evaluate code. + +@defproc[(evaluator-alive? [evaluator (any/c . -> . any)]) boolean?]{ + +Determines whether the evaluator is still alive.} + + @defproc[(kill-evaluator [evaluator (any/c . -> . any)]) void?]{ Releases the resources that are held by @scheme[evaluator] by shutting diff --git a/collects/tests/mzscheme/sandbox.ss b/collects/tests/mzscheme/sandbox.ss index bb23038bdc..1f78204f8c 100644 --- a/collects/tests/mzscheme/sandbox.ss +++ b/collects/tests/mzscheme/sandbox.ss @@ -7,8 +7,14 @@ ;; test call-in-nested-thread* (let () + (define (kill) (kill-thread (current-thread))) + (define (shut) (custodian-shutdown-all (current-custodian))) (define-syntax-rule (nested body ...) (call-in-nested-thread* (lambda () body ...))) + (define-syntax-rule (nested* body ...) + (call-in-nested-thread* (lambda () body ...) + (lambda () 'kill) + (lambda () 'shut))) (test 1 values (nested 1)) ;; propagates parameters (let ([p (make-parameter #f)]) @@ -19,13 +25,15 @@ ;; propagates kill-thread (test (void) thread-wait (thread (lambda () - (nested (kill-thread (current-thread))) + (nested (kill)) ;; never reach here (semaphore-wait (make-semaphore 0))))) ;; propagates custodian-shutdown-all (test (void) values - (parameterize ([current-custodian (make-custodian)]) - (nested (custodian-shutdown-all (current-custodian)))))) + (parameterize ([current-custodian (make-custodian)]) (nested (shut)))) + ;; test handlers parameters + (test 'kill (lambda () (nested* (kill)))) + (test 'shut (lambda () (nested* (shut))))) (let ([ev void]) (define (run thunk) @@ -362,31 +370,33 @@ --top-- (set! ev (parameterize ([sandbox-output 'bytes] [sandbox-error-output current-output-port] + [sandbox-memory-limit 5] [sandbox-eval-limits '(0.25 1/2)]) (make-evaluator 'scheme/base))) ;; GCing is needed to allow these to happen - --eval-- (display (make-bytes 400000 65)) + --eval-- (display (make-bytes 400000 65)) (collect-garbage) --top-- (bytes-length (get-output ev)) => 400000 - --eval-- (display (make-bytes 400000 65)) + --eval-- (display (make-bytes 400000 65)) (collect-garbage) --top-- (bytes-length (get-output ev)) => 400000 - --eval-- (display (make-bytes 400000 65)) + --eval-- (display (make-bytes 400000 65)) (collect-garbage) --top-- (bytes-length (get-output ev)) => 400000 - --eval-- (display (make-bytes 400000 65)) + --eval-- (display (make-bytes 400000 65)) (collect-garbage) --top-- (bytes-length (get-output ev)) => 400000 - --eval-- (display (make-bytes 400000 65)) + --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 - ;; EB: for some reason, the first thing doesn't throw an error, and I think - ;; that the second should break much sooner than 100 iterations - ;; --eval-- (let ([400k (make-bytes 400000 65)]) - ;; (for ([i (in-range 2)]) (display 400k))) - ;; --top-- (bytes-length (get-output ev)) - ;; =err> "out of memory" - ;; --eval-- (let ([400k (make-bytes 400000 65)]) - ;; (for ([i (in-range 100)]) (display 400k))) - ;; =err> "out of memory" ;; test that killing the custodian works fine - ;; first try it without limits (which imply a nester thread/custodian) + ;; first try it without limits (limits imply a nested thread/custodian) --top-- (set! ev (parameterize ([sandbox-eval-limits #f]) (make-evaluator 'scheme/base))) @@ -426,6 +436,20 @@ (lambda () (custodian-shutdown-all (current-custodian)))) =err> "terminated" + ;; when an expression is out of memory, the sandbox should stay alive + --top-- + (set! ev (parameterize ([sandbox-eval-limits '(2 5)] + [sandbox-memory-limit 100]) + (make-evaluator 'scheme/base))) + --eval-- + (define a '()) + (define b 1) + (for ([i (in-range 20)]) + (set! a (cons (make-bytes 500000) a)) + (collect-garbage)) + =err> "out of memory" + b => 1 + )) (report-errs) diff --git a/collects/xml/private/xexpr.ss b/collects/xml/private/xexpr.ss index 0932a05f78..6d512b30f4 100644 --- a/collects/xml/private/xexpr.ss +++ b/collects/xml/private/xexpr.ss @@ -148,7 +148,6 @@ (null? (cddr b)))) ;; xml->xexpr : Content -> Xexpr - ;; The contract is loosely enforced. (define (xml->xexpr x) (let* ([non-dropping-combine (lambda (atts body) @@ -170,8 +169,7 @@ [(entity? x) (entity-text x)] [(or (comment? x) (pi? x) (cdata? x)) x] [(document? x) (error 'xml->xexpr "Expected content, given ~e\nUse document-element to extract the content." x)] - [else ;(error 'xml->xexpr "Expected content, given ~e" x) - x])))) + [else (error 'xml->xexpr "Expected content, given ~e" x)])))) ;; attribute->srep : Attribute -> Attribute-srep (define (attribute->srep a) diff --git a/src/mzscheme/Makefile.in b/src/mzscheme/Makefile.in index 8d473403ba..b1c4e1e2a2 100644 --- a/src/mzscheme/Makefile.in +++ b/src/mzscheme/Makefile.in @@ -68,10 +68,6 @@ cgc: cd dynsrc; $(MAKE) dynlib3m cd gc2; $(MAKE) ../mzscheme@MMM@ -compact: - $(MAKE) 3m - cd gc2; $(MAKE) ../mzscheme_compact_gc - both: $(MAKE) cgc $(MAKE) 3m diff --git a/src/mzscheme/gc2/Makefile.in b/src/mzscheme/gc2/Makefile.in index dc7854ce39..315209a657 100644 --- a/src/mzscheme/gc2/Makefile.in +++ b/src/mzscheme/gc2/Makefile.in @@ -30,9 +30,6 @@ XSRCDIR = xsrc XFORM = env XFORM_USE_PRECOMP=$(XSRCDIR)/precomp.h $(XFORM_NOPRECOMP) SRCDIR = $(srcdir)/../src -XFORM_COMPACT_GC_NOPRECOMP = $(XFORM_SETUP) --cpp "$(CPP) $(CPPFLAGS) -DUSE_COMPACT_3M_GC" @XFORMFLAGS@ -o -XFORM_COMPACT_GC = env XFORM_USE_PRECOMP=$(XSRCDIR)/precomp.h $(XFORM_COMPACT_GC_NOPRECOMP) - FOREIGN_USED_OBJ = foreign.@LTO@ FOREIGN_NOT_USED_OBJ = @@ -49,6 +46,7 @@ OBJS = salloc.@LTO@ \ file.@LTO@ \ fun.@LTO@ \ hash.@LTO@ \ + jit.@LTO@ \ list.@LTO@ \ module.@LTO@ \ mzrt.@LTO@ \ @@ -137,6 +135,15 @@ XFORMDEP = $(srcdir)/gc2.h $(srcdir)/xform.ss $(srcdir)/xform-mod.ss \ $(srcdir)/../sconfig.h $(srcdir)/../uconfig.h $(srcdir)/../src/schemef.h \ $(srcdir)/../src/stypes.h +LIGHTNINGDEP = $(srcdir)/../src/lightning/i386/core.h $(srcdir)/../src/lightning/i386/core-common.h \ + $(srcdir)/../src/lightning/i386/asm.h $(srcdir)/../src/lightning/i386/asm-common.h \ + $(srcdir)/../src/lightning/i386/fp.h $(srcdir)/../src/lightning/i386/fp-common.h \ + $(srcdir)/../src/lightning/i386/funcs.h $(srcdir)/../src/lightning/i386/funcs-common.h \ + $(srcdir)/../src/lightning/ppc/core.h $(srcdir)/../src/lightning/ppc/core-common.h \ + $(srcdir)/../src/lightning/ppc/asm.h $(srcdir)/../src/lightning/ppc/asm-common.h \ + $(srcdir)/../src/lightning/ppc/fp.h $(srcdir)/../src/lightning/ppc/fp-common.h \ + $(srcdir)/../src/lightning/ppc/funcs.h $(srcdir)/../src/lightning/ppc/funcs-common.h + $(XSRCDIR)/precomp.h : $(XFORMDEP) $(srcdir)/../src/schvers.h env XFORM_PRECOMP=yes $(XFORM_NOPRECOMP) $(XSRCDIR)/precomp.h $(srcdir)/precomp.c @@ -154,7 +161,7 @@ $(XSRCDIR)/complex.c: ../src/complex.@LTO@ $(XFORMDEP) $(XFORM) $(XSRCDIR)/complex.c $(SRCDIR)/complex.c $(XSRCDIR)/dynext.c: ../src/dynext.@LTO@ $(XFORMDEP) $(XFORM) $(XSRCDIR)/dynext.c $(SRCDIR)/dynext.c -$(XSRCDIR)/env.c: ../src/env.@LTO@ $(XFORMDEP) +$(XSRCDIR)/env.c: ../src/env.@LTO@ $(XFORMDEP) $(SRCDIR)/mzrt.h $(XFORM) $(XSRCDIR)/env.c $(SRCDIR)/env.c $(XSRCDIR)/error.c: ../src/error.@LTO@ $(XFORMDEP) $(XFORM) $(XSRCDIR)/error.c $(SRCDIR)/error.c @@ -166,9 +173,9 @@ $(XSRCDIR)/fun.c: ../src/fun.@LTO@ $(XFORMDEP) $(XFORM) $(XSRCDIR)/fun.c $(SRCDIR)/fun.c $(XSRCDIR)/hash.c: ../src/hash.@LTO@ $(XFORMDEP) $(XFORM) $(XSRCDIR)/hash.c $(SRCDIR)/hash.c -$(XSRCDIR)/jit.c: ../src/jit.@LTO@ $(XFORMDEP) +$(XSRCDIR)/jit.c: ../src/jit.@LTO@ $(XFORMDEP) $(LIGHTNINGDEP) $(XFORM) $(XSRCDIR)/jit.c $(SRCDIR)/jit.c -$(XSRCDIR)/module.c: ../src/module.@LTO@ $(XFORMDEP) +$(XSRCDIR)/module.c: ../src/module.@LTO@ $(XFORMDEP) $(SRCDIR)/mzrt.h $(XFORM) $(XSRCDIR)/module.c $(SRCDIR)/module.c $(XSRCDIR)/list.c: ../src/list.@LTO@ $(XFORMDEP) $(XFORM) $(XSRCDIR)/list.c $(SRCDIR)/list.c @@ -182,7 +189,7 @@ $(XSRCDIR)/numcomp.c: ../src/numcomp.@LTO@ $(XFORMDEP) $(XFORM) $(XSRCDIR)/numcomp.c $(SRCDIR)/numcomp.c $(XSRCDIR)/numstr.c: ../src/numstr.@LTO@ $(XFORMDEP) $(XFORM) $(XSRCDIR)/numstr.c $(SRCDIR)/numstr.c -$(XSRCDIR)/places.c: ../src/places.@LTO@ $(XFORMDEP) +$(XSRCDIR)/places.c: ../src/places.@LTO@ $(XFORMDEP) $(SRCDIR)/mzrt.h $(XFORM) $(XSRCDIR)/places.c $(SRCDIR)/places.c $(XSRCDIR)/port.c: ../src/port.@LTO@ $(XFORMDEP) $(XFORM) $(XSRCDIR)/port.c $(SRCDIR)/port.c @@ -206,7 +213,7 @@ $(XSRCDIR)/struct.c: ../src/struct.@LTO@ $(XFORMDEP) $(XFORM) $(XSRCDIR)/struct.c $(SRCDIR)/struct.c $(XSRCDIR)/stxobj.c: ../src/stxobj.@LTO@ $(XFORMDEP) $(XFORM) $(XSRCDIR)/stxobj.c $(SRCDIR)/stxobj.c -$(XSRCDIR)/symbol.c: ../src/symbol.@LTO@ $(XFORMDEP) +$(XSRCDIR)/symbol.c: ../src/symbol.@LTO@ $(XFORMDEP) $(SRCDIR)/mzrt.h $(XFORM) $(XSRCDIR)/symbol.c $(SRCDIR)/symbol.c $(XSRCDIR)/syntax.c: ../src/syntax.@LTO@ $(XFORMDEP) $(XFORM) $(XSRCDIR)/syntax.c $(SRCDIR)/syntax.c @@ -221,9 +228,6 @@ $(XSRCDIR)/foreign.c: ../../foreign/foreign.@LTO@ $(XFORMDEP) $(XSRCDIR)/main.c: ../main.@LTO@ $(XFORMDEP) $(XFORM_NOPRECOMP) $(XSRCDIR)/main.c $(DEF_COLLECTS_DIR) $(srcdir)/../main.c -$(XSRCDIR)/jit_compact_gc.c: ../src/jit.@LTO@ $(XFORMDEP) - $(XFORM_COMPACT_GC) $(XSRCDIR)/jit_compact_gc.c $(SRCDIR)/jit.c - salloc.@LTO@: $(XSRCDIR)/salloc.c $(CC) $(CFLAGS) -c $(XSRCDIR)/salloc.c -o salloc.@LTO@ bignum.@LTO@: $(XSRCDIR)/bignum.c @@ -252,13 +256,11 @@ hash.@LTO@: $(XSRCDIR)/hash.c $(CC) $(CFLAGS) -c $(XSRCDIR)/hash.c -o hash.@LTO@ jit.@LTO@: $(XSRCDIR)/jit.c $(CC) $(CFLAGS) -c $(XSRCDIR)/jit.c -o jit.@LTO@ -jit_compact_gc.@LTO@: $(XSRCDIR)/jit_compact_gc.c - $(CC) $(CFLAGS) -c $(XSRCDIR)/jit_compact_gc.c -o jit_compact_gc.@LTO@ list.@LTO@: $(XSRCDIR)/list.c $(CC) $(CFLAGS) -c $(XSRCDIR)/list.c -o list.@LTO@ module.@LTO@: $(XSRCDIR)/module.c $(CC) $(CFLAGS) -c $(XSRCDIR)/module.c -o module.@LTO@ -mzrt.@LTO@: $(SRCDIR)/mzrt.c +mzrt.@LTO@: $(SRCDIR)/mzrt.c $(SRCDIR)/mzrt.h $(CC) $(CFLAGS) -DMZ_PRECISE_GC -c $(SRCDIR)/mzrt.c -o mzrt.@LTO@ network.@LTO@: $(XSRCDIR)/network.c $(CC) $(CFLAGS) -c $(XSRCDIR)/network.c -o network.@LTO@ @@ -311,6 +313,7 @@ main.@LTO@: $(XSRCDIR)/main.c gc2.@LTO@: $(srcdir)/gc2.c $(srcdir)/newgc.c $(srcdir)/gc2.h \ $(srcdir)/newgc.h $(srcdir)/blame_the_child.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 \ $(srcdir)/page_range.c $(srcdir)/protect_range.c $(srcdir)/var_stack.c $(srcdir)/stack_comp.c \ @@ -318,30 +321,6 @@ gc2.@LTO@: $(srcdir)/gc2.c $(srcdir)/newgc.c $(srcdir)/gc2.h \ $(srcdir)/weak.c $(srcdir)/fnls.c $(srcdir)/../include/scheme.h $(srcdir)/../src/schpriv.h $(CC) $(CFLAGS) -I$(builddir)/.. -c $(srcdir)/gc2.c -o gc2.@LTO@ -new_gc.@LTO@: $(srcdir)/newgc.c $(srcdir)/gc2.h \ - $(srcdir)/vm_osx.c $(srcdir)/vm_mmap.c $(srcdir)/vm_osk.c $(srcdir)/vm.c\ - $(srcdir)/vm_memalign.c $(srcdir)/alloc_cache.c \ - $(srcdir)/page_range.c $(srcdir)/protect_range.c $(srcdir)/var_stack.c $(srcdir)/stack_comp.c \ - $(srcdir)/../utils/splay.c $(srcdir)/my_qsort.c $(srcdir)/backtrace.c \ - $(srcdir)/weak.c $(srcdir)/fnls.c $(srcdir)/../include/scheme.h $(srcdir)/../src/schpriv.h - $(CC) $(CFLAGS) -c $(srcdir)/newgc.c -o new_gc.@LTO@ - -copy_gc.@LTO@: $(srcdir)/copy.c $(srcdir)/gc2.h \ - $(srcdir)/vm_osx.c $(srcdir)/vm_mmap.c $(srcdir)/vm_osk.c $(srcdir)/vm.c\ - $(srcdir)/vm_memalign.c $(srcdir)/alloc_cache.c \ - $(srcdir)/page_range.c $(srcdir)/protect_range.c $(srcdir)/var_stack.c $(srcdir)/stack_comp.c \ - $(srcdir)/../utils/splay.c $(srcdir)/my_qsort.c $(srcdir)/backtrace.c \ - $(srcdir)/weak.c $(srcdir)/fnls.c $(srcdir)/../include/scheme.h $(srcdir)/../src/schpriv.h - $(CC) $(CFLAGS) -c $(srcdir)/copy.c -o copy_gc.@LTO@ - -compact_gc.@LTO@: $(srcdir)/compact.c $(srcdir)/gc2.h \ - $(srcdir)/vm_osx.c $(srcdir)/vm_mmap.c $(srcdir)/vm_osk.c $(srcdir)/vm.c\ - $(srcdir)/vm_memalign.c $(srcdir)/alloc_cache.c \ - $(srcdir)/page_range.c $(srcdir)/protect_range.c $(srcdir)/var_stack.c $(srcdir)/stack_comp.c \ - $(srcdir)/../utils/splay.c $(srcdir)/my_qsort.c $(srcdir)/backtrace.c \ - $(srcdir)/weak.c $(srcdir)/fnls.c $(srcdir)/../include/scheme.h $(srcdir)/../src/schpriv.h - $(CC) $(CFLAGS) -c $(srcdir)/compact.c -o compact_gc.@LTO@ - FOREIGN_OBJS = ../../foreign/gcc/libffi/src/*.@LTO@ ../../foreign/gcc/libffi/src/*/*.@LTO@ FOREIGN_LIB = ../../foreign/gcc/libffi/libffi@FOREIGN_CONVENIENCE@.la FOREIGN_OBJSLIB = @FOREIGN_OBJSLIB@ @@ -354,20 +333,13 @@ FOREIGN_NOT_USED_OBJSLIB = EXTRA_OBJS_T = ../src/gmp.@LTO@ ../src/unwind.@LTO@ $(@FOREIGN_IF_USED@_LIB) EXTRA_OBJS_L = ../src/gmp.@LTO@ ../src/unwind.@LTO@ $(@FOREIGN_IF_USED@_OBJSLIB) -../libmzscheme3m.@LIBSFX@: $(OBJS) $(EXTRA_OBJS_T) jit.@LTO@ gc2.@LTO@ - $(AR) $(ARFLAGS) ../libmzscheme3m.@LIBSFX@ $(OBJS) $(EXTRA_OBJS_L) jit.@LTO@ gc2.@LTO@ +../libmzscheme3m.@LIBSFX@: $(OBJS) $(EXTRA_OBJS_T) gc2.@LTO@ + $(AR) $(ARFLAGS) ../libmzscheme3m.@LIBSFX@ $(OBJS) $(EXTRA_OBJS_L) gc2.@LTO@ $(RANLIB) ../libmzscheme3m.@LIBSFX@ -../libmzscheme_compact_gc.@LIBSFX@: $(OBJS) $(EXTRA_OBJS_T) jit_compact_gc.@LTO@ compact_gc.@LTO@ - $(AR) $(ARFLAGS) ../libmzscheme_compact_gc.@LIBSFX@ $(OBJS) $(EXTRA_OBJS_L) jit_compact_gc.@LTO@ compact_gc.@LTO@ - $(RANLIB) ../libmzscheme_compact_gc.@LIBSFX@ - ../mzscheme@MMM@@NOT_OSX@: main.@LTO@ ../libmzscheme3m.@LIBSFX@ cd ..; @MZLINKER@ -o mzscheme@MMM@ @PROFFLAGS@ gc2/main.@LTO@ libmzscheme3m.@LIBSFX@ @LDFLAGS@ $(LIBS) -../mzscheme_compact_gc@NOT_OSX@: main.@LTO@ ../libmzscheme_compact_gc.@LIBSFX@ - cd ..; @MZLINKER@ -o mzscheme_compact_gc @PROFFLAGS@ gc2/main.@LTO@ libmzscheme_compact_gc.@LIBSFX@ @LDFLAGS@ $(LIBS) - # The above "cd .." prevents a problem with libtool's generated script in --enable-shared mode, # at least for Mac OS X. Beware of changing LIBS or LDFLAGS to inclucde something with a relative # path. @@ -386,9 +358,6 @@ $(MZFWMMM): ../libmzscheme3m.@LIBSFX@ cp "PLT_MzScheme.framework/Versions/$(FWVERSION)_3m/PLT_MzScheme" "../PLT_MzScheme.framework/Versions/$(FWVERSION)_3m/PLT_MzScheme" /usr/bin/install_name_tool -change "PLT_MzScheme.framework/Versions/$(FWVERSION)_3m/PLT_MzScheme" "@executable_path/PLT_MzScheme.framework/Versions/$(FWVERSION)_3m/PLT_MzScheme" "../mzscheme@MMM@" -../mzscheme_compact_gc@OSX@: - echo "../mzscheme_compact_gc does not currently build on Mac OS X; use --enable-compact with configure, instead" - clean: /bin/rm -f ../mzscheme@MMM@ *.@LTO@ $(XSRCDIR)/* /bin/rm -rf xform-collects diff --git a/src/mzscheme/gc2/blame_the_child.c b/src/mzscheme/gc2/blame_the_child.c index 21fb5c08bf..5b8a21e8c7 100644 --- a/src/mzscheme/gc2/blame_the_child.c +++ b/src/mzscheme/gc2/blame_the_child.c @@ -4,6 +4,13 @@ #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 */ + +static const int btc_redirect_thread = 511; +static const int btc_redirect_custodian = 510; +static const int btc_redirect_ephemeron = 509; +static const int btc_redirect_cust_box = 508; /*****************************************************************************/ /* thread list */ @@ -36,11 +43,12 @@ inline static void BTC_register_thread(void *t, void *c) inline static void mark_threads(NewGC *gc, int owner) { GC_Thread_Info *work; + Mark_Proc thread_mark = gc->mark_table[btc_redirect_thread]; for(work = gc->thread_infos; work; work = work->next) if(work->owner == owner) { if (((Scheme_Thread *)work->thread)->running) { - gc->normal_thread_mark(work->thread); + thread_mark(work->thread); if (work->thread == scheme_current_thread) { GC_mark_variable_stack(GC_variable_stack, 0, get_stack_base(gc), NULL); } @@ -249,6 +257,7 @@ inline static void mark_cust_boxes(NewGC *gc, Scheme_Custodian *cur) { Scheme_Object *pr, *prev = NULL, *next; GC_Weak_Box *wb; + Mark_Proc cust_box_mark = gc->mark_table[btc_redirect_cust_box]; /* cust boxes is a list of weak boxes to cust boxes */ @@ -257,7 +266,7 @@ inline static void mark_cust_boxes(NewGC *gc, Scheme_Custodian *cur) wb = (GC_Weak_Box *)SCHEME_CAR(pr); next = SCHEME_CDR(pr); if (wb->val) { - gc->normal_cust_box_mark(wb->val); + cust_box_mark(wb->val); prev = pr; } else { if (prev) @@ -273,21 +282,32 @@ inline static void mark_cust_boxes(NewGC *gc, Scheme_Custodian *cur) int BTC_thread_mark(void *p) { - return ((struct objhead *)(NUM(p) - WORD_SIZE))->size; + NewGC *gc = GC_get_GC(); + if (gc->doing_memory_accounting) { + return ((struct objhead *)(NUM(p) - WORD_SIZE))->size; + } + return gc->mark_table[btc_redirect_thread](p); } int BTC_custodian_mark(void *p) { NewGC *gc = GC_get_GC(); - if(custodian_to_owner_set(gc, p) == gc->current_mark_owner) - return gc->normal_custodian_mark(p); - else - return ((struct objhead *)(NUM(p) - WORD_SIZE))->size; + if (gc->doing_memory_accounting) { + if(custodian_to_owner_set(gc, p) == gc->current_mark_owner) + return gc->mark_table[btc_redirect_custodian](p); + else + return ((struct objhead *)(NUM(p) - WORD_SIZE))->size; + } + return gc->mark_table[btc_redirect_custodian](p); } int BTC_cust_box_mark(void *p) { - return ((struct objhead *)(NUM(p) - WORD_SIZE))->size; + NewGC *gc = GC_get_GC(); + if (gc->doing_memory_accounting) { + return ((struct objhead *)(NUM(p) - WORD_SIZE))->size; + } + return gc->mark_table[btc_redirect_cust_box](p); } inline static void mark_normal_obj(NewGC *gc, mpage *page, void *ptr) @@ -375,6 +395,21 @@ static void propagate_accounting_marks(NewGC *gc) reset_pointer_stack(); } +inline static void BTC_initialize_mark_table(NewGC *gc) { + gc->mark_table[scheme_thread_type] = BTC_thread_mark; + gc->mark_table[scheme_custodian_type] = BTC_custodian_mark; + gc->mark_table[gc->ephemeron_tag] = BTC_ephemeron_mark; + gc->mark_table[gc->cust_box_tag] = BTC_cust_box_mark; +} + +inline static int BTC_get_redirect_tag(NewGC *gc, int tag) { + if (tag == scheme_thread_type ) { tag = btc_redirect_thread; } + else if (tag == scheme_custodian_type ) { tag = btc_redirect_custodian; } + else if (tag == gc->ephemeron_tag ) { tag = btc_redirect_ephemeron; } + else if (tag == gc->cust_box_tag ) { tag = btc_redirect_cust_box; } + return tag; +} + static void BTC_do_accounting(NewGC *gc) { const int table_size = gc->owner_table_size; @@ -390,17 +425,6 @@ static void BTC_do_accounting(NewGC *gc) gc->in_unsafe_allocation_mode = 1; gc->unsafe_allocation_abort = btc_overmem_abort; - if(!gc->normal_thread_mark) { - gc->normal_thread_mark = gc->mark_table[scheme_thread_type]; - gc->normal_custodian_mark = gc->mark_table[scheme_custodian_type]; - gc->normal_cust_box_mark = gc->mark_table[gc->cust_box_tag]; - } - - gc->mark_table[scheme_thread_type] = BTC_thread_mark; - gc->mark_table[scheme_custodian_type] = BTC_custodian_mark; - gc->mark_table[gc->ephemeron_tag] = BTC_ephemeron_mark; - gc->mark_table[gc->cust_box_tag] = BTC_cust_box_mark; - /* clear the memory use numbers out */ for(i = 1; i < table_size; i++) if(owner_table[i]) @@ -427,11 +451,6 @@ static void BTC_do_accounting(NewGC *gc) box = cur->global_prev; cur = box ? SCHEME_PTR1_VAL(box) : NULL; } - gc->mark_table[scheme_thread_type] = gc->normal_thread_mark; - gc->mark_table[scheme_custodian_type] = gc->normal_custodian_mark; - gc->mark_table[gc->ephemeron_tag] = mark_ephemeron; - gc->mark_table[gc->cust_box_tag] = gc->normal_cust_box_mark; - gc->in_unsafe_allocation_mode = 0; gc->doing_memory_accounting = 0; gc->old_btc_mark = gc->new_btc_mark; diff --git a/src/mzscheme/gc2/gc2.h b/src/mzscheme/gc2/gc2.h index 01d6503c46..04a5be7cbd 100644 --- a/src/mzscheme/gc2/gc2.h +++ b/src/mzscheme/gc2/gc2.h @@ -376,6 +376,19 @@ GC2_EXTERN void GC_write_barrier(void *p); Explicit write barrier to ensure that a write-barrier signal is not triggered by a memory write. */ +GC2_EXTERN void GC_switch_in_master_gc(); +/* + Makes the current thread the master GC thread. +*/ +GC2_EXTERN void GC_switch_out_master_gc(); +/* + Makes the current GC the master GC. + Creates a new place specific GC and links it to the master GC. +*/ +GC2_EXTERN void GC_construct_child_gc(); +/* + Creates a new place specific GC and links to the master GC. +*/ # ifdef __cplusplus }; diff --git a/src/mzscheme/gc2/newgc.c b/src/mzscheme/gc2/newgc.c index 9350b12c27..0751d9f2de 100644 --- a/src/mzscheme/gc2/newgc.c +++ b/src/mzscheme/gc2/newgc.c @@ -31,10 +31,12 @@ #include #include #include +#include #include "platforms.h" #include "gc2.h" #include "gc2_dump.h" + /* the number of tags to use for tagged objects */ #define NUMBER_OF_TAGS 512 @@ -73,9 +75,16 @@ static const char *type_name[PAGE_TYPES] = { #include "newgc.h" +static NewGC *MASTERGC; static THREAD_LOCAL NewGC *GC; #define GCTYPE NewGC #define GC_get_GC() (GC) +#define GC_set_GC(gc) (GC = gc) + +inline static int is_master_gc(NewGC *gc) { + return (MASTERGC == gc); +} + #include "msgprint.c" @@ -260,10 +269,33 @@ int GC_mtrace_union_current_with(int newval) /*****************************************************************************/ /* Page Map Routines */ /*****************************************************************************/ +inline static void free_page_maps(PageMap page_maps1) { +#ifdef SIXTY_FOUR_BIT_INTEGERS + unsigned long i; + unsigned long j; + mpage ***page_maps2; + mpage **page_maps3; + + for (i=0; iprev = NULL; @@ -1381,9 +1408,8 @@ void GC_register_new_thread(void *t, void *c) /* administration / initialization */ /*****************************************************************************/ -static int designate_modified(void *p) +static int designate_modified_gc(NewGC *gc, void *p) { - NewGC *gc = GC_get_GC(); struct mpage *page = pagemap_find_page(gc->page_maps, p); if (gc->no_further_modifications) { @@ -1399,11 +1425,20 @@ static int designate_modified(void *p) return 1; } } else { + if (gc->primoridal_gc) { + return designate_modified_gc(gc->primoridal_gc, p); + } GCPRINT(GCOUTF, "Seg fault (internal error) at %p\n", p); } return 0; } +static int designate_modified(void *p) { + NewGC *gc = GC_get_GC(); + return designate_modified_gc(gc, p); +} + + void GC_write_barrier(void *p) { (void)designate_modified(p); @@ -1411,23 +1446,76 @@ void GC_write_barrier(void *p) #include "sighand.c" -void NewGC_initialize(NewGC *newgc) { - memset(newgc, 0, sizeof(NewGC)); - newgc->mark_table = ofm_malloc_zero(NUMBER_OF_TAGS * sizeof (Mark_Proc)); - newgc->fixup_table = ofm_malloc_zero(NUMBER_OF_TAGS * sizeof (Fixup_Proc)); +void NewGC_initialize(NewGC *newgc, NewGC *parentgc) { + if (parentgc) { + newgc->mark_table = parentgc->mark_table; + newgc->fixup_table = parentgc->fixup_table; + } + else { + newgc->mark_table = ofm_malloc_zero(NUMBER_OF_TAGS * sizeof (Mark_Proc)); + newgc->fixup_table = ofm_malloc_zero(NUMBER_OF_TAGS * sizeof (Fixup_Proc)); +# ifdef NEWGC_BTC_ACCOUNT + BTC_initialize_mark_table(newgc); +#endif + } + + mark_stack_initialize(); + #ifdef SIXTY_FOUR_BIT_INTEGERS newgc->page_maps = ofm_malloc_zero(PAGEMAP64_LEVEL1_SIZE * sizeof (mpage***)); #else newgc->page_maps = ofm_malloc_zero(PAGEMAP32_SIZE * sizeof (mpage*)); #endif + newgc->vm = vm_create(); newgc->protect_range = ofm_malloc_zero(sizeof(Page_Range)); newgc->generations_available = 1; newgc->last_full_mem_use = (20 * 1024 * 1024); newgc->new_btc_mark = 1; +} - init_mark_stack(); +/* NOTE This method sets the constructed GC as the new Thread Specific GC. */ +static NewGC *init_type_tags_worker(NewGC *parentgc, int count, int pair, int mutable_pair, int weakbox, int ephemeron, int weakarray, int custbox) +{ + NewGC *gc; + + gc = ofm_malloc_zero(sizeof(NewGC)); + /* NOTE sets the constructed GC as the new Thread Specific GC. */ + GC_set_GC(gc); + + gc->weak_box_tag = weakbox; + gc->ephemeron_tag = ephemeron; + gc->weak_array_tag = weakarray; +# ifdef NEWGC_BTC_ACCOUNT + gc->cust_box_tag = custbox; +# endif + + NewGC_initialize(gc, parentgc); + + + /* Our best guess at what the OS will let us allocate: */ + gc->max_pages_in_heap = determine_max_heap_size() / APAGE_SIZE; + /* Not all of that memory is available for allocating GCable + objects. There's the memory used by the stack, code, + malloc()/free()ed memory, etc., and there's also the + administrative structures for the GC itself. */ + gc->max_pages_for_use = gc->max_pages_in_heap / 2; + + resize_gen0(gc, GEN0_INITIAL_SIZE); + + if (!parentgc) { + GC_register_traversers(gc->weak_box_tag, size_weak_box, mark_weak_box, fixup_weak_box, 0, 0); + GC_register_traversers(gc->ephemeron_tag, size_ephemeron, mark_ephemeron, fixup_ephemeron, 0, 0); + GC_register_traversers(gc->weak_array_tag, size_weak_array, mark_weak_array, fixup_weak_array, 0, 0); + } + initialize_signal_handler(gc); + GC_add_roots(&gc->park, (char *)&gc->park + sizeof(gc->park) + 1); + GC_add_roots(&gc->park_save, (char *)&gc->park_save + sizeof(gc->park_save) + 1); + + initialize_protect_page_ranges(gc->protect_range, malloc_dirty_pages(gc, APAGE_SIZE, APAGE_SIZE), APAGE_SIZE); + + return gc; } void GC_init_type_tags(int count, int pair, int mutable_pair, int weakbox, int ephemeron, int weakarray, int custbox) @@ -1435,45 +1523,56 @@ void GC_init_type_tags(int count, int pair, int mutable_pair, int weakbox, int e static int initialized = 0; if(!initialized) { - NewGC *gc; initialized = 1; - - gc = ofm_malloc(sizeof(NewGC)); - GC = gc; - NewGC_initialize(gc); - - gc->weak_box_tag = weakbox; - gc->ephemeron_tag = ephemeron; - gc->weak_array_tag = weakarray; -# ifdef NEWGC_BTC_ACCOUNT - gc->cust_box_tag = custbox; -# endif - - /* Our best guess at what the OS will let us allocate: */ - gc->max_pages_in_heap = determine_max_heap_size() / APAGE_SIZE; - /* Not all of that memory is available for allocating GCable - objects. There's the memory used by the stack, code, - malloc()/free()ed memory, etc., and there's also the - administrative structures for the GC itself. */ - gc->max_pages_for_use = gc->max_pages_in_heap / 2; - - resize_gen0(gc, GEN0_INITIAL_SIZE); - - GC_register_traversers(gc->weak_box_tag, size_weak_box, mark_weak_box, fixup_weak_box, 0, 0); - GC_register_traversers(gc->ephemeron_tag, size_ephemeron, mark_ephemeron, fixup_ephemeron, 0, 0); - GC_register_traversers(gc->weak_array_tag, size_weak_array, mark_weak_array, fixup_weak_array, 0, 0); - initialize_signal_handler(gc); - GC_add_roots(&gc->park, (char *)&gc->park + sizeof(gc->park) + 1); - GC_add_roots(&gc->park_save, (char *)&gc->park_save + sizeof(gc->park_save) + 1); - - initialize_protect_page_ranges(gc->protect_range, malloc_dirty_pages(gc, APAGE_SIZE, APAGE_SIZE), APAGE_SIZE); + init_type_tags_worker(NULL, count, pair, mutable_pair, weakbox, ephemeron, weakarray, custbox); } else { - GCPRINT(GCOUTF, "HEY WHATS UP.\n"); + GCPRINT(GCOUTF, "GC_init_type_tags should only be called once!\n"); abort(); } } +void GC_construct_child_gc() { + NewGC *gc = MASTERGC; + NewGC *newgc = init_type_tags_worker(gc, 0, 0, 0, gc->weak_box_tag, gc->ephemeron_tag, gc->weak_array_tag, gc->cust_box_tag); + newgc->primoridal_gc = MASTERGC; +} + +static inline void save_globals_to_gc(NewGC *gc) { + gc->saved_mark_stack = mark_stack; + gc->saved_GC_variable_stack = GC_variable_stack; + gc->saved_GC_gen0_alloc_page_ptr = GC_gen0_alloc_page_ptr; + gc->saved_GC_gen0_alloc_page_end = GC_gen0_alloc_page_end; +} + +static inline void restore_globals_from_gc(NewGC *gc) { + mark_stack = gc->saved_mark_stack; + GC_variable_stack = gc->saved_GC_variable_stack; + GC_gen0_alloc_page_ptr = gc->saved_GC_gen0_alloc_page_ptr; + GC_gen0_alloc_page_end = gc->saved_GC_gen0_alloc_page_end; +} + +void GC_switch_out_master_gc() { + static int initialized = 0; + + if(!initialized) { + initialized = 1; + MASTERGC = GC_get_GC(); + MASTERGC->dumping_avoid_collection = 1; + save_globals_to_gc(MASTERGC); + GC_construct_child_gc(); + } + else { + GCPRINT(GCOUTF, "GC_switch_out_master_gc should only be called once!\n"); + abort(); + } +} + +void GC_switch_in_master_gc() { + GC_set_GC(MASTERGC); + restore_globals_from_gc(MASTERGC); +} + void GC_gcollect(void) { NewGC *gc = GC_get_GC(); @@ -1484,8 +1583,15 @@ void GC_register_traversers(short tag, Size_Proc size, Mark_Proc mark, Fixup_Proc fixup, int constant_Size, int atomic) { NewGC *gc = GC_get_GC(); - gc->mark_table[tag] = atomic ? (Mark_Proc)PAGE_ATOMIC : mark; - gc->fixup_table[tag] = fixup; + + int mark_tag = tag; + +#ifdef NEWGC_BTC_ACCOUNT + mark_tag = BTC_get_redirect_tag(gc, mark_tag); +#endif + + gc->mark_table[mark_tag] = atomic ? (Mark_Proc)PAGE_ATOMIC : mark; + gc->fixup_table[tag] = fixup; } long GC_get_memory_use(void *o) @@ -1709,8 +1815,10 @@ static void propagate_marks(NewGC *gc) unsigned short tag = *(unsigned short*)start; if((unsigned long)mark_table[tag] < PAGE_TYPES) { /* atomic */ - } else + } else { + assert(mark_table[tag]); mark_table[tag](start); break; + } } case PAGE_ATOMIC: break; case PAGE_ARRAY: while(start < end) gcMARK(*(start++)); break; @@ -1718,7 +1826,10 @@ static void propagate_marks(NewGC *gc) case PAGE_TARRAY: { unsigned short tag = *(unsigned short *)start; end -= INSET_WORDS; - while(start < end) start += mark_table[tag](start); + while(start < end) { + assert(mark_table[tag]); + start += mark_table[tag](start); + } break; } } @@ -1728,7 +1839,13 @@ static void propagate_marks(NewGC *gc) set_backtrace_source(p, info->type); switch(info->type) { - case PAGE_TAGGED: mark_table[*(unsigned short*)p](p); break; + case PAGE_TAGGED: + { + unsigned short tag = *(unsigned short*)p; + assert(mark_table[tag]); + mark_table[tag](p); + break; + } case PAGE_ATOMIC: break; case PAGE_ARRAY: { void **start = p; @@ -1740,7 +1857,10 @@ static void propagate_marks(NewGC *gc) void **start = p; void **end = PPTR(info) + (info->size - INSET_WORDS); unsigned short tag = *(unsigned short *)start; - while(start < end) start += mark_table[tag](start); + while(start < end) { + assert(mark_table[tag]); + start += mark_table[tag](start); + } break; } case PAGE_XTAGGED: GC_mark_xtagged(p); break; @@ -2466,15 +2586,25 @@ static void garbage_collect(NewGC *gc, int force_full) mark_roots(gc); mark_immobiles(gc); TIME_STEP("rooted"); - GC_mark_variable_stack(GC_variable_stack, 0, get_stack_base(gc), NULL); + if (!is_master_gc(gc)) + GC_mark_variable_stack(GC_variable_stack, 0, get_stack_base(gc), NULL); TIME_STEP("stacked"); /* now propagate/repair the marks we got from these roots, and do the finalizer passes */ - propagate_marks(gc); mark_ready_ephemerons(gc); propagate_marks(gc); - check_finalizers(gc, 1); mark_ready_ephemerons(gc); propagate_marks(gc); - check_finalizers(gc, 2); mark_ready_ephemerons(gc); propagate_marks(gc); + propagate_marks(gc); + mark_ready_ephemerons(gc); + propagate_marks(gc); + + check_finalizers(gc, 1); + mark_ready_ephemerons(gc); + propagate_marks(gc); + + check_finalizers(gc, 2); + mark_ready_ephemerons(gc); + propagate_marks(gc); + if(gc->gc_full) zero_weak_finalizers(gc); do_ordered_level3(gc); propagate_marks(gc); check_finalizers(gc, 3); propagate_marks(gc); @@ -2514,7 +2644,8 @@ static void garbage_collect(NewGC *gc, int force_full) repair_weak_finalizer_structs(gc); repair_roots(gc); repair_immobiles(gc); - GC_fixup_variable_stack(GC_variable_stack, 0, get_stack_base(gc), NULL); + if (!is_master_gc(gc)) + GC_fixup_variable_stack(GC_variable_stack, 0, get_stack_base(gc), NULL); TIME_STEP("reparied roots"); repair_heap(gc); TIME_STEP("repaired"); @@ -2679,6 +2810,13 @@ void GC_free_all(void) } } + free(gc->mark_table); + free(gc->fixup_table); + + free_page_maps(gc->page_maps); + + free(gc->protect_range); + vm_flush_freed_pages(gc->vm); vm_free(gc->vm); free(gc); diff --git a/src/mzscheme/gc2/newgc.h b/src/mzscheme/gc2/newgc.h index 2ecffd74c8..435dae0d11 100644 --- a/src/mzscheme/gc2/newgc.h +++ b/src/mzscheme/gc2/newgc.h @@ -35,6 +35,12 @@ typedef struct Gen0 { unsigned long max_size; } Gen0; +typedef struct MarkSegment { + struct MarkSegment *prev; + struct MarkSegment *next; + void **top; +} MarkSegment; + typedef struct Weak_Finalizer { void *p; int offset; @@ -110,10 +116,7 @@ typedef struct NewGC { void (*unsafe_allocation_abort)(struct NewGC *); unsigned long memory_in_use; /* the amount of memory in use */ - /* blame the child saved off Mark_Proc pointers */ - Mark_Proc normal_thread_mark; - Mark_Proc normal_custodian_mark; - Mark_Proc normal_cust_box_mark; + /* blame the child thread infos */ GC_Thread_Info *thread_infos; mpage *release_pages; @@ -141,8 +144,6 @@ typedef struct NewGC { AccountHook *hooks; - - unsigned long number_of_gc_runs; unsigned int since_last_full; unsigned long last_full_mem_use; @@ -151,6 +152,13 @@ typedef struct NewGC { unsigned long peak_memory_use; unsigned long num_minor_collects; unsigned long num_major_collects; + + /* THREAD_LOCAL variables that need to be saved off */ + MarkSegment *saved_mark_stack; + void *saved_GC_variable_stack; + unsigned long saved_GC_gen0_alloc_page_ptr; + unsigned long saved_GC_gen0_alloc_page_end; + /* Callbacks */ void (*GC_collect_start_callback)(void); diff --git a/src/mzscheme/gc2/sighand.c b/src/mzscheme/gc2/sighand.c index db9145ea54..dc3902920a 100644 --- a/src/mzscheme/gc2/sighand.c +++ b/src/mzscheme/gc2/sighand.c @@ -14,11 +14,42 @@ /* ========== Linux signal handler ========== */ #if defined(linux) -# include +#include +#include +#include + +static void launchgdb() { + pid_t pid = getpid(); + char inbuffer[10]; + + fprintf(stderr, "pid # %i run gdb \"gdb ./mzscheme3m %i\" or kill process.\n", pid, pid); + fflush(stderr); + + while(read(fileno(stdin), inbuffer, 10) <= 0){ + if(errno != EINTR){ + fprintf(stderr, "Error detected %i\n", errno); + } + } +} + void fault_handler(int sn, struct siginfo *si, void *ctx) { - if (!designate_modified(si->si_addr)) + void *p = si->si_addr; + if (si->si_code != SEGV_ACCERR) { /*SEGV_MAPERR*/ + printf("SIGSEGV fault on %p\n", p); + launchgdb(); abort(); + } + + if (!designate_modified(p)) { + if (si->si_code == SEGV_ACCERR) { + printf("mprotect fault on %p\n", p); + } + else { + printf("?? %i fault on %p\n", si->si_code, p); + } + abort(); + } # define NEED_SIGACTION # define USE_SIGACTON_SIGNAL_KIND SIGSEGV } diff --git a/src/mzscheme/gc2/weak.c b/src/mzscheme/gc2/weak.c index 719d5cceef..da95fb12a7 100644 --- a/src/mzscheme/gc2/weak.c +++ b/src/mzscheme/gc2/weak.c @@ -234,12 +234,17 @@ static int mark_ephemeron(void *p) #ifdef NEWGC_BTC_ACCOUNT static int BTC_ephemeron_mark(void *p) { - GC_Ephemeron *eph = (GC_Ephemeron *)p; - - gcMARK(eph->key); - gcMARK(eph->val); + GCTYPE *gc = GC_get_GC(); + if (gc->doing_memory_accounting) { - return gcBYTES_TO_WORDS(sizeof(GC_Ephemeron)); + GC_Ephemeron *eph = (GC_Ephemeron *)p; + + gcMARK(eph->key); + gcMARK(eph->val); + + return gcBYTES_TO_WORDS(sizeof(GC_Ephemeron)); + } + return mark_ephemeron(p); } #endif diff --git a/src/mzscheme/sgc/sgc.c b/src/mzscheme/sgc/sgc.c index 31330e255c..d3cfaedb47 100644 --- a/src/mzscheme/sgc/sgc.c +++ b/src/mzscheme/sgc/sgc.c @@ -776,25 +776,24 @@ static long mem_traced; static long num_chunks; static long num_blocks; -typedef void (*GC_collect_start_callback_Proc)(void); -typedef void (*GC_collect_end_callback_Proc)(void); GC_collect_start_callback_Proc GC_collect_start_callback; GC_collect_end_callback_Proc GC_collect_end_callback; void (*GC_custom_finalize)(void); -GC_collect_start_callback_Proc GC_set_collect_start_callback(GC_collect_start_callback_Proc) { +GC_collect_start_callback_Proc GC_set_collect_start_callback(GC_collect_start_callback_Proc func) { GC_collect_start_callback_Proc old; old = GC_collect_start_callback; GC_collect_start_callback = func; - return old + return old; } -GC_collect_end_callback_Proc GC_set_collect_end_callback(GC_collect_end_callback_Proc) { - GC_collect_end_callback_Proc old +GC_collect_end_callback_Proc GC_set_collect_end_callback(GC_collect_end_callback_Proc func) { + GC_collect_end_callback_Proc old; old = GC_collect_end_callback; GC_collect_end_callback = func; - return old + return old; } + static long roots_count; static long roots_size; static unsigned long *roots; diff --git a/src/mzscheme/sgc/sgc.h b/src/mzscheme/sgc/sgc.h index 6568beb2a8..ec54f37803 100644 --- a/src/mzscheme/sgc/sgc.h +++ b/src/mzscheme/sgc/sgc.h @@ -36,6 +36,11 @@ void *GC_malloc_stubborn(size_t size_in_bytes); void *GC_malloc_uncollectable(size_t size_in_bytes); void *GC_malloc_atomic_uncollectable(size_t size_in_bytes); +typedef void (*GC_collect_start_callback_Proc)(void); +typedef void (*GC_collect_end_callback_Proc)(void); +GC_collect_start_callback_Proc GC_set_collect_start_callback(GC_collect_start_callback_Proc); +GC_collect_end_callback_Proc GC_set_collect_end_callback(GC_collect_end_callback_Proc); + void GC_free(void *); /* ... but only if it's turned on in sgc.c. */ struct GC_Set; diff --git a/src/mzscheme/src/Makefile.in b/src/mzscheme/src/Makefile.in index 536da8af2e..7aa7a464d1 100644 --- a/src/mzscheme/src/Makefile.in +++ b/src/mzscheme/src/Makefile.in @@ -268,8 +268,12 @@ jit.@LTO@: $(srcdir)/schpriv.h $(srcdir)/schexn.h $(SCONFIG) $(srcdir)/../includ $(srcdir)/../src/stypes.h $(srcdir)/codetab.inc $(srcdir)/mzmark.c \ $(srcdir)/lightning/i386/core.h $(srcdir)/lightning/i386/core-common.h \ $(srcdir)/lightning/i386/asm.h $(srcdir)/lightning/i386/asm-common.h \ + $(srcdir)/lightning/i386/funcs.h $(srcdir)/lightning/i386/funcs-common.h \ + $(srcdir)/lightning/i386/fp.h $(srcdir)/lightning/i386/fp-common.h \ $(srcdir)/lightning/ppc/core.h $(srcdir)/lightning/ppc/core-common.h \ - $(srcdir)/lightning/ppc/asm.h $(srcdir)/lightning/ppc/asm-common.h + $(srcdir)/lightning/ppc/asm.h $(srcdir)/lightning/ppc/asm-common.h \ + $(srcdir)/lightning/ppc/funcs.h $(srcdir)/lightning/ppc/funcs-common.h \ + $(srcdir)/lightning/ppc/fp.h $(srcdir)/lightning/ppc/fp-common.h list.@LTO@: $(srcdir)/schpriv.h $(srcdir)/schexn.h $(SCONFIG) $(srcdir)/../include/scheme.h \ $(srcdir)/../src/stypes.h module.@LTO@: $(srcdir)/schpriv.h $(srcdir)/schexn.h $(SCONFIG) $(srcdir)/../include/scheme.h \ diff --git a/src/mzscheme/src/cstartup.inc b/src/mzscheme/src/cstartup.inc index cb859c37ba..087b354cfa 100644 --- a/src/mzscheme/src/cstartup.inc +++ b/src/mzscheme/src/cstartup.inc @@ -1,10 +1,10 @@ { - static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,52,50,0,0,0,1,0,0,6,0,9,0, + static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,53,50,0,0,0,1,0,0,6,0,9,0, 18,0,22,0,35,0,38,0,43,0,50,0,55,0,60,0,67,0,74,0,78, 0,84,0,98,0,112,0,115,0,119,0,121,0,132,0,134,0,148,0,155,0, 177,0,179,0,193,0,253,0,23,1,32,1,41,1,51,1,87,1,126,1,165, 1,234,1,42,2,130,2,194,2,199,2,219,2,110,3,130,3,181,3,247,3, -132,4,34,5,84,5,107,5,186,5,0,0,201,7,0,0,65,98,101,103,105, +132,4,34,5,84,5,107,5,186,5,0,0,204,7,0,0,65,98,101,103,105, 110,29,11,11,68,104,101,114,101,45,115,116,120,63,108,101,116,72,112,97,114, 97,109,101,116,101,114,105,122,101,62,111,114,64,108,101,116,42,66,117,110,108, 101,115,115,64,99,111,110,100,64,119,104,101,110,66,108,101,116,114,101,99,66, @@ -29,15 +29,15 @@ 248,22,72,248,22,66,23,195,2,248,22,65,193,249,22,190,3,80,158,38,35, 251,22,74,2,17,248,22,65,23,200,2,249,22,64,2,13,248,22,66,23,202, 1,11,18,16,2,101,10,8,31,8,30,8,29,8,28,8,27,16,4,11,11, -2,18,3,1,7,101,110,118,57,55,57,52,16,4,11,11,2,19,3,1,7, -101,110,118,57,55,57,53,93,8,224,252,60,0,0,95,9,8,224,252,60,0, +2,18,3,1,7,101,110,118,57,55,57,51,16,4,11,11,2,19,3,1,7, +101,110,118,57,55,57,52,93,8,224,252,60,0,0,95,9,8,224,252,60,0, 0,2,2,27,248,22,66,248,22,133,4,23,197,1,28,248,22,72,23,194,2, 20,15,159,36,35,36,28,248,22,72,248,22,66,23,195,2,248,22,65,193,249, 22,190,3,80,158,38,35,250,22,74,2,20,248,22,74,249,22,74,248,22,74, 2,21,248,22,65,23,202,2,251,22,74,2,17,2,21,2,21,249,22,64,2, 6,248,22,66,23,205,1,18,16,2,101,11,8,31,8,30,8,29,8,28,8, -27,16,4,11,11,2,18,3,1,7,101,110,118,57,55,57,55,16,4,11,11, -2,19,3,1,7,101,110,118,57,55,57,56,93,8,224,253,60,0,0,95,9, +27,16,4,11,11,2,18,3,1,7,101,110,118,57,55,57,54,16,4,11,11, +2,19,3,1,7,101,110,118,57,55,57,55,93,8,224,253,60,0,0,95,9, 8,224,253,60,0,0,2,2,248,22,133,4,193,27,248,22,133,4,194,249,22, 64,248,22,74,248,22,65,196,248,22,66,195,27,248,22,66,248,22,133,4,23, 197,1,249,22,190,3,80,158,38,35,28,248,22,52,248,22,191,3,248,22,65, @@ -68,48 +68,48 @@ 249,22,162,8,248,22,191,3,248,22,65,23,201,2,64,101,108,115,101,10,248, 22,65,23,198,2,250,22,75,2,20,9,248,22,66,23,201,1,249,22,64,2, 9,248,22,66,23,203,1,100,8,31,8,30,8,29,8,28,8,27,16,4,11, -11,2,18,3,1,7,101,110,118,57,56,50,48,16,4,11,11,2,19,3,1, -7,101,110,118,57,56,50,49,93,8,224,254,60,0,0,18,16,2,158,94,10, +11,2,18,3,1,7,101,110,118,57,56,49,57,16,4,11,11,2,19,3,1, +7,101,110,118,57,56,50,48,93,8,224,254,60,0,0,18,16,2,158,94,10, 64,118,111,105,100,8,47,95,9,8,224,254,60,0,0,2,2,27,248,22,66, 248,22,133,4,196,249,22,190,3,80,158,38,35,28,248,22,52,248,22,191,3, 248,22,65,197,250,22,74,2,26,248,22,74,248,22,65,199,248,22,89,198,27, 248,22,191,3,248,22,65,197,250,22,74,2,26,248,22,74,248,22,65,197,250, 22,75,2,23,248,22,66,199,248,22,66,202,159,35,20,103,159,35,16,1,2, -1,16,0,83,158,41,20,100,141,69,35,37,109,105,110,45,115,116,120,2,2, +1,16,0,83,158,41,20,100,143,69,35,37,109,105,110,45,115,116,120,2,2, 11,10,11,10,35,80,158,35,35,20,103,159,35,16,0,16,0,11,11,16,1, -2,3,36,16,0,35,11,11,38,35,11,11,16,10,2,4,2,5,2,6,2, -7,2,8,2,9,2,10,2,11,2,12,2,13,16,10,11,11,11,11,11,11, -11,11,11,11,16,10,2,4,2,5,2,6,2,7,2,8,2,9,2,10,2, -11,2,12,2,13,35,45,36,11,11,16,0,16,0,16,0,35,35,11,11,11, -16,0,16,0,16,0,35,35,16,11,16,5,93,2,3,20,15,159,35,35,35, -35,20,103,159,35,16,0,16,1,33,32,10,16,5,93,2,8,89,162,8,44, -36,52,9,223,0,33,33,35,20,103,159,35,16,1,20,25,159,36,2,2,2, -3,16,0,11,16,5,93,2,10,89,162,8,44,36,52,9,223,0,33,34,35, -20,103,159,35,16,1,20,25,159,36,2,2,2,3,16,0,11,16,5,93,2, -13,89,162,8,44,36,52,9,223,0,33,35,35,20,103,159,35,16,1,20,25, -159,36,2,2,2,3,16,1,33,36,11,16,5,93,2,6,89,162,8,44,36, -55,9,223,0,33,37,35,20,103,159,35,16,1,20,25,159,36,2,2,2,3, -16,1,33,38,11,16,5,93,2,4,89,162,8,44,36,57,9,223,0,33,41, +2,3,36,16,0,35,16,0,35,11,11,38,35,11,11,16,10,2,4,2,5, +2,6,2,7,2,8,2,9,2,10,2,11,2,12,2,13,16,10,11,11,11, +11,11,11,11,11,11,11,16,10,2,4,2,5,2,6,2,7,2,8,2,9, +2,10,2,11,2,12,2,13,35,45,36,11,11,16,0,16,0,16,0,35,35, +11,11,11,16,0,16,0,16,0,35,35,16,11,16,5,93,2,3,20,15,159, +35,35,35,35,20,103,159,35,16,0,16,1,33,32,10,16,5,93,2,8,89, +162,8,44,36,52,9,223,0,33,33,35,20,103,159,35,16,1,20,25,159,36, +2,2,2,3,16,0,11,16,5,93,2,10,89,162,8,44,36,52,9,223,0, +33,34,35,20,103,159,35,16,1,20,25,159,36,2,2,2,3,16,0,11,16, +5,93,2,13,89,162,8,44,36,52,9,223,0,33,35,35,20,103,159,35,16, +1,20,25,159,36,2,2,2,3,16,1,33,36,11,16,5,93,2,6,89,162, +8,44,36,55,9,223,0,33,37,35,20,103,159,35,16,1,20,25,159,36,2, +2,2,3,16,1,33,38,11,16,5,93,2,4,89,162,8,44,36,57,9,223, +0,33,41,35,20,103,159,35,16,1,20,25,159,36,2,2,2,3,16,0,11, +16,5,93,2,11,89,162,8,44,36,52,9,223,0,33,43,35,20,103,159,35, +16,1,20,25,159,36,2,2,2,3,16,0,11,16,5,93,2,7,89,162,8, +44,36,53,9,223,0,33,44,35,20,103,159,35,16,1,20,25,159,36,2,2, +2,3,16,0,11,16,5,93,2,5,89,162,8,44,36,54,9,223,0,33,45, 35,20,103,159,35,16,1,20,25,159,36,2,2,2,3,16,0,11,16,5,93, -2,11,89,162,8,44,36,52,9,223,0,33,43,35,20,103,159,35,16,1,20, -25,159,36,2,2,2,3,16,0,11,16,5,93,2,7,89,162,8,44,36,53, -9,223,0,33,44,35,20,103,159,35,16,1,20,25,159,36,2,2,2,3,16, -0,11,16,5,93,2,5,89,162,8,44,36,54,9,223,0,33,45,35,20,103, -159,35,16,1,20,25,159,36,2,2,2,3,16,0,11,16,5,93,2,9,89, -162,8,44,36,57,9,223,0,33,46,35,20,103,159,35,16,1,20,25,159,36, -2,2,2,3,16,1,33,48,11,16,5,93,2,12,89,162,8,44,36,53,9, -223,0,33,49,35,20,103,159,35,16,1,20,25,159,36,2,2,2,3,16,0, -11,16,0,94,2,15,2,16,93,2,15,9,9,35,0}; - EVAL_ONE_SIZED_STR((char *)expr, 2114); +2,9,89,162,8,44,36,57,9,223,0,33,46,35,20,103,159,35,16,1,20, +25,159,36,2,2,2,3,16,1,33,48,11,16,5,93,2,12,89,162,8,44, +36,53,9,223,0,33,49,35,20,103,159,35,16,1,20,25,159,36,2,2,2, +3,16,0,11,16,0,94,2,15,2,16,93,2,15,9,9,35,0}; + EVAL_ONE_SIZED_STR((char *)expr, 2117); } { - static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,52,60,0,0,0,1,0,0,3,0,16,0, + static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,53,60,0,0,0,1,0,0,3,0,16,0, 21,0,38,0,53,0,71,0,87,0,97,0,115,0,135,0,151,0,169,0,200, 0,229,0,251,0,9,1,15,1,29,1,34,1,44,1,52,1,80,1,112,1, 157,1,202,1,226,1,9,2,11,2,68,2,158,3,199,3,33,5,137,5,241, 5,102,6,116,6,150,6,166,6,16,8,30,8,193,8,194,9,194,10,201,10, 208,10,215,10,90,11,103,11,58,12,160,12,173,12,195,12,147,13,51,14,122, -15,130,15,138,15,164,15,18,16,0,0,67,19,0,0,29,11,11,72,112,97, +15,130,15,138,15,164,15,18,16,0,0,70,19,0,0,29,11,11,72,112,97, 116,104,45,115,116,114,105,110,103,63,64,98,115,98,115,76,110,111,114,109,97, 108,45,99,97,115,101,45,112,97,116,104,74,45,99,104,101,99,107,45,114,101, 108,112,97,116,104,77,45,99,104,101,99,107,45,99,111,108,108,101,99,116,105, @@ -306,7 +306,7 @@ 173,3,23,202,1,28,192,192,35,249,22,151,5,23,197,1,83,158,39,20,97, 95,89,162,8,44,35,47,9,224,3,2,33,58,23,195,1,23,196,1,27,248, 22,136,5,23,195,1,248,80,159,38,53,36,193,159,35,20,103,159,35,16,1, -65,98,101,103,105,110,16,0,83,158,41,20,100,141,67,35,37,117,116,105,108, +65,98,101,103,105,110,16,0,83,158,41,20,100,143,67,35,37,117,116,105,108, 115,2,1,11,11,10,10,42,80,158,35,35,20,103,159,37,16,17,30,2,1, 2,2,193,30,2,1,2,3,193,30,2,1,2,4,193,30,2,1,2,5,193, 30,2,1,2,6,193,30,2,1,2,7,193,30,2,1,2,8,193,30,2,1, @@ -315,63 +315,63 @@ 2,16,193,30,2,18,1,20,112,97,114,97,109,101,116,101,114,105,122,97,116, 105,111,110,45,107,101,121,4,30,2,18,1,23,101,120,116,101,110,100,45,112, 97,114,97,109,101,116,101,114,105,122,97,116,105,111,110,3,16,0,11,11,16, -0,35,16,4,2,6,2,5,2,3,2,9,39,11,11,38,35,11,11,16,11, -2,8,2,7,2,16,2,15,2,13,2,12,2,4,2,11,2,14,2,10,2, -2,16,11,11,11,11,11,11,11,11,11,11,11,11,16,11,2,8,2,7,2, -16,2,15,2,13,2,12,2,4,2,11,2,14,2,10,2,2,46,46,36,11, -11,16,0,16,0,16,0,35,35,11,11,11,16,0,16,0,16,0,35,35,16, -0,16,17,83,158,35,16,2,89,162,43,36,48,2,19,223,0,33,29,80,159, -35,53,36,83,158,35,16,2,89,162,8,44,36,55,2,19,223,0,33,30,80, -159,35,52,36,83,158,35,16,2,32,0,89,162,43,36,44,2,2,222,33,31, -80,159,35,35,36,83,158,35,16,2,249,22,159,6,7,92,7,92,80,159,35, -36,36,83,158,35,16,2,89,162,43,36,53,2,4,223,0,33,32,80,159,35, -37,36,83,158,35,16,2,32,0,89,162,8,44,37,49,2,5,222,33,33,80, -159,35,38,36,83,158,35,16,2,32,0,89,162,8,44,38,50,2,6,222,33, -35,80,159,35,39,36,83,158,35,16,2,89,162,8,45,37,47,2,7,223,0, -33,37,80,159,35,40,36,83,158,35,16,2,32,0,89,162,43,39,51,2,8, -222,33,40,80,159,35,41,36,83,158,35,16,2,32,0,89,162,43,38,49,2, -9,222,33,41,80,159,35,42,36,83,158,35,16,2,32,0,89,162,43,37,52, -2,10,222,33,42,80,159,35,43,36,83,158,35,16,2,32,0,89,162,43,37, -53,2,11,222,33,43,80,159,35,44,36,83,158,35,16,2,32,0,89,162,43, -36,43,2,12,222,33,44,80,159,35,45,36,83,158,35,16,2,83,158,38,20, -96,96,2,13,89,162,43,35,43,9,223,0,33,45,89,162,43,36,44,9,223, -0,33,46,89,162,43,37,54,9,223,0,33,47,80,159,35,46,36,83,158,35, -16,2,27,248,22,182,13,248,22,168,7,27,28,249,22,162,8,247,22,176,7, -2,21,6,1,1,59,6,1,1,58,250,22,141,7,6,14,14,40,91,94,126, -97,93,42,41,126,97,40,46,42,41,23,196,2,23,196,1,89,162,8,44,37, -47,2,14,223,0,33,50,80,159,35,47,36,83,158,35,16,2,83,158,38,20, -96,96,2,15,89,162,8,44,38,53,9,223,0,33,55,89,162,43,37,46,9, -223,0,33,56,89,162,43,36,45,9,223,0,33,57,80,159,35,48,36,83,158, -35,16,2,89,162,43,38,51,2,16,223,0,33,59,80,159,35,49,36,94,29, -94,2,17,68,35,37,107,101,114,110,101,108,11,29,94,2,17,69,35,37,109, -105,110,45,115,116,120,11,9,9,9,35,0}; - EVAL_ONE_SIZED_STR((char *)expr, 5072); +0,35,16,0,35,16,4,2,6,2,5,2,3,2,9,39,11,11,38,35,11, +11,16,11,2,8,2,7,2,16,2,15,2,13,2,12,2,4,2,11,2,14, +2,10,2,2,16,11,11,11,11,11,11,11,11,11,11,11,11,16,11,2,8, +2,7,2,16,2,15,2,13,2,12,2,4,2,11,2,14,2,10,2,2,46, +46,36,11,11,16,0,16,0,16,0,35,35,11,11,11,16,0,16,0,16,0, +35,35,16,0,16,17,83,158,35,16,2,89,162,43,36,48,2,19,223,0,33, +29,80,159,35,53,36,83,158,35,16,2,89,162,8,44,36,55,2,19,223,0, +33,30,80,159,35,52,36,83,158,35,16,2,32,0,89,162,43,36,44,2,2, +222,33,31,80,159,35,35,36,83,158,35,16,2,249,22,159,6,7,92,7,92, +80,159,35,36,36,83,158,35,16,2,89,162,43,36,53,2,4,223,0,33,32, +80,159,35,37,36,83,158,35,16,2,32,0,89,162,8,44,37,49,2,5,222, +33,33,80,159,35,38,36,83,158,35,16,2,32,0,89,162,8,44,38,50,2, +6,222,33,35,80,159,35,39,36,83,158,35,16,2,89,162,8,45,37,47,2, +7,223,0,33,37,80,159,35,40,36,83,158,35,16,2,32,0,89,162,43,39, +51,2,8,222,33,40,80,159,35,41,36,83,158,35,16,2,32,0,89,162,43, +38,49,2,9,222,33,41,80,159,35,42,36,83,158,35,16,2,32,0,89,162, +43,37,52,2,10,222,33,42,80,159,35,43,36,83,158,35,16,2,32,0,89, +162,43,37,53,2,11,222,33,43,80,159,35,44,36,83,158,35,16,2,32,0, +89,162,43,36,43,2,12,222,33,44,80,159,35,45,36,83,158,35,16,2,83, +158,38,20,96,96,2,13,89,162,43,35,43,9,223,0,33,45,89,162,43,36, +44,9,223,0,33,46,89,162,43,37,54,9,223,0,33,47,80,159,35,46,36, +83,158,35,16,2,27,248,22,182,13,248,22,168,7,27,28,249,22,162,8,247, +22,176,7,2,21,6,1,1,59,6,1,1,58,250,22,141,7,6,14,14,40, +91,94,126,97,93,42,41,126,97,40,46,42,41,23,196,2,23,196,1,89,162, +8,44,37,47,2,14,223,0,33,50,80,159,35,47,36,83,158,35,16,2,83, +158,38,20,96,96,2,15,89,162,8,44,38,53,9,223,0,33,55,89,162,43, +37,46,9,223,0,33,56,89,162,43,36,45,9,223,0,33,57,80,159,35,48, +36,83,158,35,16,2,89,162,43,38,51,2,16,223,0,33,59,80,159,35,49, +36,94,29,94,2,17,68,35,37,107,101,114,110,101,108,11,29,94,2,17,69, +35,37,109,105,110,45,115,116,120,11,9,9,9,35,0}; + EVAL_ONE_SIZED_STR((char *)expr, 5075); } { - static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,52,8,0,0,0,1,0,0,6,0,19,0, -34,0,48,0,62,0,76,0,111,0,0,0,3,1,0,0,65,113,117,111,116, + static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,53,8,0,0,0,1,0,0,6,0,19,0, +34,0,48,0,62,0,76,0,111,0,0,0,6,1,0,0,65,113,117,111,116, 101,29,94,2,1,67,35,37,117,116,105,108,115,11,29,94,2,1,69,35,37, 110,101,116,119,111,114,107,11,29,94,2,1,68,35,37,112,97,114,97,109,122, 11,29,94,2,1,68,35,37,101,120,112,111,98,115,11,29,94,2,1,68,35, 37,107,101,114,110,101,108,11,98,10,35,11,8,186,245,97,159,2,2,35,35, 159,2,3,35,35,159,2,4,35,35,159,2,5,35,35,159,2,6,35,35,16, 0,159,35,20,103,159,35,16,1,65,98,101,103,105,110,16,0,83,158,41,20, -100,141,69,35,37,98,117,105,108,116,105,110,29,11,11,11,10,10,18,96,11, +100,143,69,35,37,98,117,105,108,116,105,110,29,11,11,11,10,10,18,96,11, 42,42,42,35,80,158,35,35,20,103,159,35,16,0,16,0,11,11,16,0,35, -16,0,35,11,11,38,35,11,11,16,0,16,0,16,0,35,35,36,11,11,16, -0,16,0,16,0,35,35,11,11,11,16,0,16,0,16,0,35,35,16,0,16, -0,99,2,6,2,5,29,94,2,1,69,35,37,102,111,114,101,105,103,110,11, -2,4,2,3,2,2,29,94,2,1,67,35,37,112,108,97,99,101,11,9,9, -9,35,0}; - EVAL_ONE_SIZED_STR((char *)expr, 296); +16,0,35,16,0,35,11,11,38,35,11,11,16,0,16,0,16,0,35,35,36, +11,11,16,0,16,0,16,0,35,35,11,11,11,16,0,16,0,16,0,35,35, +16,0,16,0,99,2,6,2,5,29,94,2,1,69,35,37,102,111,114,101,105, +103,110,11,2,4,2,3,2,2,29,94,2,1,67,35,37,112,108,97,99,101, +11,9,9,9,35,0}; + EVAL_ONE_SIZED_STR((char *)expr, 299); } { - static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,52,53,0,0,0,1,0,0,3,0,14,0, + static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,53,53,0,0,0,1,0,0,3,0,14,0, 41,0,47,0,60,0,74,0,96,0,122,0,134,0,152,0,172,0,184,0,200, 0,223,0,3,1,8,1,13,1,18,1,27,1,32,1,63,1,67,1,75,1, 83,1,91,1,194,1,239,1,3,2,31,2,62,2,117,2,127,2,174,2,184, 2,191,2,78,4,91,4,110,4,229,4,241,4,137,5,151,5,15,6,21,6, -35,6,62,6,147,6,149,6,214,6,149,12,208,12,240,12,0,0,168,15,0, +35,6,62,6,147,6,149,6,214,6,149,12,208,12,240,12,0,0,171,15,0, 0,29,11,11,70,100,108,108,45,115,117,102,102,105,120,1,25,100,101,102,97, 117,108,116,45,108,111,97,100,47,117,115,101,45,99,111,109,112,105,108,101,100, 65,113,117,111,116,101,29,94,2,4,67,35,37,117,116,105,108,115,11,29,94, @@ -530,7 +530,7 @@ 33,43,89,162,43,38,48,9,223,1,33,44,89,162,43,39,8,30,9,225,2, 3,0,33,50,208,87,95,248,22,150,4,248,80,158,37,49,247,22,183,11,248, 22,188,4,80,158,36,36,248,22,174,12,80,159,36,41,36,159,35,20,103,159, -35,16,1,65,98,101,103,105,110,16,0,83,158,41,20,100,141,66,35,37,98, +35,16,1,65,98,101,103,105,110,16,0,83,158,41,20,100,143,66,35,37,98, 111,111,116,2,1,11,11,10,10,36,80,158,35,35,20,103,159,39,16,19,30, 2,1,2,2,193,30,2,1,2,3,193,30,2,5,72,112,97,116,104,45,115, 116,114,105,110,103,63,10,30,2,5,75,112,97,116,104,45,97,100,100,45,115, @@ -542,26 +542,27 @@ 1,2,14,193,30,2,1,2,15,193,30,2,5,69,45,102,105,110,100,45,99, 111,108,0,30,2,5,76,110,111,114,109,97,108,45,99,97,115,101,45,112,97, 116,104,6,30,2,5,79,112,97,116,104,45,114,101,112,108,97,99,101,45,115, -117,102,102,105,120,9,30,2,1,2,16,193,16,0,11,11,16,0,35,16,11, -2,10,2,11,2,8,2,9,2,12,2,13,2,3,2,7,2,2,2,15,2, -14,46,11,11,38,35,11,11,16,1,2,16,16,1,11,16,1,2,16,36,36, -36,11,11,16,0,16,0,16,0,35,35,11,11,11,16,0,16,0,16,0,35, -35,16,0,16,16,83,158,35,16,2,89,162,43,36,44,9,223,0,33,24,80, -159,35,57,36,83,158,35,16,2,89,162,43,36,44,9,223,0,33,25,80,159, -35,56,36,83,158,35,16,2,89,162,43,36,48,67,103,101,116,45,100,105,114, -223,0,33,26,80,159,35,55,36,83,158,35,16,2,89,162,43,37,48,68,119, -105,116,104,45,100,105,114,223,0,33,27,80,159,35,54,36,83,158,35,16,2, -248,22,176,7,69,115,111,45,115,117,102,102,105,120,80,159,35,35,36,83,158, -35,16,2,89,162,43,37,59,2,3,223,0,33,36,80,159,35,36,36,83,158, -35,16,2,32,0,89,162,8,44,36,41,2,7,222,192,80,159,35,41,36,83, -158,35,16,2,247,22,125,80,159,35,42,36,83,158,35,16,2,247,22,124,80, -159,35,43,36,83,158,35,16,2,247,22,60,80,159,35,44,36,83,158,35,16, -2,248,22,18,74,109,111,100,117,108,101,45,108,111,97,100,105,110,103,80,159, -35,45,36,83,158,35,16,2,11,80,158,35,46,83,158,35,16,2,11,80,158, -35,47,83,158,35,16,2,32,0,89,162,43,37,44,2,14,222,33,42,80,159, -35,48,36,83,158,35,16,2,89,162,8,44,36,44,2,15,223,0,33,51,80, -159,35,49,36,83,158,35,16,2,89,162,43,35,43,2,16,223,0,33,52,80, -159,35,53,36,95,29,94,2,4,68,35,37,107,101,114,110,101,108,11,29,94, -2,4,69,35,37,109,105,110,45,115,116,120,11,2,5,9,9,9,35,0}; - EVAL_ONE_SIZED_STR((char *)expr, 4135); +117,102,102,105,120,9,30,2,1,2,16,193,16,0,11,11,16,0,35,16,0, +35,16,11,2,10,2,11,2,8,2,9,2,12,2,13,2,3,2,7,2,2, +2,15,2,14,46,11,11,38,35,11,11,16,1,2,16,16,1,11,16,1,2, +16,36,36,36,11,11,16,0,16,0,16,0,35,35,11,11,11,16,0,16,0, +16,0,35,35,16,0,16,16,83,158,35,16,2,89,162,43,36,44,9,223,0, +33,24,80,159,35,57,36,83,158,35,16,2,89,162,43,36,44,9,223,0,33, +25,80,159,35,56,36,83,158,35,16,2,89,162,43,36,48,67,103,101,116,45, +100,105,114,223,0,33,26,80,159,35,55,36,83,158,35,16,2,89,162,43,37, +48,68,119,105,116,104,45,100,105,114,223,0,33,27,80,159,35,54,36,83,158, +35,16,2,248,22,176,7,69,115,111,45,115,117,102,102,105,120,80,159,35,35, +36,83,158,35,16,2,89,162,43,37,59,2,3,223,0,33,36,80,159,35,36, +36,83,158,35,16,2,32,0,89,162,8,44,36,41,2,7,222,192,80,159,35, +41,36,83,158,35,16,2,247,22,125,80,159,35,42,36,83,158,35,16,2,247, +22,124,80,159,35,43,36,83,158,35,16,2,247,22,60,80,159,35,44,36,83, +158,35,16,2,248,22,18,74,109,111,100,117,108,101,45,108,111,97,100,105,110, +103,80,159,35,45,36,83,158,35,16,2,11,80,158,35,46,83,158,35,16,2, +11,80,158,35,47,83,158,35,16,2,32,0,89,162,43,37,44,2,14,222,33, +42,80,159,35,48,36,83,158,35,16,2,89,162,8,44,36,44,2,15,223,0, +33,51,80,159,35,49,36,83,158,35,16,2,89,162,43,35,43,2,16,223,0, +33,52,80,159,35,53,36,95,29,94,2,4,68,35,37,107,101,114,110,101,108, +11,29,94,2,4,69,35,37,109,105,110,45,115,116,120,11,2,5,9,9,9, +35,0}; + EVAL_ONE_SIZED_STR((char *)expr, 4138); } diff --git a/src/mzscheme/src/env.c b/src/mzscheme/src/env.c index bb99733d51..3c25b28ce0 100644 --- a/src/mzscheme/src/env.c +++ b/src/mzscheme/src/env.c @@ -288,7 +288,6 @@ static void init_toplevel_local_offsets_hashtable_caches() } } - /* READ-ONLY GLOBAL structures ONE-TIME initialization */ Scheme_Env *scheme_engine_instance_init() { Scheme_Env *env; @@ -325,6 +324,16 @@ Scheme_Env *scheme_engine_instance_init() { #ifndef MZ_PRECISE_GC scheme_init_ephemerons(); #endif + +/* These calls must be made here so that they allocate out of the master GC */ + scheme_init_symbol_table(); + scheme_init_module_path_table(); + + +#if defined(MZ_PRECISE_GC) && defined(MZ_USE_PLACES) + GC_switch_out_master_gc(); + spawn_master_scheme_place(); +#endif place_instance_init_pre_kernel(stack_base); make_kernel_env(); @@ -455,7 +464,6 @@ static void make_kernel_env(void) /* The ordering of the first few init calls is important, so add to the end of the list, not the beginning. */ - MZTIMEIT(symbol-table, scheme_init_symbol_table()); MZTIMEIT(type, scheme_init_type(env)); MZTIMEIT(symbol-type, scheme_init_symbol_type(env)); MZTIMEIT(fun, scheme_init_fun(env)); diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c index 3da8a2ce01..f30247d33c 100644 --- a/src/mzscheme/src/eval.c +++ b/src/mzscheme/src/eval.c @@ -8431,15 +8431,16 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands, case scheme_with_cont_mark_type: { Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)obj; - GC_CAN_IGNORE Scheme_Object *key, *val; + Scheme_Object *key; + GC_CAN_IGNORE Scheme_Object *val; UPDATE_THREAD_RSPTR(); key = wcm->key; if (SCHEME_TYPE(key) < _scheme_values_types_) - key = _scheme_eval_linked_expr_wp(wcm->key, p); + key = _scheme_eval_linked_expr_wp(key, p); val = wcm->val; if (SCHEME_TYPE(val) < _scheme_values_types_) - val = _scheme_eval_linked_expr_wp(wcm->val, p); + val = _scheme_eval_linked_expr_wp(val, p); scheme_set_cont_mark(key, val); diff --git a/src/mzscheme/src/module.c b/src/mzscheme/src/module.c index bb5baf1878..5873332de8 100644 --- a/src/mzscheme/src/module.c +++ b/src/mzscheme/src/module.c @@ -248,7 +248,8 @@ static char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash char **_phase1_protects); static Scheme_Object **compute_indirects(Scheme_Env *genv, Scheme_Module_Phase_Exports *pt, - int *_count); + int *_count, + int vars); static void start_module(Scheme_Module *m, Scheme_Env *env, int restart, Scheme_Object *syntax_idx, int eval_exp, int eval_run, long base_phase, Scheme_Object *cycle_list); static void finish_expstart_module(Scheme_Env *menv); @@ -2369,6 +2370,11 @@ void scheme_prep_namespace_rename(Scheme_Env *menv) scheme_extend_module_rename(one_rn, m->self_modidx, name, name, m->self_modidx, name, 0, scheme_make_integer(0), NULL, 0); } + for (i = 0; i < m->num_indirect_syntax_provides; i++) { + name = m->indirect_syntax_provides[i]; + scheme_extend_module_rename(one_rn, m->self_modidx, name, name, m->self_modidx, name, 0, + scheme_make_integer(0), NULL, 0); + } one_rn = scheme_get_module_rename_from_set(rns, scheme_make_integer(1), 1); @@ -2710,7 +2716,13 @@ static Scheme_Object *module_path_index_join(int argc, Scheme_Object *argv[]) return scheme_make_modidx(argv[0], argv[1], scheme_false); } -Scheme_Object *scheme_intern_resolved_module_path(Scheme_Object *o) +void scheme_init_module_path_table() +{ + REGISTER_SO(modpath_table); + modpath_table = scheme_make_weak_equal_table(); +} + +Scheme_Object *scheme_intern_resolved_module_path_worker(Scheme_Object *o) { Scheme_Object *rmp; Scheme_Bucket *b; @@ -2718,11 +2730,6 @@ Scheme_Object *scheme_intern_resolved_module_path(Scheme_Object *o) mzrt_mutex_lock(modpath_table_mutex); - if (!modpath_table) { - REGISTER_SO(modpath_table); - modpath_table = scheme_make_weak_equal_table(); - } - rmp = scheme_alloc_small_object(); rmp->type = scheme_resolved_module_path_type; SCHEME_PTR_VAL(rmp) = o; @@ -2738,6 +2745,21 @@ Scheme_Object *scheme_intern_resolved_module_path(Scheme_Object *o) return return_value; } +Scheme_Object *scheme_intern_resolved_module_path(Scheme_Object *o) +{ +#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC) + mz_proc_thread *self; + self = proc_thread_self; + if ( scheme_master_proc_thread && scheme_master_proc_thread != proc_thread_self ) { + int return_msg_type; + void *return_payload; + pt_mbox_send_recv(scheme_master_proc_thread->mbox, 1, o, self->mbox, &return_msg_type, &return_payload); + return (Scheme_Object*) return_payload; + } +#endif + return scheme_intern_resolved_module_path_worker(o); +} + static Scheme_Object *resolved_module_path_p(int argc, Scheme_Object *argv[]) { return (SCHEME_MODNAMEP(argv[0]) @@ -5678,9 +5700,9 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Object *post_ex_rn_set; /* phase -> post_ex_rn-like rename */ Scheme_Hash_Table *tables; /* phase -> (vector toplevels requires syntaxes) */ Scheme_Object *exclude_hint = scheme_false, *lift_data; - Scheme_Object **exis, **et_exis; + Scheme_Object **exis, **et_exis, **exsis; Scheme_Object *lift_ctx; - int exicount, et_exicount; + int exicount, et_exicount, exsicount; char *exps, *et_exps; int all_simple_renames = 1; int maybe_has_lifts = 0; @@ -6395,8 +6417,9 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, form, &et_exps); /* Compute indirect provides (which is everything at the top-level): */ - exis = compute_indirects(env->genv, env->genv->module->me->rt, &exicount); - et_exis = compute_indirects(env->genv->exp_env, env->genv->module->me->et, &et_exicount); + exis = compute_indirects(env->genv, env->genv->module->me->rt, &exicount, 1); + exsis = compute_indirects(env->genv, env->genv->module->me->rt, &exsicount, 0); + et_exis = compute_indirects(env->genv->exp_env, env->genv->module->me->et, &et_exicount, 1); if (rec[drec].comp || (rec[drec].depth != -2)) { scheme_clean_dead_env(env->genv); @@ -6519,6 +6542,14 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, env->genv->module->indirect_provides = exis; env->genv->module->num_indirect_provides = exicount; + if (all_simple_renames) { + env->genv->module->indirect_syntax_provides = exsis; + env->genv->module->num_indirect_syntax_provides = exsicount; + } else { + env->genv->module->indirect_syntax_provides = NULL; + env->genv->module->num_indirect_syntax_provides = 0; + } + env->genv->module->et_indirect_provides = et_exis; env->genv->module->num_indirect_et_provides = et_exicount; @@ -6930,18 +6961,34 @@ int compute_reprovides(Scheme_Hash_Table *all_provided, static Scheme_Object **compute_indirects(Scheme_Env *genv, Scheme_Module_Phase_Exports *pt, - int *_count) + int *_count, + int vars) { - int i, count, j; + int i, count, j, start, end; Scheme_Bucket **bs, *b; Scheme_Object **exsns = pt->provide_src_names, **exis; - int exvcount = pt->num_var_provides, exicount; + int exicount; + Scheme_Bucket_Table *t; - if (!genv->toplevel) + if (vars) { + start = 0; + end = pt->num_var_provides; + } else { + start = pt->num_var_provides; + end = pt->num_provides; + } + + if (vars) + t = genv->toplevel; + else + t = genv->syntax; + + + if (!t) count = 0; else { - bs = genv->toplevel->buckets; - for (count = 0, i = genv->toplevel->size; i--; ) { + bs = t->buckets; + for (count = 0, i = t->size; i--; ) { b = bs[i]; if (b && b->val) count++; @@ -6955,7 +7002,7 @@ static Scheme_Object **compute_indirects(Scheme_Env *genv, exis = MALLOC_N(Scheme_Object *, count); - for (count = 0, i = genv->toplevel->size; i--; ) { + for (count = 0, i = t->size; i--; ) { b = bs[i]; if (b && b->val) { Scheme_Object *name; @@ -6963,12 +7010,12 @@ static Scheme_Object **compute_indirects(Scheme_Env *genv, name = (Scheme_Object *)b->key; /* If the name is directly provided, no need for indirect... */ - for (j = 0; j < exvcount; j++) { + for (j = start; j < end; j++) { if (SAME_OBJ(name, exsns[j])) break; } - if (j == exvcount) + if (j == end) exis[count++] = name; } } @@ -9099,6 +9146,14 @@ static Scheme_Object *write_module(Scheme_Object *obj) } l = cons(v, l); + count = m->num_indirect_syntax_provides; + l = cons(scheme_make_integer(count), l); + v = scheme_make_vector(count, NULL); + for (i = 0; i < count; i++) { + SCHEME_VEC_ELS(v)[i] = m->indirect_syntax_provides[i]; + } + l = cons(v, l); + count = m->num_indirect_et_provides; l = cons(scheme_make_integer(count), l); v = scheme_make_vector(count, NULL); @@ -9249,6 +9304,24 @@ static Scheme_Object *read_module(Scheme_Object *obj) count = SCHEME_INT_VAL(nie); + if (!SCHEME_VECTORP(ie) || (SCHEME_VEC_SIZE(ie) != count)) return_NULL(); + v = MALLOC_N(Scheme_Object *, count); + for (i = 0; i < count; i++) { + v[i] = SCHEME_VEC_ELS(ie)[i]; + } + m->indirect_syntax_provides = v; + m->num_indirect_syntax_provides = count; + + if (!SCHEME_PAIRP(obj)) return_NULL(); + ie = SCHEME_CAR(obj); + obj = SCHEME_CDR(obj); + + if (!SCHEME_PAIRP(obj)) return_NULL(); + nie = SCHEME_CAR(obj); + obj = SCHEME_CDR(obj); + + count = SCHEME_INT_VAL(nie); + if (!SCHEME_VECTORP(ie) || (SCHEME_VEC_SIZE(ie) != count)) return_NULL(); v = MALLOC_N(Scheme_Object *, count); for (i = 0; i < count; i++) { diff --git a/src/mzscheme/src/mzmark.c b/src/mzscheme/src/mzmark.c index a78bf7de5e..ec88cbf267 100644 --- a/src/mzscheme/src/mzmark.c +++ b/src/mzscheme/src/mzmark.c @@ -2346,6 +2346,8 @@ static int module_val_MARK(void *p) { gcMARK(m->provide_protects); gcMARK(m->indirect_provides); + gcMARK(m->indirect_syntax_provides); + gcMARK(m->et_provide_protects); gcMARK(m->et_indirect_provides); @@ -2390,6 +2392,8 @@ static int module_val_FIXUP(void *p) { gcFIXUP(m->provide_protects); gcFIXUP(m->indirect_provides); + gcFIXUP(m->indirect_syntax_provides); + gcFIXUP(m->et_provide_protects); gcFIXUP(m->et_indirect_provides); diff --git a/src/mzscheme/src/mzmarksrc.c b/src/mzscheme/src/mzmarksrc.c index 3ea084b71d..6b9bd076bd 100644 --- a/src/mzscheme/src/mzmarksrc.c +++ b/src/mzscheme/src/mzmarksrc.c @@ -937,6 +937,8 @@ module_val { gcMARK(m->provide_protects); gcMARK(m->indirect_provides); + gcMARK(m->indirect_syntax_provides); + gcMARK(m->et_provide_protects); gcMARK(m->et_indirect_provides); diff --git a/src/mzscheme/src/mzrt.c b/src/mzscheme/src/mzrt.c index 67632fd842..c92b6d75ae 100644 --- a/src/mzscheme/src/mzrt.c +++ b/src/mzscheme/src/mzrt.c @@ -5,7 +5,7 @@ /************************************************************************/ /************************************************************************/ /************************************************************************/ - +#define MZRT_INTERNAL #include "mzrt.h" #include "schgc.h" @@ -43,29 +43,30 @@ void mzrt_set_user_break_handler(void (*user_break_handler)(int)) #endif } -static void segfault_handler(int signal_num) { +static void rungdb() { #ifdef WIN32 #else pid_t pid = getpid(); - char buffer[500]; - char buf[500]; - signal(SIGSEGV, segfault_handler); + char outbuffer[100]; + char inbuffer[10]; - fprintf(stderr, "%i %i resume(r)/gdb(d)/exit(e)?\n", signal_num, pid); + fprintf(stderr, "pid # %i resume(r)/gdb(d)/exit(e)?\n", pid); fflush(stderr); - while(read(fileno(stdin), buf, 100) <= 0){ - if(errno != EINTR){ - fprintf(stderr, "\nCould not read response, sleeping for 20 seconds.\n"); + while(1) { + while(read(fileno(stdin), inbuffer, 10) <= 0){ + if(errno != EINTR){ + fprintf(stderr, "Error detected %i\n", errno); + } } - switch(buf[0]) { + switch(inbuffer[0]) { case 'r': return; break; case 'd': - snprintf(buffer, 500, "xterm -e gdb ./mzschemecgc %d &", pid); - fprintf(stderr, "%i %i Launching GDB", signal_num, pid); - system(buffer); + snprintf(outbuffer, 100, "xterm -e gdb ./mzscheme3m %d &", pid); + fprintf(stderr, "%s\n", outbuffer); + system(outbuffer); break; case 'e': default: @@ -76,6 +77,13 @@ static void segfault_handler(int signal_num) { #endif } +static void segfault_handler(int signal_num) { + pid_t pid = getpid(); + fprintf(stderr, "sig# %i pid# %i\n", signal_num, pid); + rungdb(); +} + + void mzrt_set_segfault_debug_handler() { #ifdef WIN32 @@ -138,42 +146,64 @@ MZ_INLINE uint32_t mzrt_atomic_incr_32(volatile unsigned int *counter) { /***********************************************************************/ /* Threads */ /***********************************************************************/ +typedef struct mzrt_thread_stub_data { + void * (*start_proc)(void *); + void *data; + mz_proc_thread *thread; +} mzrt_thread_stub_data; -struct mz_proc_thread { -#ifdef WIN32 - HANDLE threadid; -#else - pthread_t threadid; -#endif -}; +void *mzrt_thread_stub(void *data){ + mzrt_thread_stub_data *stub_data = (mzrt_thread_stub_data*) data; + void * (*start_proc)(void *) = stub_data->start_proc; + void *start_proc_data = stub_data->data; + proc_thread_self = stub_data->thread; -int mz_proc_thread_self() { + free(data); + + return start_proc(start_proc_data); +} + +unsigned int mz_proc_thread_self() { #ifdef WIN32 #error !!!mz_proc_thread_id not implemented!!! #else - return (int) pthread_self(); + return (unsigned int) pthread_self(); #endif } -int mz_proc_thread_id(mz_proc_thread* thread) { +unsigned int mz_proc_thread_id(mz_proc_thread* thread) { - return (int) thread->threadid; + return (unsigned int) thread->threadid; } +mz_proc_thread* mzrt_proc_first_thread_init() { + /* initialize mz_proc_thread struct for first thread myself that wasn't created with mz_proc_thread_create, + * so it can communicate with other mz_proc_thread_created threads via pt_mboxes */ + mz_proc_thread *thread = (mz_proc_thread*)malloc(sizeof(mz_proc_thread)); + thread->mbox = pt_mbox_create(); + thread->threadid = mz_proc_thread_self(); + proc_thread_self = thread; + return thread; +} mz_proc_thread* mz_proc_thread_create(mz_proc_thread_start start_proc, void* data) { mz_proc_thread *thread = (mz_proc_thread*)malloc(sizeof(mz_proc_thread)); -#ifdef WIN32 -# ifndef MZ_PRECISE_GC +#ifdef MZ_PRECISE_GC + mzrt_thread_stub_data *stub_data = (mzrt_thread_stub_data*)malloc(sizeof(mzrt_thread_stub_data)); + thread->mbox = pt_mbox_create(); + stub_data->start_proc = start_proc; + stub_data->data = data; + stub_data->thread = thread; +# ifdef WIN32 thread->threadid = CreateThread(NULL, 0, start_proc, data, 0, NULL); # else - thread->threadid = CreateThread(NULL, 0, start_proc, data, 0, NULL); + pthread_create(&thread->threadid, NULL, mzrt_thread_stub, stub_data); # endif #else -# ifndef MZ_PRECISE_GC - GC_pthread_create(&thread->threadid, NULL, start_proc, data); +# ifdef WIN32 + thread->threadid = GC_CreateThread(NULL, 0, start_proc, data, 0, NULL); # else - pthread_create(&thread->threadid, NULL, start_proc, data); + GC_pthread_create(&thread->threadid, NULL, start_proc, data); # endif #endif return thread; @@ -245,7 +275,7 @@ struct mzrt_mutex { }; int mzrt_mutex_create(mzrt_mutex **mutex) { - *mutex = malloc(sizeof(mzrt_mutex)); + *mutex = malloc(sizeof(struct mzrt_mutex)); return pthread_mutex_init(&(*mutex)->mutex, NULL); } @@ -265,6 +295,91 @@ int mzrt_mutex_destroy(mzrt_mutex *mutex) { return pthread_mutex_destroy(&mutex->mutex); } +struct mzrt_cond { + pthread_cond_t cond; +}; + +int mzrt_cond_create(mzrt_cond **cond) { + *cond = malloc(sizeof(struct mzrt_cond)); + return pthread_cond_init(&(*cond)->cond, NULL); +} + +int mzrt_cond_wait(mzrt_cond *cond, mzrt_mutex *mutex) { + return pthread_cond_wait(&cond->cond, &mutex->mutex); +} + +int mzrt_cond_timedwait(mzrt_cond *cond, mzrt_mutex *mutex, long seconds, long nanoseconds) { + struct timespec timeout; + timeout.tv_sec = seconds; + timeout.tv_nsec = nanoseconds; + return pthread_cond_timedwait(&cond->cond, &mutex->mutex, &timeout); +} + +int mzrt_cond_signal(mzrt_cond *cond) { + return pthread_cond_signal(&cond->cond); +} + +int mzrt_cond_broadcast(mzrt_cond *cond) { + return pthread_cond_broadcast(&cond->cond); +} + +int mzrt_cond_destroy(mzrt_cond *cond) { + return pthread_cond_destroy(&cond->cond); +} + +/****************** PROCESS THREAD MAIL BOX *******************************/ + +pt_mbox *pt_mbox_create() { + pt_mbox *mbox = (pt_mbox *)malloc(sizeof(pt_mbox)); + mbox->count = 0; + mbox->in = 0; + mbox->out = 0; + mzrt_mutex_create(&mbox->mutex); + mzrt_cond_create(&mbox->nonempty); + mzrt_cond_create(&mbox->nonfull); + return mbox; +} + +void pt_mbox_send(pt_mbox *mbox, int type, void *payload, pt_mbox *origin) { + mzrt_mutex_lock(mbox->mutex); + while ( mbox->count == 5 ) { + mzrt_cond_wait(mbox->nonfull, mbox->mutex); + } + mbox->queue[mbox->in].type = type; + mbox->queue[mbox->in].payload = payload; + mbox->queue[mbox->in].origin = origin; + mbox->in = (mbox->in + 1) % 5; + mbox->count++; + mzrt_cond_signal(mbox->nonempty); + mzrt_mutex_unlock(mbox->mutex); +} + +void pt_mbox_recv(pt_mbox *mbox, int *type, void **payload, pt_mbox **origin){ + mzrt_mutex_lock(mbox->mutex); + while ( mbox->count == 0 ) { + mzrt_cond_wait(mbox->nonempty, mbox->mutex); + } + *type = mbox->queue[mbox->out].type; + *payload = mbox->queue[mbox->out].payload; + *origin = mbox->queue[mbox->out].origin; + mbox->out = (mbox->out + 1) % 5; + mbox->count--; + mzrt_cond_signal(mbox->nonfull); + mzrt_mutex_unlock(mbox->mutex); +} + +void pt_mbox_send_recv(pt_mbox *mbox, int type, void *payload, pt_mbox *origin, int *return_type, void **return_payload) { + pt_mbox *return_origin; + pt_mbox_send(mbox, type, payload, origin); + pt_mbox_recv(origin, return_type, return_payload, &return_origin); +} + +void pt_mbox_destroy(pt_mbox *mbox) { + mzrt_mutex_destroy(mbox->mutex); + mzrt_cond_destroy(mbox->nonempty); + mzrt_cond_destroy(mbox->nonfull); + free(mbox); +} #ifdef MZ_XFORM END_XFORM_SUSPEND; @@ -410,6 +525,35 @@ int mzrt_mutex_destroy(mzrt_mutex *mutex) { return 0; } +struct mzrt_cond { + pthread_cond_t cond; +}; + +int mzrt_cond_create(mzrt_cond **cond) { + *cond = malloc(sizeof(mzrt_cond)); + return pthread_cond_init(&(*cond)->cond, NULL); +} + +int mzrt_cond_wait(mzrt_cond *cond, mzrt_mutex *mutex) { + return pthread_cond_wait(&cond->cond, &mutex->mutex); +} + +int mzrt_cond_timedwait(mzrt_cond *cond, mzrt_mutex *mutex) { + return pthread_cond_timedwait(&cond->cond, &mutex->mutex); +} + +int mzrt_cond_signal(mzrt_cond *cond) { + return pthread_cond_signal(&cond->cond); +} + +int mzrt_cond_broadcast(mzrt_cond *cond) { + return pthread_cond_broadcast(&cond->cond); +} + +int mzrt_cond_destroy(mzrt_cond *cond) { + return pthread_cond_destroy(&cond->cond); +} + #ifdef MZ_XFORM END_XFORM_SUSPEND; #endif diff --git a/src/mzscheme/src/mzrt.h b/src/mzscheme/src/mzrt.h index 98c96b864a..f97ae6e579 100644 --- a/src/mzscheme/src/mzrt.h +++ b/src/mzscheme/src/mzrt.h @@ -23,7 +23,15 @@ void mzrt_set_user_break_handler(void (*user_break_handler)(int)); /****************** PROCESS WEIGHT THREADS ********************************/ /* mzrt_threads.c */ -typedef struct mz_proc_thread mz_proc_thread; /* OPAQUE DEFINITION */ +typedef struct mz_proc_thread { +#ifdef WIN32 + HANDLE threadid; +#else + pthread_t threadid; +#endif + struct pt_mbox *mbox; +} mz_proc_thread; + #ifdef WIN32 typedef DWORD (WINAPI *mz_proc_thread_start)(void*); @@ -31,13 +39,14 @@ typedef DWORD (WINAPI *mz_proc_thread_start)(void*); typedef void *(mz_proc_thread_start)(void*); #endif +mz_proc_thread* mzrt_proc_first_thread_init(); mz_proc_thread* mz_proc_thread_create(mz_proc_thread_start*, void* data); void *mz_proc_thread_wait(mz_proc_thread *thread); void mzrt_sleep(int seconds); -int mz_proc_thread_self(); -int mz_proc_thread_id(mz_proc_thread* thread); +unsigned int mz_proc_thread_self(); +unsigned int mz_proc_thread_id(mz_proc_thread* thread); /****************** THREAD RWLOCK ******************************************/ /* mzrt_rwlock_*.c */ @@ -58,6 +67,37 @@ int mzrt_mutex_trylock(mzrt_mutex *mutex); int mzrt_mutex_unlock(mzrt_mutex *mutex); int mzrt_mutex_destroy(mzrt_mutex *mutex); +/****************** THREAD COND *******************************************/ +typedef struct mzrt_cond mzrt_cond; /* OPAQUE DEFINITION */ +int mzrt_cond_create(mzrt_cond **cond); +int mzrt_cond_wait(mzrt_cond *cond, mzrt_mutex *mutex); +int mzrt_cond_timedwait(mzrt_cond *cond, mzrt_mutex *mutex, long seconds, long nanoseconds); +int mzrt_cond_signal(mzrt_cond *cond); +int mzrt_cond_broadcast(mzrt_cond *cond); +int mzrt_cond_destroy(mzrt_cond *cond); + +/****************** PROCESS THREAD MAIL BOX *******************************/ +typedef struct pt_mbox_msg { + int type; + void *payload; + struct pt_mbox *origin; +} pt_mbox_msg; + +typedef struct pt_mbox { + struct pt_mbox_msg queue[5]; + int count; + int in; + int out; + mzrt_mutex *mutex; + mzrt_cond *nonempty; + mzrt_cond *nonfull; +} pt_mbox; + +pt_mbox *pt_mbox_create(); +void pt_mbox_send(pt_mbox *mbox, int type, void *payload, pt_mbox *origin); +void pt_mbox_recv(pt_mbox *mbox, int *type, void **payload, pt_mbox **origin); +void pt_mbox_send_recv(pt_mbox *mbox, int type, void *payload, pt_mbox *origin, int *return_type, void **return_payload); +void pt_mbox_destroy(pt_mbox *mbox); #endif diff --git a/src/mzscheme/src/places.c b/src/mzscheme/src/places.c index d19c7eef68..1350909fb2 100644 --- a/src/mzscheme/src/places.c +++ b/src/mzscheme/src/places.c @@ -1,10 +1,17 @@ #include "schpriv.h" +/* READ ONLY SHARABLE GLOBALS */ +static Scheme_Object *place_main_symbol; + #ifdef MZ_USE_PLACES #include "mzrt.h" + +mz_proc_thread *scheme_master_proc_thread; +THREAD_LOCAL mz_proc_thread *proc_thread_self; + Scheme_Object *scheme_place(int argc, Scheme_Object *args[]); static Scheme_Object *scheme_place_wait(int argc, Scheme_Object *args[]); static Scheme_Object *scheme_place_sleep(int argc, Scheme_Object *args[]); @@ -47,9 +54,10 @@ void scheme_init_place(Scheme_Env *env) register_traversers(); #endif + place_main_symbol = scheme_intern_symbol("place-main"); plenv = scheme_primitive_module(scheme_intern_symbol("#%place"), env); - PLACE_PRIM_W_ARITY("place", scheme_place, 1, 1, plenv); + PLACE_PRIM_W_ARITY("place", scheme_place, 1, 2, plenv); PLACE_PRIM_W_ARITY("place-sleep", scheme_place_sleep, 1, 1, plenv); PLACE_PRIM_W_ARITY("place-wait", scheme_place_wait, 1, 1, plenv); PLACE_PRIM_W_ARITY("place?", scheme_place_p, 1, 1, plenv); @@ -66,7 +74,10 @@ void scheme_init_place(Scheme_Env *env) /* FIXME this struct probably will need to be garbage collected as stuff * is added to it */ typedef struct Place_Start_Data { + int argc; Scheme_Object *thunk; + Scheme_Object *module; + Scheme_Object *channel; Scheme_Object *current_library_collection_paths; } Place_Start_Data; @@ -98,7 +109,17 @@ Scheme_Object *scheme_place(int argc, Scheme_Object *args[]) { /* pass critical info to new place */ place_data = MALLOC_ONE(Place_Start_Data); - place_data->thunk = args[0]; + place_data->argc = argc; + if (argc == 1) { + place_data->thunk = args[0]; + } + else if (argc == 2 ) { + place_data->module = args[0]; + place_data->channel = args[1]; + } + else { + scheme_wrong_count_m("place", 1, 2, argc, args, 0); + } collection_paths = scheme_current_library_collection_paths(0, NULL); place_data->current_library_collection_paths = collection_paths; @@ -133,7 +154,7 @@ static void load_namespace_utf8(Scheme_Object *namespace_name) { Scheme_Object *a[1]; Scheme_Thread * volatile p; mz_jmp_buf * volatile saved_error_buf; - mz_jmp_buf volatile new_error_buf; + mz_jmp_buf new_error_buf; nsreq = scheme_builtin_value("namespace-require"); a[0] = scheme_make_pair(scheme_intern_symbol("lib"), @@ -147,11 +168,41 @@ static void load_namespace_utf8(Scheme_Object *namespace_name) { p->error_buf = saved_error_buf; } +Scheme_Object *scheme_places_deep_copy(Scheme_Object *so) +{ + Scheme_Object *new_so = so; + if (SCHEME_INTP(so)) { + return so; + } + + switch (so->type) { + case scheme_char_string_type: /*43*/ + new_so = scheme_make_sized_offset_char_string(SCHEME_CHAR_STR_VAL(so), 0, SCHEME_CHAR_STRLEN_VAL(so), 1); + break; + case scheme_unix_path_type: + new_so = scheme_make_sized_offset_path(SCHEME_BYTE_STR_VAL(so), 0, SCHEME_BYTE_STRLEN_VAL(so), 1); + break; + case scheme_symbol_type: + { + Scheme_Symbol *sym = (Scheme_Symbol *)so; + new_so = scheme_intern_exact_symbol(sym->s, sym->len); + } + break; + case scheme_resolved_module_path_type: + abort(); + break; + default: + abort(); + break; + } + return new_so; +} + static void *place_start_proc(void *data_arg) { void *stack_base; Scheme_Object *thunk; Place_Start_Data *place_data; - Scheme_Object *a[1]; + Scheme_Object *a[2]; int ptid; ptid = mz_proc_thread_self(); @@ -165,21 +216,75 @@ static void *place_start_proc(void *data_arg) { null_out_runtime_globals(); /* scheme_make_thread behaves differently if the above global vars are not null */ +#ifdef MZ_PRECISE_GC + GC_construct_child_gc(); +#endif scheme_place_instance_init(stack_base); a[0] = place_data->current_library_collection_paths; scheme_current_library_collection_paths(1, a); - load_namespace("scheme/init"); - thunk = place_data->thunk; + if (place_data->argc == 1) + { + load_namespace("scheme/init"); + thunk = place_data->thunk; + scheme_apply(thunk, 0, NULL); + stack_base = NULL; + } else { + Scheme_Object *place_main; + a[0] = scheme_places_deep_copy(place_data->module); + a[1] = place_main_symbol; + place_main = scheme_dynamic_require(2, a); - scheme_apply(thunk, 0, NULL); - - stack_base = NULL; + a[0] = scheme_places_deep_copy(place_data->channel); + scheme_apply(place_main, 1, a); + } return scheme_true; } +#ifdef MZ_PRECISE_GC + +static void *master_scheme_place(void *data) { + mz_proc_thread *myself; + myself = proc_thread_self; + GC_switch_in_master_gc(); + + while(1) { + int recv_type; + void *recv_payload; + pt_mbox *origin; + Scheme_Object *o; + Scheme_Object *copied_o; + + pt_mbox_recv(myself->mbox, &recv_type, &recv_payload, &origin); + switch(recv_type) { + case 1: + copied_o = scheme_places_deep_copy((Scheme_Object *)recv_payload); + o = scheme_intern_resolved_module_path_worker(copied_o); + pt_mbox_send(origin, 2, (void *) o, NULL); + break; + case 3: + { + Scheme_Symbol_Parts *parts; + parts = (Scheme_Symbol_Parts *) recv_payload; + o = (Scheme_Object *)scheme_intern_exact_symbol_in_table_worker(parts->table, parts->kind, parts->name, parts->len); + pt_mbox_send(origin, 4, (void *) o, NULL); + } + break; + case 5: + break; + } + } + return NULL; +} + +void spawn_master_scheme_place() { + mzrt_proc_first_thread_init(); + + scheme_master_proc_thread = mz_proc_thread_create(master_scheme_place, NULL); +} +#endif /*========================================================================*/ /* precise GC traversers */ diff --git a/src/mzscheme/src/salloc.c b/src/mzscheme/src/salloc.c index db5e8a50a8..26d137189f 100644 --- a/src/mzscheme/src/salloc.c +++ b/src/mzscheme/src/salloc.c @@ -1040,7 +1040,7 @@ static void do_next_finalization(void *o, void *data) /* Makes gc2 xformer happy: */ typedef void (*finalizer_function)(void *p, void *data); static int traversers_registered; -static Finalizations **save_fns_ptr; +static THREAD_LOCAL Finalizations **save_fns_ptr; static void add_finalizer(void *v, void (*f)(void*,void*), void *data, int prim, int ext, diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index d3800ccb07..3fec63931a 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -166,6 +166,7 @@ void scheme_init_type(Scheme_Env *env); void scheme_init_list(Scheme_Env *env); void scheme_init_stx(Scheme_Env *env); void scheme_init_module(Scheme_Env *env); +void scheme_init_module_path_table(void); void scheme_init_port(Scheme_Env *env); void scheme_init_port_fun(Scheme_Env *env); void scheme_init_network(Scheme_Env *env); @@ -356,6 +357,9 @@ extern THREAD_LOCAL Scheme_Thread *scheme_first_thread; #define scheme_jumping_to_continuation (scheme_current_thread->cjs.jumping_to_continuation) #define scheme_multiple_count (scheme_current_thread->ku.multiple.count) #define scheme_multiple_array (scheme_current_thread->ku.multiple.array) +#include "mzrt.h" +extern mz_proc_thread *scheme_master_proc_thread; +extern THREAD_LOCAL mz_proc_thread *proc_thread_self; #endif typedef struct Scheme_Thread_Set { @@ -2557,6 +2561,10 @@ typedef struct Scheme_Module Scheme_Object **indirect_provides; /* symbols (internal names) */ int num_indirect_provides; + /* Only if needed to reconstruct the renaming: */ + Scheme_Object **indirect_syntax_provides; /* symbols (internal names) */ + int num_indirect_syntax_provides; + char *et_provide_protects; /* 1 => protected, 0 => not */ Scheme_Object **et_indirect_provides; /* symbols (internal names) */ int num_indirect_et_provides; @@ -2683,6 +2691,7 @@ Scheme_Object *scheme_modidx_shift(Scheme_Object *modidx, Scheme_Object *shift_to_modidx); Scheme_Object *scheme_intern_resolved_module_path(Scheme_Object *o); +Scheme_Object *scheme_intern_resolved_module_path_worker(Scheme_Object *o); Scheme_Object *scheme_hash_module_variable(Scheme_Env *env, Scheme_Object *modidx, Scheme_Object *stxsym, Scheme_Object *insp, @@ -3080,6 +3089,7 @@ int scheme_hash_tree_equal_rec(Scheme_Hash_Tree *t1, Scheme_Hash_Tree *t2, void void scheme_set_root_param(int p, Scheme_Object *v); +Scheme_Object *scheme_intern_exact_symbol_in_table_worker(Scheme_Hash_Table *symbol_table, int kind, const char *name, unsigned int len); Scheme_Object *scheme_intern_exact_parallel_symbol(const char *name, unsigned int len); Scheme_Object *scheme_symbol_append(Scheme_Object *s1, Scheme_Object *s2); Scheme_Object *scheme_copy_list(Scheme_Object *l); @@ -3111,13 +3121,23 @@ Scheme_Object *scheme_current_library_collection_paths(int argc, Scheme_Object * /* places */ /*========================================================================*/ +#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC) +typedef struct Scheme_Symbol_Parts { + Scheme_Hash_Table *table; + int kind; + unsigned int len; + const char *name; +} Scheme_Symbol_Parts; +#endif + typedef struct Scheme_Place { Scheme_Object so; void *proc_thread; } Scheme_Place; Scheme_Env *scheme_place_instance_init(); - +void spawn_master_scheme_place(); +Scheme_Object *scheme_places_deep_copy(Scheme_Object *so); /*========================================================================*/ /* engine */ diff --git a/src/mzscheme/src/schvers.h b/src/mzscheme/src/schvers.h index 1ff97513ad..ae8e6871c9 100644 --- a/src/mzscheme/src/schvers.h +++ b/src/mzscheme/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "4.1.3.4" +#define MZSCHEME_VERSION "4.1.3.5" #define MZSCHEME_VERSION_X 4 #define MZSCHEME_VERSION_Y 1 #define MZSCHEME_VERSION_Z 3 -#define MZSCHEME_VERSION_W 4 +#define MZSCHEME_VERSION_W 5 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) diff --git a/src/mzscheme/src/symbol.c b/src/mzscheme/src/symbol.c index 97a255507d..46aec57962 100644 --- a/src/mzscheme/src/symbol.c +++ b/src/mzscheme/src/symbol.c @@ -369,7 +369,7 @@ scheme_make_exact_char_symbol(const mzchar *name, unsigned int len) } Scheme_Object * -scheme_intern_exact_symbol_in_table(Scheme_Hash_Table *symbol_table, int kind, const char *name, unsigned int len) +scheme_intern_exact_symbol_in_table_worker(Scheme_Hash_Table *symbol_table, int kind, const char *name, unsigned int len) { Scheme_Object *sym; @@ -392,6 +392,27 @@ scheme_intern_exact_symbol_in_table(Scheme_Hash_Table *symbol_table, int kind, c return sym; } +Scheme_Object * +scheme_intern_exact_symbol_in_table(Scheme_Hash_Table *symbol_table, int kind, const char *name, unsigned int len) +{ +#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC) + mz_proc_thread *self; + self = proc_thread_self; + if ( scheme_master_proc_thread && scheme_master_proc_thread != proc_thread_self ) { + int return_msg_type; + void *return_payload; + Scheme_Symbol_Parts parts; + parts.table = symbol_table; + parts.kind = kind; + parts.len = len; + parts.name = name; + pt_mbox_send_recv(scheme_master_proc_thread->mbox, 3, &parts, self->mbox, &return_msg_type, &return_payload); + return (Scheme_Object*) return_payload; + } +#endif + return scheme_intern_exact_symbol_in_table_worker(symbol_table, kind, name, len); +} + Scheme_Object * scheme_intern_exact_symbol(const char *name, unsigned int len) { diff --git a/src/mzscheme/src/thread.c b/src/mzscheme/src/thread.c index acef8eda8f..39ca02d150 100644 --- a/src/mzscheme/src/thread.c +++ b/src/mzscheme/src/thread.c @@ -2147,7 +2147,7 @@ static Scheme_Thread *make_thread(Scheme_Config *config, scheme_fuel_counter_ptr = &scheme_fuel_counter; #endif -#if defined(MZ_PRECISE_GC) || defined(USE_SENORA_GC) +#if defined(MZ_PRECISE_GC) GC_set_get_thread_stack_base(scheme_get_current_thread_stack_start); #endif process->stack_start = stack_base; diff --git a/src/mzscheme/src/type.c b/src/mzscheme/src/type.c index e0582c5813..72049b5b9c 100644 --- a/src/mzscheme/src/type.c +++ b/src/mzscheme/src/type.c @@ -51,7 +51,7 @@ static void init_type_arrays() REGISTER_SO(scheme_type_hash2s); maxtype = _scheme_last_type_; - allocmax = maxtype + 10; + allocmax = maxtype + 100; type_names = MALLOC_N(char *, allocmax); scheme_type_readers = MALLOC_N_ATOMIC(Scheme_Type_Reader, allocmax); diff --git a/src/worksp/mred/mred.manifest b/src/worksp/mred/mred.manifest index a4ff42e42a..05ff6d22f6 100644 --- a/src/worksp/mred/mred.manifest +++ b/src/worksp/mred/mred.manifest @@ -1,7 +1,7 @@