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

Syncing

Browse Source 
svn: r12824
This commit is contained in:
Stevie Strickland 2008-12-13 02:13:59 +00:00
commit c360e8ce81
43 changed files with 1247 additions and 490 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

56
collects/compiler/embed-unit.ss
View File

@ -740,7 +740,7 @@
;; Write a module bundle that can be loaded with 'load' (do not embed it ;; 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. ;; 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 on-extension program-name compiler expand-namespace
src-filter get-extra-imports) src-filter get-extra-imports)
(let* ([module-paths (map cadr modules)] (let* ([module-paths (map cadr modules)]
@ -778,11 +778,11 @@
;; Drop elements of `codes' that just record copied libs: ;; Drop elements of `codes' that just record copied libs:
(set-box! codes (filter mod-code (unbox codes))) (set-box! codes (filter mod-code (unbox codes)))
;; Bind `module' to get started: ;; 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 ;; Install a module name resolver that redirects
;; to the embedded modules ;; to the embedded modules
(write (make-module-name-resolver (filter mod-code (unbox codes)))) (write (make-module-name-resolver (filter mod-code (unbox codes))) outp)
(write (compile-using-kernel '(namespace-require ''#%resolver))) (write (compile-using-kernel '(namespace-require ''#%resolver)) outp)
;; Write the extension table and copy module code: ;; Write the extension table and copy module code:
(let* ([l (reverse (unbox codes))] (let* ([l (reverse (unbox codes))]
[extensions (filter (lambda (m) (extension? (mod-code m))) l)] [extensions (filter (lambda (m) (extension? (mod-code m))) l)]
@ -825,15 +825,17 @@
(path->complete-path p (current-directory)))) (path->complete-path p (current-directory))))
(current-directory d))) (current-directory d)))
p)))) p))))
eXtEnSiOn-modules)))) eXtEnSiOn-modules)))
(write (compile-using-kernel '(namespace-require ''#%extension-table)))) outp)
(write (compile-using-kernel '(namespace-require ''#%extension-table)) outp))
;; Runtime-path table: ;; Runtime-path table:
(unless (null? runtimes) (unless (null? runtimes)
(unless table-mod (unless table-mod
(error 'create-embedding-executable "cannot find module for runtime-path table")) (error 'create-embedding-executable "cannot find module for runtime-path table"))
(write (compile-using-kernel (write (compile-using-kernel
`(current-module-declare-name (make-resolved-module-path `(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 (write `(module runtime-path-table '#%kernel
(#%provide table) (#%provide table)
(define-values (table) (define-values (table)
@ -884,7 +886,8 @@
(bytes-append #"................." (path->bytes program-name)))) (bytes-append #"................." (path->bytes program-name))))
(mod-runtime-paths nc))) (mod-runtime-paths nc)))
runtimes))]) runtimes))])
rUnTiMe-paths)))))) rUnTiMe-paths))))
outp))
;; Copy module code: ;; Copy module code:
(for-each (for-each
(lambda (nc) (lambda (nc)
@ -895,26 +898,27 @@
(write (compile-using-kernel (write (compile-using-kernel
`(current-module-declare-name `(current-module-declare-name
(make-resolved-module-path (make-resolved-module-path
',(mod-full-name nc))))) ',(mod-full-name nc))))
outp)
(if (src-filter (mod-file nc)) (if (src-filter (mod-file nc))
(with-input-from-file (mod-file nc) (call-with-input-file* (mod-file nc)
(lambda () (lambda (inp)
(copy-port (current-input-port) (current-output-port)))) (copy-port inp outp)))
(write (mod-code nc))))) (write (mod-code nc) outp))))
l)) 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: ;; 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-set-variable-value! 'module #f #t)) outp)
(write (compile-using-kernel '(namespace-undefine-variable! 'module))) (write (compile-using-kernel '(namespace-undefine-variable! 'module)) outp)
(newline) (newline outp)
(for-each (lambda (f) (for-each (lambda (f)
(when verbose? (when verbose?
(fprintf (current-error-port) "Copying from ~s~n" f)) (fprintf (current-error-port) "Copying from ~s~n" f))
(call-with-input-file* f (call-with-input-file* f
(lambda (i) (lambda (i)
(copy-port i (current-output-port))))) (copy-port i outp))))
literal-files) literal-files)
(for-each write literal-expressions))) (for-each (lambda (v) (write v outp)) literal-expressions)))
(define (write-module-bundle #:verbose? [verbose? #f] (define (write-module-bundle #:verbose? [verbose? #f]
#:modules [modules null] #:modules [modules null]
@ -927,7 +931,7 @@
(compile expr)))] (compile expr)))]
#:src-filter [src-filter (lambda (filename) #f)] #:src-filter [src-filter (lambda (filename) #f)]
#:get-extra-imports [get-extra-imports (lambda (filename code) null)]) #: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 #f ; collects-dest
on-extension on-extension
"?" ; program-name "?" ; program-name
@ -1072,8 +1076,9 @@
(path->complete-path orig-exe))]) (path->complete-path orig-exe))])
(update-dll-dir dest (build-path orig-dir dir)))))))) (update-dll-dir dest (build-path orig-dir dir))))))))
(let ([write-module (let ([write-module
(lambda () (lambda (s)
(do-write-module-bundle verbose? modules literal-files literal-expressions collects-dest (do-write-module-bundle s
verbose? modules literal-files literal-expressions collects-dest
on-extension on-extension
(file-name-from-path dest) (file-name-from-path dest)
compiler compiler
@ -1085,16 +1090,15 @@
(not unix-starter?)) (not unix-starter?))
;; For Mach-O, we know how to add a proper segment ;; For Mach-O, we know how to add a proper segment
(let ([s (open-output-bytes)]) (let ([s (open-output-bytes)])
(parameterize ([current-output-port s]) (write-module s)
(write-module))
(let ([s (get-output-bytes s)]) (let ([s (get-output-bytes s)])
(let ([start (add-plt-segment dest-exe s)]) (let ([start (add-plt-segment dest-exe s)])
(values start (values start
(+ start (bytes-length s)))))) (+ start (bytes-length s))))))
;; Other platforms: just add to the end of the file: ;; Other platforms: just add to the end of the file:
(let ([start (file-size dest-exe)]) (let ([start (file-size dest-exe)])
(with-output-to-file dest-exe write-module (call-with-output-file* dest-exe write-module
#:exists 'append) #:exists 'append)
(values start (file-size dest-exe))))]) (values start (file-size dest-exe))))])
(when verbose? (when verbose?
(fprintf (current-error-port) "Setting command line~n")) (fprintf (current-error-port) "Setting command line~n"))

26
collects/handin-server/checker.ss
View File

@ -1,6 +1,7 @@
#lang scheme/base #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) (provide (except-out (all-from-out scheme/base) #%module-begin)
(all-from-out "utils.ss")) (all-from-out "utils.ss"))
@ -654,8 +655,21 @@
(define (get-namespace evaluator) (define (get-namespace evaluator)
(call-in-sandbox-context evaluator (lambda () (current-namespace)))) (call-in-sandbox-context evaluator (lambda () (current-namespace))))
;; checks that ids are defined, either as variables or syntaxes
(provide !defined) (provide !defined)
(define-syntax-rule (!defined id ...) (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 ;; expected to be used only with identifiers
(begin (with-handlers ([exn:fail:contract:variable? (begin (with-handlers ([exn:fail:contract:variable?
(lambda (_) (lambda (_)
@ -668,6 +682,7 @@
(namespace-variable-value `id))) (namespace-variable-value `id)))
...)) ...))
;; checks that ids are defined as syntaxes, not variables
(provide !syntax) (provide !syntax)
(define-syntax-rule (!syntax id ...) (define-syntax-rule (!syntax id ...)
;; expected to be used only with identifiers ;; expected to be used only with identifiers
@ -726,11 +741,10 @@
(define-syntax (!test/exn stx) (define-syntax (!test/exn stx)
(syntax-case stx () (syntax-case stx ()
[(_ test-exp) [(_ test-exp)
#`(unless #`(unless (with-handlers ([exn:fail? (lambda (exn) #t)])
(with-handlers ([exn:fail? (lambda (exn) #t)]) ((submission-eval) `test-exp)
((submission-eval) `test-exp) #f)
#f) (error* "expected exception on test expression: ~v"
(error* "expected exception on test expression: ~v"
(->disp 'test-exp)))])) (->disp 'test-exp)))]))
(provide !all-covered) (provide !all-covered)

23
collects/handin-server/scribblings/checker.scrbl
View File

@ -16,7 +16,7 @@ language module---a typical checker that uses it looks like this:
@schemeblock[ @schemeblock[
(module checker (lib "checker.ss" "handin-server") (module checker (lib "checker.ss" "handin-server")
(check: :language 'intermediate (check: :language '(special intermediate)
:users pairs-or-singles-with-warning :users pairs-or-singles-with-warning
:coverage? #t :coverage? #t
(!procedure Fahrenheit->Celsius 1) (!procedure Fahrenheit->Celsius 1)
@ -327,16 +327,20 @@ code.}
@defform[(!defined id ...)]{ @defform[(!defined id ...)]{
Checks that the given identifiers are defined in the (evaluated) 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)]{ @defform[(!bound id ...)]{
Checks that the given identifiers are defined in the (evaluated)
Checks that @scheme[id] is defined, and is bound to a procedure.} submission as a plain value. Throws an error if not, or if an
identifier is bound to a syntax.}
@defform[(!syntax id arity)]{ @defform[(!syntax id arity)]{
Checks that @scheme[id] is defined, and is bound as a macro.} 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)]{ @defform[(!procedure* expr arity)]{
Similar to @scheme[!procedure] but omits the defined check, making Similar to @scheme[!procedure] but omits the defined check, making
@ -350,13 +354,16 @@ code.}
integers.} integers.}
@defform*[((!test expr) @defform*[((!test expr)
(!test/exn expr)
(!test expr result) (!test expr result)
(!test expr result equal?))]{ (!test expr result equal?))]{
The first form checks that the given expression evaluates to a The first form checks that the given expression evaluates to a
non-@scheme[#f] value in the submission context, throwing an error non-@scheme[#f] value in the submission context, throwing an error
otherwise. The second form compares the result of evaluation, otherwise. The second form checks that the given expression throws
requiring it to be equal to @scheme[result]. The third allows 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 specifying an equality procedure. Note that the @scheme[result] and
@scheme[equal?] forms are @italic{not} evaluated in the submission @scheme[equal?] forms are @italic{not} evaluated in the submission
context.} context.}

4
collects/lang/htdp-reader.ss
View File

@ -41,6 +41,8 @@
`(module ,modname ,spec `(module ,modname ,spec
,@(map (λ (x) `(require ,x)) ,@(map (λ (x) `(require ,x))
(lookup 'teachpacks table)) (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))))))]) (get-all-exps source-name port))))))])
read-syntax))) read-syntax)))

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

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

172
collects/scheme/sandbox.ss
View File

@ -21,7 +21,9 @@
sandbox-network-guard sandbox-network-guard
sandbox-make-inspector sandbox-make-inspector
sandbox-make-logger sandbox-make-logger
sandbox-memory-limit
sandbox-eval-limits sandbox-eval-limits
evaluator-alive?
kill-evaluator kill-evaluator
break-evaluator break-evaluator
set-eval-limits set-eval-limits
@ -52,6 +54,7 @@
(define sandbox-output (make-parameter #f)) (define sandbox-output (make-parameter #f))
(define sandbox-error-output (define sandbox-error-output
(make-parameter (lambda () (dup-output-port (current-error-port))))) (make-parameter (lambda () (dup-output-port (current-error-port)))))
(define sandbox-memory-limit (make-parameter 20)) ; 30mb total
(define sandbox-eval-limits (make-parameter '(30 20))) ; 30sec, 20mb (define sandbox-eval-limits (make-parameter '(30 20))) ; 30sec, 20mb
(define sandbox-propagate-breaks (make-parameter #t)) (define sandbox-propagate-breaks (make-parameter #t))
(define sandbox-coverage-enabled (make-parameter #f)) (define sandbox-coverage-enabled (make-parameter #f))
@ -149,6 +152,11 @@
(define sandbox-make-logger (make-parameter current-logger)) (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 ;; computes permissions that are needed for require specs (`read' for all
;; files and "compiled" subdirs, `exists' for the base-dir) ;; files and "compiled" subdirs, `exists' for the base-dir)
(define (module-specs->path-permissions mods) (define (module-specs->path-permissions mods)
@ -215,49 +223,73 @@
;; similar to `call-in-nested-thread', but propagates killing the thread, ;; similar to `call-in-nested-thread', but propagates killing the thread,
;; shutting down the custodian or setting parameters and thread cells; ;; 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* (define (call-in-nested-thread*
thunk thunk
[kill (lambda () (kill-thread (current-thread)))] [kill (lambda () (kill-thread (current-thread)))]
[shutdown (lambda () (custodian-shutdown-all (current-custodian)))]) [shutdown (lambda () (custodian-shutdown-all (current-custodian)))])
(let* ([p #f] (let* ([p #f]
[c (make-custodian)] [c (make-custodian (current-custodian))]
[b (make-custodian-box c #t)]) [b (make-custodian-box c #t)]
(with-handlers ([(lambda (_) (not p)) [break? (break-enabled)])
;; if the after thunk was not called, then this error is (parameterize-break #f
;; about the thread dying unnaturally, so propagate (with-handlers ([(lambda (_) (not p))
;; whatever it did ;; if the after thunk was not called, then this error is
(lambda (_) ((if (custodian-box-value b) kill shutdown)))]) ;; about the thread dying unnaturally, so propagate
(dynamic-wind void ;; whatever it did
(lambda () (lambda (_)
(parameterize ([current-custodian c]) ((if (custodian-box-value b) kill shutdown)))])
(call-in-nested-thread (dynamic-wind void
(lambda () (lambda ()
(dynamic-wind void thunk (parameterize ([current-custodian c])
;; this should always be called unless the thread is killed or (call-in-nested-thread
;; the custodian is shutdown, distinguish the two cases (lambda ()
;; through the above box (break-enabled break?)
(lambda () (dynamic-wind void thunk
(set! p (current-preserved-thread-cell-values)))))))) ;; this should always be called unless the thread is killed
(lambda () (when p (current-preserved-thread-cell-values p))))))) ;; 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) (define (call-with-limits sec mb thunk)
;; note that when the thread is killed after using too much memory or time, ;; 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 ;; then all thread-local changes (parameters and thread cells) are discarded
(let ([r #f]) (let ([r #f])
(call-in-nested-thread* ;; memory limit, set on a new custodian so if there's an out-of-memory
(lambda () ;; error, the user's custodian is still alive
;; memory limit (define-values (cust cust-box)
(when (and mb memory-accounting?) (if (and mb memory-accounting?)
(custodian-limit-memory (current-custodian) (* mb 1024 1024))) (let ([c (make-custodian (current-custodian))])
;; time limit (custodian-limit-memory c (* mb 1024 1024) c)
(when sec (values c (make-custodian-box c #t)))
(let ([t (current-thread)]) (values (current-custodian) #f)))
(thread (lambda () (sleep sec) (set! r 'time) (kill-thread t))))) (parameterize ([current-custodian cust])
(set! r (with-handlers ([void (lambda (e) (list raise e))]) (call-in-nested-thread*
(call-with-values thunk (lambda vs (list* values vs)))))) (lambda ()
(lambda () (unless r (set! r 'kill))) ;; time limit
(lambda () (unless r (set! r 'shut)))) (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 (case r
[(kill) (kill-thread (current-thread))] [(kill) (kill-thread (current-thread))]
[(shut) (custodian-shutdown-all (current-custodian))] [(shut) (custodian-shutdown-all (current-custodian))]
@ -317,23 +349,25 @@
;; (path/string/bytes) value. ;; (path/string/bytes) value.
(define (input->code inps source n) (define (input->code inps source n)
(if (null? inps) (if (null? inps)
'() '()
(let ([p (input->port (car inps))]) (let ([p (input->port (car inps))])
(cond [(and p (null? (cdr inps))) (cond [(and p (null? (cdr inps)))
(port-count-lines! p) (port-count-lines! p)
(parameterize ([current-input-port p]) (parameterize ([current-input-port p])
((sandbox-reader) source))] (begin0 ((sandbox-reader) source)
[p (error 'input->code "ambiguous inputs: ~e" inps)] ;; close a port if we opened it
[else (let loop ([inps inps] [n n] [r '()]) (unless (eq? p (car inps)) (close-input-port p))))]
(if (null? inps) [p (error 'input->code "ambiguous inputs: ~e" inps)]
(reverse r) [else (let loop ([inps inps] [n n] [r '()])
(loop (cdr inps) (and n (add1 n)) (if (null? inps)
;; 1st at line#1, pos#1, 2nd at line#2, pos#2 etc (reverse r)
;; (starting from the `n' argument) (loop (cdr inps) (and n (add1 n))
(cons (datum->syntax ;; 1st at line#1, pos#1, 2nd at line#2, pos#2 etc
#f (car inps) ;; (starting from the `n' argument)
(list source n (and n 0) n (and n 1))) (cons (datum->syntax
r))))])))) #f (car inps)
(list source n (and n 0) n (and n 1)))
r))))]))))
(define ((init-for-language language)) (define ((init-for-language language))
(cond [(or (not (pair? language)) (cond [(or (not (pair? language))
@ -353,7 +387,7 @@
;; ;;
;; FIXME: inserting `#%require's here is bad if the language has a ;; FIXME: inserting `#%require's here is bad if the language has a
;; `#%module-begin' that processes top-level forms specially. ;; `#%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. ;; the given language plus all of the given extra requires.
;; ;;
;; We use `#%requre' because, unlike the `require' of scheme/base, ;; We use `#%requre' because, unlike the `require' of scheme/base,
@ -448,6 +482,7 @@
(let ([evmsg (make-evaluator-message msg '())]) (let ([evmsg (make-evaluator-message msg '())])
(lambda (evaluator) (evaluator evmsg))))])) (lambda (evaluator) (evaluator evmsg))))]))
(define-evaluator-messenger evaluator-alive? 'alive?)
(define-evaluator-messenger kill-evaluator 'kill) (define-evaluator-messenger kill-evaluator 'kill)
(define-evaluator-messenger break-evaluator 'break) (define-evaluator-messenger break-evaluator 'break)
(define-evaluator-messenger (set-eval-limits secs mb) 'limits) (define-evaluator-messenger (set-eval-limits secs mb) 'limits)
@ -457,8 +492,11 @@
(define-evaluator-messenger (get-uncovered-expressions . xs) 'uncovered) (define-evaluator-messenger (get-uncovered-expressions . xs) 'uncovered)
(define-evaluator-messenger (call-in-sandbox-context thunk) 'thunk) (define-evaluator-messenger (call-in-sandbox-context thunk) 'thunk)
(define (make-evaluator* init-hook require-perms program-maker) (define (make-evaluator* init-hook allow program-maker)
(define user-cust (make-custodian)) (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 coverage? (sandbox-coverage-enabled))
(define uncovered #f) (define uncovered #f)
(define input-ch (make-channel)) (define input-ch (make-channel))
@ -469,7 +507,6 @@
(define limits (sandbox-eval-limits)) (define limits (sandbox-eval-limits))
(define user-thread #t) ; set later to the thread (define user-thread #t) ; set later to the thread
(define user-done-evt #t) ; set in the same place (define user-done-evt #t) ; set in the same place
(define orig-cust (current-custodian))
(define (limit-thunk thunk) (define (limit-thunk thunk)
(let* ([sec (and limits (car limits))] (let* ([sec (and limits (car limits))]
[mb (and limits (cadr limits))]) [mb (and limits (cadr limits))])
@ -523,7 +560,9 @@
(loop))]) (loop))])
(sync user-done-evt result-ch)))) (sync user-done-evt result-ch))))
eof)]) 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))] [(eq? (car r) 'exn) (raise (cdr r))]
[else (apply values (cdr r))]))) [else (apply values (cdr r))])))
(define get-uncovered (define get-uncovered
@ -552,6 +591,7 @@
(if (evaluator-message? expr) (if (evaluator-message? expr)
(let ([msg (evaluator-message-msg expr)]) (let ([msg (evaluator-message-msg expr)])
(case msg (case msg
[(alive?) (and user-thread (not (thread-dead? user-thread)))]
[(kill) (user-kill)] [(kill) (user-kill)]
[(break) (user-break)] [(break) (user-break)]
[(limits) (set! limits (evaluator-message-args expr))] [(limits) (set! limits (evaluator-message-args expr))]
@ -582,6 +622,10 @@
(if bytes? buf (bytes->string/utf-8 buf #\?))))) (if bytes? buf (bytes->string/utf-8 buf #\?)))))
out)] out)]
[else (error 'make-evaluator "bad sandox-~a spec: ~e" what 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 (parameterize* ; the order in these matters
(;; create a sandbox context first (;; create a sandbox context first
[current-custodian user-cust] [current-custodian user-cust]
@ -611,7 +655,7 @@
[sandbox-path-permissions [sandbox-path-permissions
(append (map (lambda (p) `(read ,p)) (append (map (lambda (p) `(read ,p))
(current-library-collection-paths)) (current-library-collection-paths))
(module-specs->path-permissions require-perms) (compute-permissions allow)
(sandbox-path-permissions))] (sandbox-path-permissions))]
;; general info ;; general info
[current-command-line-arguments '#()] [current-command-line-arguments '#()]
@ -633,10 +677,10 @@
(set! user-done-evt (handle-evt user-thread (lambda (_) (user-kill) eof))) (set! user-done-evt (handle-evt user-thread (lambda (_) (user-kill) eof)))
(let ([r (channel-get result-ch)]) (let ([r (channel-get result-ch)])
(if (eq? r 'ok) (if (eq? r 'ok)
;; initial program executed ok, so return an evaluator ;; initial program executed ok, so return an evaluator
evaluator evaluator
;; program didn't execute ;; program didn't execute
(raise r))))) (raise r)))))
(define (make-evaluator language (define (make-evaluator language
#:requires [requires null] #:allow-read [allow null] #:requires [requires null] #:allow-read [allow null]
@ -654,8 +698,7 @@
`(file ,(path->string (simplify-path* r))))) `(file ,(path->string (simplify-path* r)))))
requires))]) requires))])
(make-evaluator* (init-for-language lang) (make-evaluator* (init-for-language lang)
(append (extract-required (or (decode-language lang) (append (extract-required (or (decode-language lang) lang)
lang)
reqs) reqs)
allow) allow)
(lambda () (build-program lang reqs input-program))))) (lambda () (build-program lang reqs input-program)))))
@ -679,5 +722,6 @@
(syntax->datum #'lang) reqlang))] (syntax->datum #'lang) reqlang))]
[_else (error 'make-evaluator "expecting a `module' program; got ~e" [_else (error 'make-evaluator "expecting a `module' program; got ~e"
(syntax->datum (car prog)))]))) (syntax->datum (car prog)))])))
(make-evaluator* void allow make-program)) (make-evaluator* void
(if (path? input-program) (cons input-program allow) allow)
make-program))

1
collects/scribble/eval.ss
View File

@ -243,6 +243,7 @@
[sandbox-output 'string] [sandbox-output 'string]
[sandbox-error-output 'string] [sandbox-error-output 'string]
[sandbox-eval-limits #f] [sandbox-eval-limits #f]
[sandbox-memory-limit #f]
[sandbox-make-inspector current-inspector]) [sandbox-make-inspector current-inspector])
(make-evaluator '(begin (require scheme/base))))) (make-evaluator '(begin (require scheme/base)))))

4
collects/scribble/reader.ss
View File

@ -65,8 +65,8 @@
(define (internal-error label) (define (internal-error label)
(error 'scribble-reader "internal error [~a]" label)) (error 'scribble-reader "internal error [~a]" label))
;; like `regexp-match/fail-without-reading', without extras; the regexp that ;; like `regexp-try-match', without extras; the regexp that is used
;; is used must be anchored -- nothing is dropped ;; must be anchored -- nothing is dropped
(define (*regexp-match-peek-positions pattern input-port) (define (*regexp-match-peek-positions pattern input-port)
#; ; sanity checks, not needed unless this file is edited #; ; sanity checks, not needed unless this file is edited
(unless (and (byte-regexp? pattern) (unless (and (byte-regexp? pattern)

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

@ -176,8 +176,11 @@ environment:
@item{The evaluator works under the @scheme[sandbox-security-guard], @item{The evaluator works under the @scheme[sandbox-security-guard],
which restricts file system and network access.} which restricts file system and network access.}
@item{Each evaluation is wrapped in a @scheme[call-with-limits]; see @item{The evaluator is contained in a memory-restricted environment,
also @scheme[sandbox-eval-limits] and @scheme[set-eval-limits].} 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 Note that these limits apply to the creation of the sandbox
environment too --- so, for example, if the memory that is required to 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.} 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 @defparam[sandbox-eval-limits limits
(or/c (list/c (or/c exact-nonnegative-integer? #f) (or/c (list/c (or/c exact-nonnegative-integer? #f)
(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 parameter that determines the default limits on @italic{each} use of
a @scheme[make-evaluator] function, including the initial evaluation a @scheme[make-evaluator] function, including the initial evaluation
of the input program. Its value should be a list of two numbers, the of the input program. Its value should be a list of two numbers;
first is a timeout value in seconds, and the second is a memory limit where the first is a timeout value in seconds, and the second is a
in megabytes. Either one can be @scheme[#f] for disabling the memory limit in megabytes. Either one can be @scheme[#f] for
corresponding limit; alternately, the parameter can be set to disabling the corresponding limit; alternately, the parameter can be
@scheme[#f] to disable all limits (useful in case more limit kinds are set to @scheme[#f] to disable all per-evaluation limits (useful in
available in future versions). The default is @scheme[(list 30 20)]. 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 Note that these limits apply to the creation of the sandbox
environment too --- even @scheme[(make-evaluator 'scheme/base)] can environment too --- even @scheme[(make-evaluator 'scheme/base)] can
@ -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 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 around each use of the evaluator, so consuming too much time or memory
results in an exception. Change the limits of a running evaluator 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?)]{ @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 The following functions are used to interact with a sandboxed
evaluator in addition to using it to evaluate code. 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?]{ @defproc[(kill-evaluator [evaluator (any/c . -> . any)]) void?]{
Releases the resources that are held by @scheme[evaluator] by shutting Releases the resources that are held by @scheme[evaluator] by shutting

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

@ -7,8 +7,14 @@
;; test call-in-nested-thread* ;; test call-in-nested-thread*
(let () (let ()
(define (kill) (kill-thread (current-thread)))
(define (shut) (custodian-shutdown-all (current-custodian)))
(define-syntax-rule (nested body ...) (define-syntax-rule (nested body ...)
(call-in-nested-thread* (lambda () 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)) (test 1 values (nested 1))
;; propagates parameters ;; propagates parameters
(let ([p (make-parameter #f)]) (let ([p (make-parameter #f)])
@ -19,13 +25,15 @@
;; propagates kill-thread ;; propagates kill-thread
(test (void) thread-wait (test (void) thread-wait
(thread (lambda () (thread (lambda ()
(nested (kill-thread (current-thread))) (nested (kill))
;; never reach here ;; never reach here
(semaphore-wait (make-semaphore 0))))) (semaphore-wait (make-semaphore 0)))))
;; propagates custodian-shutdown-all ;; propagates custodian-shutdown-all
(test (void) values (test (void) values
(parameterize ([current-custodian (make-custodian)]) (parameterize ([current-custodian (make-custodian)]) (nested (shut))))
(nested (custodian-shutdown-all (current-custodian)))))) ;; test handlers parameters
(test 'kill (lambda () (nested* (kill))))
(test 'shut (lambda () (nested* (shut)))))
(let ([ev void]) (let ([ev void])
(define (run thunk) (define (run thunk)
@ -362,31 +370,33 @@
--top-- --top--
(set! ev (parameterize ([sandbox-output 'bytes] (set! ev (parameterize ([sandbox-output 'bytes]
[sandbox-error-output current-output-port] [sandbox-error-output current-output-port]
[sandbox-memory-limit 5]
[sandbox-eval-limits '(0.25 1/2)]) [sandbox-eval-limits '(0.25 1/2)])
(make-evaluator 'scheme/base))) (make-evaluator 'scheme/base)))
;; GCing is needed to allow these to happen ;; 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 --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 --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 --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 --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 --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 ;; 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-- --top--
(set! ev (parameterize ([sandbox-eval-limits #f]) (set! ev (parameterize ([sandbox-eval-limits #f])
(make-evaluator 'scheme/base))) (make-evaluator 'scheme/base)))
@ -426,6 +436,20 @@
(lambda () (custodian-shutdown-all (current-custodian)))) (lambda () (custodian-shutdown-all (current-custodian))))
=err> "terminated" =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) (report-errs)

4
collects/xml/private/xexpr.ss
View File

@ -148,7 +148,6 @@
(null? (cddr b)))) (null? (cddr b))))
;; xml->xexpr : Content -> Xexpr ;; xml->xexpr : Content -> Xexpr
;; The contract is loosely enforced.
(define (xml->xexpr x) (define (xml->xexpr x)
(let* ([non-dropping-combine (let* ([non-dropping-combine
(lambda (atts body) (lambda (atts body)
@ -170,8 +169,7 @@
[(entity? x) (entity-text x)] [(entity? x) (entity-text x)]
[(or (comment? x) (pi? x) (cdata? x)) 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)] [(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) [else (error 'xml->xexpr "Expected content, given ~e" x)]))))
x]))))
;; attribute->srep : Attribute -> Attribute-srep ;; attribute->srep : Attribute -> Attribute-srep
(define (attribute->srep a) (define (attribute->srep a)

4
src/mzscheme/Makefile.in
View File

@ -68,10 +68,6 @@ cgc:
cd dynsrc; $(MAKE) dynlib3m cd dynsrc; $(MAKE) dynlib3m
cd gc2; $(MAKE) ../mzscheme@MMM@ cd gc2; $(MAKE) ../mzscheme@MMM@
compact:
$(MAKE) 3m
cd gc2; $(MAKE) ../mzscheme_compact_gc
both: both:
$(MAKE) cgc $(MAKE) cgc
$(MAKE) 3m $(MAKE) 3m

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

@ -30,9 +30,6 @@ XSRCDIR = xsrc
XFORM = env XFORM_USE_PRECOMP=$(XSRCDIR)/precomp.h $(XFORM_NOPRECOMP) XFORM = env XFORM_USE_PRECOMP=$(XSRCDIR)/precomp.h $(XFORM_NOPRECOMP)
SRCDIR = $(srcdir)/../src 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_USED_OBJ = foreign.@LTO@
FOREIGN_NOT_USED_OBJ = FOREIGN_NOT_USED_OBJ =
@ -49,6 +46,7 @@ OBJS = salloc.@LTO@ \
file.@LTO@ \ file.@LTO@ \
fun.@LTO@ \ fun.@LTO@ \
hash.@LTO@ \ hash.@LTO@ \
jit.@LTO@ \
list.@LTO@ \ list.@LTO@ \
module.@LTO@ \ module.@LTO@ \
mzrt.@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)/../sconfig.h $(srcdir)/../uconfig.h $(srcdir)/../src/schemef.h \
$(srcdir)/../src/stypes.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 $(XSRCDIR)/precomp.h : $(XFORMDEP) $(srcdir)/../src/schvers.h
env XFORM_PRECOMP=yes $(XFORM_NOPRECOMP) $(XSRCDIR)/precomp.h $(srcdir)/precomp.c 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 $(XFORM) $(XSRCDIR)/complex.c $(SRCDIR)/complex.c
$(XSRCDIR)/dynext.c: ../src/dynext.@LTO@ $(XFORMDEP) $(XSRCDIR)/dynext.c: ../src/dynext.@LTO@ $(XFORMDEP)
$(XFORM) $(XSRCDIR)/dynext.c $(SRCDIR)/dynext.c $(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 $(XFORM) $(XSRCDIR)/env.c $(SRCDIR)/env.c
$(XSRCDIR)/error.c: ../src/error.@LTO@ $(XFORMDEP) $(XSRCDIR)/error.c: ../src/error.@LTO@ $(XFORMDEP)
$(XFORM) $(XSRCDIR)/error.c $(SRCDIR)/error.c $(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 $(XFORM) $(XSRCDIR)/fun.c $(SRCDIR)/fun.c
$(XSRCDIR)/hash.c: ../src/hash.@LTO@ $(XFORMDEP) $(XSRCDIR)/hash.c: ../src/hash.@LTO@ $(XFORMDEP)
$(XFORM) $(XSRCDIR)/hash.c $(SRCDIR)/hash.c $(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 $(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 $(XFORM) $(XSRCDIR)/module.c $(SRCDIR)/module.c
$(XSRCDIR)/list.c: ../src/list.@LTO@ $(XFORMDEP) $(XSRCDIR)/list.c: ../src/list.@LTO@ $(XFORMDEP)
$(XFORM) $(XSRCDIR)/list.c $(SRCDIR)/list.c $(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 $(XFORM) $(XSRCDIR)/numcomp.c $(SRCDIR)/numcomp.c
$(XSRCDIR)/numstr.c: ../src/numstr.@LTO@ $(XFORMDEP) $(XSRCDIR)/numstr.c: ../src/numstr.@LTO@ $(XFORMDEP)
$(XFORM) $(XSRCDIR)/numstr.c $(SRCDIR)/numstr.c $(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 $(XFORM) $(XSRCDIR)/places.c $(SRCDIR)/places.c
$(XSRCDIR)/port.c: ../src/port.@LTO@ $(XFORMDEP) $(XSRCDIR)/port.c: ../src/port.@LTO@ $(XFORMDEP)
$(XFORM) $(XSRCDIR)/port.c $(SRCDIR)/port.c $(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 $(XFORM) $(XSRCDIR)/struct.c $(SRCDIR)/struct.c
$(XSRCDIR)/stxobj.c: ../src/stxobj.@LTO@ $(XFORMDEP) $(XSRCDIR)/stxobj.c: ../src/stxobj.@LTO@ $(XFORMDEP)
$(XFORM) $(XSRCDIR)/stxobj.c $(SRCDIR)/stxobj.c $(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 $(XFORM) $(XSRCDIR)/symbol.c $(SRCDIR)/symbol.c
$(XSRCDIR)/syntax.c: ../src/syntax.@LTO@ $(XFORMDEP) $(XSRCDIR)/syntax.c: ../src/syntax.@LTO@ $(XFORMDEP)
$(XFORM) $(XSRCDIR)/syntax.c $(SRCDIR)/syntax.c $(XFORM) $(XSRCDIR)/syntax.c $(SRCDIR)/syntax.c
@ -221,9 +228,6 @@ $(XSRCDIR)/foreign.c: ../../foreign/foreign.@LTO@ $(XFORMDEP)
$(XSRCDIR)/main.c: ../main.@LTO@ $(XFORMDEP) $(XSRCDIR)/main.c: ../main.@LTO@ $(XFORMDEP)
$(XFORM_NOPRECOMP) $(XSRCDIR)/main.c $(DEF_COLLECTS_DIR) $(srcdir)/../main.c $(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 salloc.@LTO@: $(XSRCDIR)/salloc.c
$(CC) $(CFLAGS) -c $(XSRCDIR)/salloc.c -o salloc.@LTO@ $(CC) $(CFLAGS) -c $(XSRCDIR)/salloc.c -o salloc.@LTO@
bignum.@LTO@: $(XSRCDIR)/bignum.c bignum.@LTO@: $(XSRCDIR)/bignum.c
@ -252,13 +256,11 @@ hash.@LTO@: $(XSRCDIR)/hash.c
$(CC) $(CFLAGS) -c $(XSRCDIR)/hash.c -o hash.@LTO@ $(CC) $(CFLAGS) -c $(XSRCDIR)/hash.c -o hash.@LTO@
jit.@LTO@: $(XSRCDIR)/jit.c jit.@LTO@: $(XSRCDIR)/jit.c
$(CC) $(CFLAGS) -c $(XSRCDIR)/jit.c -o jit.@LTO@ $(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 list.@LTO@: $(XSRCDIR)/list.c
$(CC) $(CFLAGS) -c $(XSRCDIR)/list.c -o list.@LTO@ $(CC) $(CFLAGS) -c $(XSRCDIR)/list.c -o list.@LTO@
module.@LTO@: $(XSRCDIR)/module.c module.@LTO@: $(XSRCDIR)/module.c
$(CC) $(CFLAGS) -c $(XSRCDIR)/module.c -o module.@LTO@ $(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@ $(CC) $(CFLAGS) -DMZ_PRECISE_GC -c $(SRCDIR)/mzrt.c -o mzrt.@LTO@
network.@LTO@: $(XSRCDIR)/network.c network.@LTO@: $(XSRCDIR)/network.c
$(CC) $(CFLAGS) -c $(XSRCDIR)/network.c -o network.@LTO@ $(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 \ gc2.@LTO@: $(srcdir)/gc2.c $(srcdir)/newgc.c $(srcdir)/gc2.h \
$(srcdir)/newgc.h $(srcdir)/blame_the_child.c \ $(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_osx.c $(srcdir)/vm_mmap.c $(srcdir)/vm_osk.c $(srcdir)/vm.c\
$(srcdir)/vm_memalign.c $(srcdir)/alloc_cache.c \ $(srcdir)/vm_memalign.c $(srcdir)/alloc_cache.c \
$(srcdir)/page_range.c $(srcdir)/protect_range.c $(srcdir)/var_stack.c $(srcdir)/stack_comp.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 $(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@ $(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_OBJS = ../../foreign/gcc/libffi/src/*.@LTO@ ../../foreign/gcc/libffi/src/*/*.@LTO@
FOREIGN_LIB = ../../foreign/gcc/libffi/libffi@FOREIGN_CONVENIENCE@.la FOREIGN_LIB = ../../foreign/gcc/libffi/libffi@FOREIGN_CONVENIENCE@.la
FOREIGN_OBJSLIB = @FOREIGN_OBJSLIB@ 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_T = ../src/gmp.@LTO@ ../src/unwind.@LTO@ $(@FOREIGN_IF_USED@_LIB)
EXTRA_OBJS_L = ../src/gmp.@LTO@ ../src/unwind.@LTO@ $(@FOREIGN_IF_USED@_OBJSLIB) EXTRA_OBJS_L = ../src/gmp.@LTO@ ../src/unwind.@LTO@ $(@FOREIGN_IF_USED@_OBJSLIB)
../libmzscheme3m.@LIBSFX@: $(OBJS) $(EXTRA_OBJS_T) jit.@LTO@ gc2.@LTO@ ../libmzscheme3m.@LIBSFX@: $(OBJS) $(EXTRA_OBJS_T) gc2.@LTO@
$(AR) $(ARFLAGS) ../libmzscheme3m.@LIBSFX@ $(OBJS) $(EXTRA_OBJS_L) jit.@LTO@ gc2.@LTO@ $(AR) $(ARFLAGS) ../libmzscheme3m.@LIBSFX@ $(OBJS) $(EXTRA_OBJS_L) gc2.@LTO@
$(RANLIB) ../libmzscheme3m.@LIBSFX@ $(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@ ../mzscheme@MMM@@NOT_OSX@: main.@LTO@ ../libmzscheme3m.@LIBSFX@
cd ..; @MZLINKER@ -o mzscheme@MMM@ @PROFFLAGS@ gc2/main.@LTO@ libmzscheme3m.@LIBSFX@ @LDFLAGS@ $(LIBS) 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, # 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 # at least for Mac OS X. Beware of changing LIBS or LDFLAGS to inclucde something with a relative
# path. # 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" 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@" /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: clean:
/bin/rm -f ../mzscheme@MMM@ *.@LTO@ $(XSRCDIR)/* /bin/rm -f ../mzscheme@MMM@ *.@LTO@ $(XSRCDIR)/*
/bin/rm -rf xform-collects /bin/rm -rf xform-collects

67
src/mzscheme/gc2/blame_the_child.c
View File

@ -4,6 +4,13 @@
#ifdef NEWGC_BTC_ACCOUNT #ifdef NEWGC_BTC_ACCOUNT
#include "../src/schpriv.h" #include "../src/schpriv.h"
/* BTC_ prefixed functions are called by newgc.c */
/* btc_ prefixed functions are 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 */ /* 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) inline static void mark_threads(NewGC *gc, int owner)
{ {
GC_Thread_Info *work; GC_Thread_Info *work;
Mark_Proc thread_mark = gc->mark_table[btc_redirect_thread];
for(work = gc->thread_infos; work; work = work->next) for(work = gc->thread_infos; work; work = work->next)
if(work->owner == owner) { if(work->owner == owner) {
if (((Scheme_Thread *)work->thread)->running) { if (((Scheme_Thread *)work->thread)->running) {
gc->normal_thread_mark(work->thread); thread_mark(work->thread);
if (work->thread == scheme_current_thread) { if (work->thread == scheme_current_thread) {
GC_mark_variable_stack(GC_variable_stack, 0, get_stack_base(gc), NULL); 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; Scheme_Object *pr, *prev = NULL, *next;
GC_Weak_Box *wb; 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 */ /* 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); wb = (GC_Weak_Box *)SCHEME_CAR(pr);
next = SCHEME_CDR(pr); next = SCHEME_CDR(pr);
if (wb->val) { if (wb->val) {
gc->normal_cust_box_mark(wb->val); cust_box_mark(wb->val);
prev = pr; prev = pr;
} else { } else {
if (prev) if (prev)
@ -273,21 +282,32 @@ inline static void mark_cust_boxes(NewGC *gc, Scheme_Custodian *cur)
int BTC_thread_mark(void *p) 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) int BTC_custodian_mark(void *p)
{ {
NewGC *gc = GC_get_GC(); NewGC *gc = GC_get_GC();
if(custodian_to_owner_set(gc, p) == gc->current_mark_owner) if (gc->doing_memory_accounting) {
return gc->normal_custodian_mark(p); if(custodian_to_owner_set(gc, p) == gc->current_mark_owner)
else return gc->mark_table[btc_redirect_custodian](p);
return ((struct objhead *)(NUM(p) - WORD_SIZE))->size; else
return ((struct objhead *)(NUM(p) - WORD_SIZE))->size;
}
return gc->mark_table[btc_redirect_custodian](p);
} }
int BTC_cust_box_mark(void *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) 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(); 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) static void BTC_do_accounting(NewGC *gc)
{ {
const int table_size = gc->owner_table_size; 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->in_unsafe_allocation_mode = 1;
gc->unsafe_allocation_abort = btc_overmem_abort; 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 */ /* clear the memory use numbers out */
for(i = 1; i < table_size; i++) for(i = 1; i < table_size; i++)
if(owner_table[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; 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->in_unsafe_allocation_mode = 0;
gc->doing_memory_accounting = 0; gc->doing_memory_accounting = 0;
gc->old_btc_mark = gc->new_btc_mark; gc->old_btc_mark = gc->new_btc_mark;

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

@ -376,6 +376,19 @@ GC2_EXTERN void GC_write_barrier(void *p);
Explicit write barrier to ensure that a write-barrier signal is not Explicit write barrier to ensure that a write-barrier signal is not
triggered by a memory write. 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 # ifdef __cplusplus
}; };

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

@ -31,10 +31,12 @@
#include <stdlib.h> #include <stdlib.h>
#include <stdio.h> #include <stdio.h>
#include <string.h> #include <string.h>
#include <assert.h>
#include "platforms.h" #include "platforms.h"
#include "gc2.h" #include "gc2.h"
#include "gc2_dump.h" #include "gc2_dump.h"
/* the number of tags to use for tagged objects */ /* the number of tags to use for tagged objects */
#define NUMBER_OF_TAGS 512 #define NUMBER_OF_TAGS 512
@ -73,9 +75,16 @@ static const char *type_name[PAGE_TYPES] = {
#include "newgc.h" #include "newgc.h"
static NewGC *MASTERGC;
static THREAD_LOCAL NewGC *GC; static THREAD_LOCAL NewGC *GC;
#define GCTYPE NewGC #define GCTYPE NewGC
#define GC_get_GC() (GC) #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" #include "msgprint.c"
@ -260,10 +269,33 @@ int GC_mtrace_union_current_with(int newval)
/*****************************************************************************/ /*****************************************************************************/
/* Page Map Routines */ /* 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; i<PAGEMAP64_LEVEL1_SIZE; i++) {
page_maps2 = page_maps1[i];
if (page_maps2) {
for (j=0; j<PAGEMAP64_LEVEL2_SIZE; j++) {
page_maps3 = page_maps2[j];
if (page_maps3) {
free(page_maps3);
}
}
free(page_maps2);
}
}
free(page_maps1);
#else
free(page_maps1);
#endif
}
/* the page map makes a nice mapping from addresses to pages, allowing /* the page map makes a nice mapping from addresses to pages, allowing
fairly fast lookup. this is useful. */ fairly fast lookup. this is useful. */
inline static void pagemap_set(PageMap page_maps1, void *p, mpage *value) { inline static void pagemap_set(PageMap page_maps1, void *p, mpage *value) {
#ifdef SIXTY_FOUR_BIT_INTEGERS #ifdef SIXTY_FOUR_BIT_INTEGERS
unsigned long pos; unsigned long pos;
@ -1240,11 +1272,6 @@ inline static void reset_weak_finalizers(NewGC *gc)
/* This is the code we use to implement the mark stack. We can't, sadly, use /* This is the code we use to implement the mark stack. We can't, sadly, use
the standard C stack because we'll blow it; propagation makes for a *very* the standard C stack because we'll blow it; propagation makes for a *very*
deep stack. So we use this instead. */ deep stack. So we use this instead. */
typedef struct MarkSegment {
struct MarkSegment *prev;
struct MarkSegment *next;
void **top;
} MarkSegment;
#define MARK_STACK_START(ms) ((void **)(void *)&ms[1]) #define MARK_STACK_START(ms) ((void **)(void *)&ms[1])
#define MARK_STACK_END(ms) ((void **)((char *)ms + STACK_PART_SIZE)) #define MARK_STACK_END(ms) ((void **)((char *)ms + STACK_PART_SIZE))
@ -1258,8 +1285,8 @@ inline static MarkSegment* mark_stack_create_frame() {
return mark_frame; return mark_frame;
} }
inline static void init_mark_stack() inline static void mark_stack_initialize() {
{ /* This happens at the very beginning */
if(!mark_stack) { if(!mark_stack) {
mark_stack = mark_stack_create_frame(); mark_stack = mark_stack_create_frame();
mark_stack->prev = NULL; mark_stack->prev = NULL;
@ -1381,9 +1408,8 @@ void GC_register_new_thread(void *t, void *c)
/* administration / initialization */ /* 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); struct mpage *page = pagemap_find_page(gc->page_maps, p);
if (gc->no_further_modifications) { if (gc->no_further_modifications) {
@ -1399,11 +1425,20 @@ static int designate_modified(void *p)
return 1; return 1;
} }
} else { } else {
if (gc->primoridal_gc) {
return designate_modified_gc(gc->primoridal_gc, p);
}
GCPRINT(GCOUTF, "Seg fault (internal error) at %p\n", p); GCPRINT(GCOUTF, "Seg fault (internal error) at %p\n", p);
} }
return 0; 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 GC_write_barrier(void *p)
{ {
(void)designate_modified(p); (void)designate_modified(p);
@ -1411,23 +1446,76 @@ void GC_write_barrier(void *p)
#include "sighand.c" #include "sighand.c"
void NewGC_initialize(NewGC *newgc) { void NewGC_initialize(NewGC *newgc, NewGC *parentgc) {
memset(newgc, 0, sizeof(NewGC)); if (parentgc) {
newgc->mark_table = ofm_malloc_zero(NUMBER_OF_TAGS * sizeof (Mark_Proc)); newgc->mark_table = parentgc->mark_table;
newgc->fixup_table = ofm_malloc_zero(NUMBER_OF_TAGS * sizeof (Fixup_Proc)); 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 #ifdef SIXTY_FOUR_BIT_INTEGERS
newgc->page_maps = ofm_malloc_zero(PAGEMAP64_LEVEL1_SIZE * sizeof (mpage***)); newgc->page_maps = ofm_malloc_zero(PAGEMAP64_LEVEL1_SIZE * sizeof (mpage***));
#else #else
newgc->page_maps = ofm_malloc_zero(PAGEMAP32_SIZE * sizeof (mpage*)); newgc->page_maps = ofm_malloc_zero(PAGEMAP32_SIZE * sizeof (mpage*));
#endif #endif
newgc->vm = vm_create(); newgc->vm = vm_create();
newgc->protect_range = ofm_malloc_zero(sizeof(Page_Range)); newgc->protect_range = ofm_malloc_zero(sizeof(Page_Range));
newgc->generations_available = 1; newgc->generations_available = 1;
newgc->last_full_mem_use = (20 * 1024 * 1024); newgc->last_full_mem_use = (20 * 1024 * 1024);
newgc->new_btc_mark = 1; 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) 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; static int initialized = 0;
if(!initialized) { if(!initialized) {
NewGC *gc;
initialized = 1; initialized = 1;
init_type_tags_worker(NULL, count, pair, mutable_pair, weakbox, ephemeron, weakarray, custbox);
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);
} }
else { else {
GCPRINT(GCOUTF, "HEY WHATS UP.\n"); GCPRINT(GCOUTF, "GC_init_type_tags should only be called once!\n");
abort(); 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) void GC_gcollect(void)
{ {
NewGC *gc = GC_get_GC(); 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) Fixup_Proc fixup, int constant_Size, int atomic)
{ {
NewGC *gc = GC_get_GC(); 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) long GC_get_memory_use(void *o)
@ -1709,8 +1815,10 @@ static void propagate_marks(NewGC *gc)
unsigned short tag = *(unsigned short*)start; unsigned short tag = *(unsigned short*)start;
if((unsigned long)mark_table[tag] < PAGE_TYPES) { if((unsigned long)mark_table[tag] < PAGE_TYPES) {
/* atomic */ /* atomic */
} else } else {
assert(mark_table[tag]);
mark_table[tag](start); break; mark_table[tag](start); break;
}
} }
case PAGE_ATOMIC: break; case PAGE_ATOMIC: break;
case PAGE_ARRAY: while(start < end) gcMARK(*(start++)); break; case PAGE_ARRAY: while(start < end) gcMARK(*(start++)); break;
@ -1718,7 +1826,10 @@ static void propagate_marks(NewGC *gc)
case PAGE_TARRAY: { case PAGE_TARRAY: {
unsigned short tag = *(unsigned short *)start; unsigned short tag = *(unsigned short *)start;
end -= INSET_WORDS; end -= INSET_WORDS;
while(start < end) start += mark_table[tag](start); while(start < end) {
assert(mark_table[tag]);
start += mark_table[tag](start);
}
break; break;
} }
} }
@ -1728,7 +1839,13 @@ static void propagate_marks(NewGC *gc)
set_backtrace_source(p, info->type); set_backtrace_source(p, info->type);
switch(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_ATOMIC: break;
case PAGE_ARRAY: { case PAGE_ARRAY: {
void **start = p; void **start = p;
@ -1740,7 +1857,10 @@ static void propagate_marks(NewGC *gc)
void **start = p; void **start = p;
void **end = PPTR(info) + (info->size - INSET_WORDS); void **end = PPTR(info) + (info->size - INSET_WORDS);
unsigned short tag = *(unsigned short *)start; 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; break;
} }
case PAGE_XTAGGED: GC_mark_xtagged(p); 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_roots(gc);
mark_immobiles(gc); mark_immobiles(gc);
TIME_STEP("rooted"); 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"); TIME_STEP("stacked");
/* now propagate/repair the marks we got from these roots, and do the /* now propagate/repair the marks we got from these roots, and do the
finalizer passes */ finalizer passes */
propagate_marks(gc); mark_ready_ephemerons(gc); propagate_marks(gc); propagate_marks(gc);
check_finalizers(gc, 1); mark_ready_ephemerons(gc); propagate_marks(gc); mark_ready_ephemerons(gc);
check_finalizers(gc, 2); mark_ready_ephemerons(gc); propagate_marks(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); if(gc->gc_full) zero_weak_finalizers(gc);
do_ordered_level3(gc); propagate_marks(gc); do_ordered_level3(gc); propagate_marks(gc);
check_finalizers(gc, 3); 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_weak_finalizer_structs(gc);
repair_roots(gc); repair_roots(gc);
repair_immobiles(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"); TIME_STEP("reparied roots");
repair_heap(gc); repair_heap(gc);
TIME_STEP("repaired"); 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_flush_freed_pages(gc->vm);
vm_free(gc->vm); vm_free(gc->vm);
free(gc); free(gc);

20
src/mzscheme/gc2/newgc.h
View File

@ -35,6 +35,12 @@ typedef struct Gen0 {
unsigned long max_size; unsigned long max_size;
} Gen0; } Gen0;
typedef struct MarkSegment {
struct MarkSegment *prev;
struct MarkSegment *next;
void **top;
} MarkSegment;
typedef struct Weak_Finalizer { typedef struct Weak_Finalizer {
void *p; void *p;
int offset; int offset;
@ -110,10 +116,7 @@ typedef struct NewGC {
void (*unsafe_allocation_abort)(struct NewGC *); void (*unsafe_allocation_abort)(struct NewGC *);
unsigned long memory_in_use; /* the amount of memory in use */ unsigned long memory_in_use; /* the amount of memory in use */
/* blame the child saved off Mark_Proc pointers */ /* blame the child thread infos */
Mark_Proc normal_thread_mark;
Mark_Proc normal_custodian_mark;
Mark_Proc normal_cust_box_mark;
GC_Thread_Info *thread_infos; GC_Thread_Info *thread_infos;
mpage *release_pages; mpage *release_pages;
@ -141,8 +144,6 @@ typedef struct NewGC {
AccountHook *hooks; AccountHook *hooks;
unsigned long number_of_gc_runs; unsigned long number_of_gc_runs;
unsigned int since_last_full; unsigned int since_last_full;
unsigned long last_full_mem_use; unsigned long last_full_mem_use;
@ -151,6 +152,13 @@ typedef struct NewGC {
unsigned long peak_memory_use; unsigned long peak_memory_use;
unsigned long num_minor_collects; unsigned long num_minor_collects;
unsigned long num_major_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 */ /* Callbacks */
void (*GC_collect_start_callback)(void); void (*GC_collect_start_callback)(void);

35
src/mzscheme/gc2/sighand.c
View File

@ -14,11 +14,42 @@
/* ========== Linux signal handler ========== */ /* ========== Linux signal handler ========== */
#if defined(linux) #if defined(linux)
# include <signal.h> #include <signal.h>
#include <sys/types.h>
#include <unistd.h>
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) 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(); 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 NEED_SIGACTION
# define USE_SIGACTON_SIGNAL_KIND SIGSEGV # define USE_SIGACTON_SIGNAL_KIND SIGSEGV
} }

15
src/mzscheme/gc2/weak.c
View File

@ -234,12 +234,17 @@ static int mark_ephemeron(void *p)
#ifdef NEWGC_BTC_ACCOUNT #ifdef NEWGC_BTC_ACCOUNT
static int BTC_ephemeron_mark(void *p) static int BTC_ephemeron_mark(void *p)
{ {
GC_Ephemeron *eph = (GC_Ephemeron *)p; GCTYPE *gc = GC_get_GC();
if (gc->doing_memory_accounting) {
gcMARK(eph->key);
gcMARK(eph->val);
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 #endif

13
src/mzscheme/sgc/sgc.c
View File

@ -776,25 +776,24 @@ static long mem_traced;
static long num_chunks; static long num_chunks;
static long num_blocks; 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_start_callback_Proc GC_collect_start_callback;
GC_collect_end_callback_Proc GC_collect_end_callback; GC_collect_end_callback_Proc GC_collect_end_callback;
void (*GC_custom_finalize)(void); 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; GC_collect_start_callback_Proc old;
old = GC_collect_start_callback; old = GC_collect_start_callback;
GC_collect_start_callback = func; 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 GC_set_collect_end_callback(GC_collect_end_callback_Proc func) {
GC_collect_end_callback_Proc old GC_collect_end_callback_Proc old;
old = GC_collect_end_callback; old = GC_collect_end_callback;
GC_collect_end_callback = func; GC_collect_end_callback = func;
return old return old;
} }
static long roots_count; static long roots_count;
static long roots_size; static long roots_size;
static unsigned long *roots; static unsigned long *roots;

5
src/mzscheme/sgc/sgc.h
View File

@ -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_uncollectable(size_t size_in_bytes);
void *GC_malloc_atomic_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. */ void GC_free(void *); /* ... but only if it's turned on in sgc.c. */
struct GC_Set; struct GC_Set;

6
src/mzscheme/src/Makefile.in
View File

@ -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)/../src/stypes.h $(srcdir)/codetab.inc $(srcdir)/mzmark.c \
$(srcdir)/lightning/i386/core.h $(srcdir)/lightning/i386/core-common.h \ $(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/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/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 \ list.@LTO@: $(srcdir)/schpriv.h $(srcdir)/schexn.h $(SCONFIG) $(srcdir)/../include/scheme.h \
$(srcdir)/../src/stypes.h $(srcdir)/../src/stypes.h
module.@LTO@: $(srcdir)/schpriv.h $(srcdir)/schexn.h $(SCONFIG) $(srcdir)/../include/scheme.h \ module.@LTO@: $(srcdir)/schpriv.h $(srcdir)/schexn.h $(SCONFIG) $(srcdir)/../include/scheme.h \

201
src/mzscheme/src/cstartup.inc
View File

@ -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, 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, 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, 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, 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, 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, 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, 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, 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, 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, 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, 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,53,93,8,224,252,60,0,0,95,9,8,224,252,60,0, 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, 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, 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, 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, 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, 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, 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,56,93,8,224,253,60,0,0,95,9, 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, 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, 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, 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, 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, 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, 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, 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,49,93,8,224,254,60,0,0,18,16,2,158,94,10, 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, 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,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,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, 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, 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, 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, 2,3,36,16,0,35,16,0,35,11,11,38,35,11,11,16,10,2,4,2,5,
7,2,8,2,9,2,10,2,11,2,12,2,13,16,10,11,11,11,11,11,11, 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,16,10,2,4,2,5,2,6,2,7,2,8,2,9,2,10,2, 11,11,11,11,11,11,11,16,10,2,4,2,5,2,6,2,7,2,8,2,9,
11,2,12,2,13,35,45,36,11,11,16,0,16,0,16,0,35,35,11,11,11, 2,10,2,11,2,12,2,13,35,45,36,11,11,16,0,16,0,16,0,35,35,
16,0,16,0,16,0,35,35,16,11,16,5,93,2,3,20,15,159,35,35,35, 11,11,11,16,0,16,0,16,0,35,35,16,11,16,5,93,2,3,20,15,159,
35,20,103,159,35,16,0,16,1,33,32,10,16,5,93,2,8,89,162,8,44, 35,35,35,35,20,103,159,35,16,0,16,1,33,32,10,16,5,93,2,8,89,
36,52,9,223,0,33,33,35,20,103,159,35,16,1,20,25,159,36,2,2,2, 162,8,44,36,52,9,223,0,33,33,35,20,103,159,35,16,1,20,25,159,36,
3,16,0,11,16,5,93,2,10,89,162,8,44,36,52,9,223,0,33,34,35, 2,2,2,3,16,0,11,16,5,93,2,10,89,162,8,44,36,52,9,223,0,
20,103,159,35,16,1,20,25,159,36,2,2,2,3,16,0,11,16,5,93,2, 33,34,35,20,103,159,35,16,1,20,25,159,36,2,2,2,3,16,0,11,16,
13,89,162,8,44,36,52,9,223,0,33,35,35,20,103,159,35,16,1,20,25, 5,93,2,13,89,162,8,44,36,52,9,223,0,33,35,35,20,103,159,35,16,
159,36,2,2,2,3,16,1,33,36,11,16,5,93,2,6,89,162,8,44,36, 1,20,25,159,36,2,2,2,3,16,1,33,36,11,16,5,93,2,6,89,162,
55,9,223,0,33,37,35,20,103,159,35,16,1,20,25,159,36,2,2,2,3, 8,44,36,55,9,223,0,33,37,35,20,103,159,35,16,1,20,25,159,36,2,
16,1,33,38,11,16,5,93,2,4,89,162,8,44,36,57,9,223,0,33,41, 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, 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, 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,0,11,16,5,93,2,7,89,162,8,44,36,53, 25,159,36,2,2,2,3,16,1,33,48,11,16,5,93,2,12,89,162,8,44,
9,223,0,33,44,35,20,103,159,35,16,1,20,25,159,36,2,2,2,3,16, 36,53,9,223,0,33,49,35,20,103,159,35,16,1,20,25,159,36,2,2,2,
0,11,16,5,93,2,5,89,162,8,44,36,54,9,223,0,33,45,35,20,103, 3,16,0,11,16,0,94,2,15,2,16,93,2,15,9,9,35,0};
159,35,16,1,20,25,159,36,2,2,2,3,16,0,11,16,5,93,2,9,89, EVAL_ONE_SIZED_STR((char *)expr, 2117);
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);
} }
{ {
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, 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, 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, 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, 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, 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, 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,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, 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, 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, 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, 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, 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, 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, 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, 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, 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, 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, 0,35,16,0,35,16,4,2,6,2,5,2,3,2,9,39,11,11,38,35,11,
2,8,2,7,2,16,2,15,2,13,2,12,2,4,2,11,2,14,2,10,2, 11,16,11,2,8,2,7,2,16,2,15,2,13,2,12,2,4,2,11,2,14,
2,16,11,11,11,11,11,11,11,11,11,11,11,11,16,11,2,8,2,7,2, 2,10,2,2,16,11,11,11,11,11,11,11,11,11,11,11,11,16,11,2,8,
16,2,15,2,13,2,12,2,4,2,11,2,14,2,10,2,2,46,46,36,11, 2,7,2,16,2,15,2,13,2,12,2,4,2,11,2,14,2,10,2,2,46,
11,16,0,16,0,16,0,35,35,11,11,11,16,0,16,0,16,0,35,35,16, 46,36,11,11,16,0,16,0,16,0,35,35,11,11,11,16,0,16,0,16,0,
0,16,17,83,158,35,16,2,89,162,43,36,48,2,19,223,0,33,29,80,159, 35,35,16,0,16,17,83,158,35,16,2,89,162,43,36,48,2,19,223,0,33,
35,53,36,83,158,35,16,2,89,162,8,44,36,55,2,19,223,0,33,30,80, 29,80,159,35,53,36,83,158,35,16,2,89,162,8,44,36,55,2,19,223,0,
159,35,52,36,83,158,35,16,2,32,0,89,162,43,36,44,2,2,222,33,31, 33,30,80,159,35,52,36,83,158,35,16,2,32,0,89,162,43,36,44,2,2,
80,159,35,35,36,83,158,35,16,2,249,22,159,6,7,92,7,92,80,159,35, 222,33,31,80,159,35,35,36,83,158,35,16,2,249,22,159,6,7,92,7,92,
36,36,83,158,35,16,2,89,162,43,36,53,2,4,223,0,33,32,80,159,35, 80,159,35,36,36,83,158,35,16,2,89,162,43,36,53,2,4,223,0,33,32,
37,36,83,158,35,16,2,32,0,89,162,8,44,37,49,2,5,222,33,33,80, 80,159,35,37,36,83,158,35,16,2,32,0,89,162,8,44,37,49,2,5,222,
159,35,38,36,83,158,35,16,2,32,0,89,162,8,44,38,50,2,6,222,33, 33,33,80,159,35,38,36,83,158,35,16,2,32,0,89,162,8,44,38,50,2,
35,80,159,35,39,36,83,158,35,16,2,89,162,8,45,37,47,2,7,223,0, 6,222,33,35,80,159,35,39,36,83,158,35,16,2,89,162,8,45,37,47,2,
33,37,80,159,35,40,36,83,158,35,16,2,32,0,89,162,43,39,51,2,8, 7,223,0,33,37,80,159,35,40,36,83,158,35,16,2,32,0,89,162,43,39,
222,33,40,80,159,35,41,36,83,158,35,16,2,32,0,89,162,43,38,49,2, 51,2,8,222,33,40,80,159,35,41,36,83,158,35,16,2,32,0,89,162,43,
9,222,33,41,80,159,35,42,36,83,158,35,16,2,32,0,89,162,43,37,52, 38,49,2,9,222,33,41,80,159,35,42,36,83,158,35,16,2,32,0,89,162,
2,10,222,33,42,80,159,35,43,36,83,158,35,16,2,32,0,89,162,43,37, 43,37,52,2,10,222,33,42,80,159,35,43,36,83,158,35,16,2,32,0,89,
53,2,11,222,33,43,80,159,35,44,36,83,158,35,16,2,32,0,89,162,43, 162,43,37,53,2,11,222,33,43,80,159,35,44,36,83,158,35,16,2,32,0,
36,43,2,12,222,33,44,80,159,35,45,36,83,158,35,16,2,83,158,38,20, 89,162,43,36,43,2,12,222,33,44,80,159,35,45,36,83,158,35,16,2,83,
96,96,2,13,89,162,43,35,43,9,223,0,33,45,89,162,43,36,44,9,223, 158,38,20,96,96,2,13,89,162,43,35,43,9,223,0,33,45,89,162,43,36,
0,33,46,89,162,43,37,54,9,223,0,33,47,80,159,35,46,36,83,158,35, 44,9,223,0,33,46,89,162,43,37,54,9,223,0,33,47,80,159,35,46,36,
16,2,27,248,22,182,13,248,22,168,7,27,28,249,22,162,8,247,22,176,7, 83,158,35,16,2,27,248,22,182,13,248,22,168,7,27,28,249,22,162,8,247,
2,21,6,1,1,59,6,1,1,58,250,22,141,7,6,14,14,40,91,94,126, 22,176,7,2,21,6,1,1,59,6,1,1,58,250,22,141,7,6,14,14,40,
97,93,42,41,126,97,40,46,42,41,23,196,2,23,196,1,89,162,8,44,37, 91,94,126,97,93,42,41,126,97,40,46,42,41,23,196,2,23,196,1,89,162,
47,2,14,223,0,33,50,80,159,35,47,36,83,158,35,16,2,83,158,38,20, 8,44,37,47,2,14,223,0,33,50,80,159,35,47,36,83,158,35,16,2,83,
96,96,2,15,89,162,8,44,38,53,9,223,0,33,55,89,162,43,37,46,9, 158,38,20,96,96,2,15,89,162,8,44,38,53,9,223,0,33,55,89,162,43,
223,0,33,56,89,162,43,36,45,9,223,0,33,57,80,159,35,48,36,83,158, 37,46,9,223,0,33,56,89,162,43,36,45,9,223,0,33,57,80,159,35,48,
35,16,2,89,162,43,38,51,2,16,223,0,33,59,80,159,35,49,36,94,29, 36,83,158,35,16,2,89,162,43,38,51,2,16,223,0,33,59,80,159,35,49,
94,2,17,68,35,37,107,101,114,110,101,108,11,29,94,2,17,69,35,37,109, 36,94,29,94,2,17,68,35,37,107,101,114,110,101,108,11,29,94,2,17,69,
105,110,45,115,116,120,11,9,9,9,35,0}; 35,37,109,105,110,45,115,116,120,11,9,9,9,35,0};
EVAL_ONE_SIZED_STR((char *)expr, 5072); 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, 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,3,1,0,0,65,113,117,111,116, 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, 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, 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, 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, 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, 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, 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, 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, 16,0,35,16,0,35,11,11,38,35,11,11,16,0,16,0,16,0,35,35,36,
0,16,0,16,0,35,35,11,11,11,16,0,16,0,16,0,35,35,16,0,16, 11,11,16,0,16,0,16,0,35,35,11,11,11,16,0,16,0,16,0,35,35,
0,99,2,6,2,5,29,94,2,1,69,35,37,102,111,114,101,105,103,110,11, 16,0,16,0,99,2,6,2,5,29,94,2,1,69,35,37,102,111,114,101,105,
2,4,2,3,2,2,29,94,2,1,67,35,37,112,108,97,99,101,11,9,9, 103,110,11,2,4,2,3,2,2,29,94,2,1,67,35,37,112,108,97,99,101,
9,35,0}; 11,9,9,9,35,0};
EVAL_ONE_SIZED_STR((char *)expr, 296); 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, 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, 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, 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, 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, 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, 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, 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, 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, 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, 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, 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, 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, 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, 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, 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, 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, 117,102,102,105,120,9,30,2,1,2,16,193,16,0,11,11,16,0,35,16,0,
2,10,2,11,2,8,2,9,2,12,2,13,2,3,2,7,2,2,2,15,2, 35,16,11,2,10,2,11,2,8,2,9,2,12,2,13,2,3,2,7,2,2,
14,46,11,11,38,35,11,11,16,1,2,16,16,1,11,16,1,2,16,36,36, 2,15,2,14,46,11,11,38,35,11,11,16,1,2,16,16,1,11,16,1,2,
36,11,11,16,0,16,0,16,0,35,35,11,11,11,16,0,16,0,16,0,35, 16,36,36,36,11,11,16,0,16,0,16,0,35,35,11,11,11,16,0,16,0,
35,16,0,16,16,83,158,35,16,2,89,162,43,36,44,9,223,0,33,24,80, 16,0,35,35,16,0,16,16,83,158,35,16,2,89,162,43,36,44,9,223,0,
159,35,57,36,83,158,35,16,2,89,162,43,36,44,9,223,0,33,25,80,159, 33,24,80,159,35,57,36,83,158,35,16,2,89,162,43,36,44,9,223,0,33,
35,56,36,83,158,35,16,2,89,162,43,36,48,67,103,101,116,45,100,105,114, 25,80,159,35,56,36,83,158,35,16,2,89,162,43,36,48,67,103,101,116,45,
223,0,33,26,80,159,35,55,36,83,158,35,16,2,89,162,43,37,48,68,119, 100,105,114,223,0,33,26,80,159,35,55,36,83,158,35,16,2,89,162,43,37,
105,116,104,45,100,105,114,223,0,33,27,80,159,35,54,36,83,158,35,16,2, 48,68,119,105,116,104,45,100,105,114,223,0,33,27,80,159,35,54,36,83,158,
248,22,176,7,69,115,111,45,115,117,102,102,105,120,80,159,35,35,36,83,158, 35,16,2,248,22,176,7,69,115,111,45,115,117,102,102,105,120,80,159,35,35,
35,16,2,89,162,43,37,59,2,3,223,0,33,36,80,159,35,36,36,83,158, 36,83,158,35,16,2,89,162,43,37,59,2,3,223,0,33,36,80,159,35,36,
35,16,2,32,0,89,162,8,44,36,41,2,7,222,192,80,159,35,41,36,83, 36,83,158,35,16,2,32,0,89,162,8,44,36,41,2,7,222,192,80,159,35,
158,35,16,2,247,22,125,80,159,35,42,36,83,158,35,16,2,247,22,124,80, 41,36,83,158,35,16,2,247,22,125,80,159,35,42,36,83,158,35,16,2,247,
159,35,43,36,83,158,35,16,2,247,22,60,80,159,35,44,36,83,158,35,16, 22,124,80,159,35,43,36,83,158,35,16,2,247,22,60,80,159,35,44,36,83,
2,248,22,18,74,109,111,100,117,108,101,45,108,111,97,100,105,110,103,80,159, 158,35,16,2,248,22,18,74,109,111,100,117,108,101,45,108,111,97,100,105,110,
35,45,36,83,158,35,16,2,11,80,158,35,46,83,158,35,16,2,11,80,158, 103,80,159,35,45,36,83,158,35,16,2,11,80,158,35,46,83,158,35,16,2,
35,47,83,158,35,16,2,32,0,89,162,43,37,44,2,14,222,33,42,80,159, 11,80,158,35,47,83,158,35,16,2,32,0,89,162,43,37,44,2,14,222,33,
35,48,36,83,158,35,16,2,89,162,8,44,36,44,2,15,223,0,33,51,80, 42,80,159,35,48,36,83,158,35,16,2,89,162,8,44,36,44,2,15,223,0,
159,35,49,36,83,158,35,16,2,89,162,43,35,43,2,16,223,0,33,52,80, 33,51,80,159,35,49,36,83,158,35,16,2,89,162,43,35,43,2,16,223,0,
159,35,53,36,95,29,94,2,4,68,35,37,107,101,114,110,101,108,11,29,94, 33,52,80,159,35,53,36,95,29,94,2,4,68,35,37,107,101,114,110,101,108,
2,4,69,35,37,109,105,110,45,115,116,120,11,2,5,9,9,9,35,0}; 11,29,94,2,4,69,35,37,109,105,110,45,115,116,120,11,2,5,9,9,9,
EVAL_ONE_SIZED_STR((char *)expr, 4135); 35,0};
EVAL_ONE_SIZED_STR((char *)expr, 4138);
} }

12
src/mzscheme/src/env.c
View File

@ -288,7 +288,6 @@ static void init_toplevel_local_offsets_hashtable_caches()
} }
} }
/* READ-ONLY GLOBAL structures ONE-TIME initialization */ /* READ-ONLY GLOBAL structures ONE-TIME initialization */
Scheme_Env *scheme_engine_instance_init() { Scheme_Env *scheme_engine_instance_init() {
Scheme_Env *env; Scheme_Env *env;
@ -325,6 +324,16 @@ Scheme_Env *scheme_engine_instance_init() {
#ifndef MZ_PRECISE_GC #ifndef MZ_PRECISE_GC
scheme_init_ephemerons(); scheme_init_ephemerons();
#endif #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); place_instance_init_pre_kernel(stack_base);
make_kernel_env(); 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 ordering of the first few init calls is important, so add to
the end of the list, not the beginning. */ the end of the list, not the beginning. */
MZTIMEIT(symbol-table, scheme_init_symbol_table());
MZTIMEIT(type, scheme_init_type(env)); MZTIMEIT(type, scheme_init_type(env));
MZTIMEIT(symbol-type, scheme_init_symbol_type(env)); MZTIMEIT(symbol-type, scheme_init_symbol_type(env));
MZTIMEIT(fun, scheme_init_fun(env)); MZTIMEIT(fun, scheme_init_fun(env));

7
src/mzscheme/src/eval.c
View File

@ -8431,15 +8431,16 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
case scheme_with_cont_mark_type: case scheme_with_cont_mark_type:
{ {
Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)obj; 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(); UPDATE_THREAD_RSPTR();
key = wcm->key; key = wcm->key;
if (SCHEME_TYPE(key) < _scheme_values_types_) 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; val = wcm->val;
if (SCHEME_TYPE(val) < _scheme_values_types_) 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); scheme_set_cont_mark(key, val);

113
src/mzscheme/src/module.c
View File

@ -248,7 +248,8 @@ static char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash
char **_phase1_protects); char **_phase1_protects);
static Scheme_Object **compute_indirects(Scheme_Env *genv, static Scheme_Object **compute_indirects(Scheme_Env *genv,
Scheme_Module_Phase_Exports *pt, 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, 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); int eval_exp, int eval_run, long base_phase, Scheme_Object *cycle_list);
static void finish_expstart_module(Scheme_Env *menv); 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_extend_module_rename(one_rn, m->self_modidx, name, name, m->self_modidx, name, 0,
scheme_make_integer(0), NULL, 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); 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); 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_Object *rmp;
Scheme_Bucket *b; Scheme_Bucket *b;
@ -2718,11 +2730,6 @@ Scheme_Object *scheme_intern_resolved_module_path(Scheme_Object *o)
mzrt_mutex_lock(modpath_table_mutex); 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 = scheme_alloc_small_object();
rmp->type = scheme_resolved_module_path_type; rmp->type = scheme_resolved_module_path_type;
SCHEME_PTR_VAL(rmp) = o; SCHEME_PTR_VAL(rmp) = o;
@ -2738,6 +2745,21 @@ Scheme_Object *scheme_intern_resolved_module_path(Scheme_Object *o)
return return_value; 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[]) static Scheme_Object *resolved_module_path_p(int argc, Scheme_Object *argv[])
{ {
return (SCHEME_MODNAMEP(argv[0]) 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_Object *post_ex_rn_set; /* phase -> post_ex_rn-like rename */
Scheme_Hash_Table *tables; /* phase -> (vector toplevels requires syntaxes) */ Scheme_Hash_Table *tables; /* phase -> (vector toplevels requires syntaxes) */
Scheme_Object *exclude_hint = scheme_false, *lift_data; Scheme_Object *exclude_hint = scheme_false, *lift_data;
Scheme_Object **exis, **et_exis; Scheme_Object **exis, **et_exis, **exsis;
Scheme_Object *lift_ctx; Scheme_Object *lift_ctx;
int exicount, et_exicount; int exicount, et_exicount, exsicount;
char *exps, *et_exps; char *exps, *et_exps;
int all_simple_renames = 1; int all_simple_renames = 1;
int maybe_has_lifts = 0; 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); form, &et_exps);
/* Compute indirect provides (which is everything at the top-level): */ /* Compute indirect provides (which is everything at the top-level): */
exis = compute_indirects(env->genv, env->genv->module->me->rt, &exicount); exis = compute_indirects(env->genv, env->genv->module->me->rt, &exicount, 1);
et_exis = compute_indirects(env->genv->exp_env, env->genv->module->me->et, &et_exicount); 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)) { if (rec[drec].comp || (rec[drec].depth != -2)) {
scheme_clean_dead_env(env->genv); 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->indirect_provides = exis;
env->genv->module->num_indirect_provides = exicount; 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->et_indirect_provides = et_exis;
env->genv->module->num_indirect_et_provides = et_exicount; 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, static Scheme_Object **compute_indirects(Scheme_Env *genv,
Scheme_Module_Phase_Exports *pt, 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_Bucket **bs, *b;
Scheme_Object **exsns = pt->provide_src_names, **exis; 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; count = 0;
else { else {
bs = genv->toplevel->buckets; bs = t->buckets;
for (count = 0, i = genv->toplevel->size; i--; ) { for (count = 0, i = t->size; i--; ) {
b = bs[i]; b = bs[i];
if (b && b->val) if (b && b->val)
count++; count++;
@ -6955,7 +7002,7 @@ static Scheme_Object **compute_indirects(Scheme_Env *genv,
exis = MALLOC_N(Scheme_Object *, count); exis = MALLOC_N(Scheme_Object *, count);
for (count = 0, i = genv->toplevel->size; i--; ) { for (count = 0, i = t->size; i--; ) {
b = bs[i]; b = bs[i];
if (b && b->val) { if (b && b->val) {
Scheme_Object *name; Scheme_Object *name;
@ -6963,12 +7010,12 @@ static Scheme_Object **compute_indirects(Scheme_Env *genv,
name = (Scheme_Object *)b->key; name = (Scheme_Object *)b->key;
/* If the name is directly provided, no need for indirect... */ /* 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])) if (SAME_OBJ(name, exsns[j]))
break; break;
} }
if (j == exvcount) if (j == end)
exis[count++] = name; exis[count++] = name;
} }
} }
@ -9099,6 +9146,14 @@ static Scheme_Object *write_module(Scheme_Object *obj)
} }
l = cons(v, l); 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; count = m->num_indirect_et_provides;
l = cons(scheme_make_integer(count), l); l = cons(scheme_make_integer(count), l);
v = scheme_make_vector(count, NULL); v = scheme_make_vector(count, NULL);
@ -9249,6 +9304,24 @@ static Scheme_Object *read_module(Scheme_Object *obj)
count = SCHEME_INT_VAL(nie); 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(); if (!SCHEME_VECTORP(ie) || (SCHEME_VEC_SIZE(ie) != count)) return_NULL();
v = MALLOC_N(Scheme_Object *, count); v = MALLOC_N(Scheme_Object *, count);
for (i = 0; i < count; i++) { for (i = 0; i < count; i++) {

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

@ -2346,6 +2346,8 @@ static int module_val_MARK(void *p) {
gcMARK(m->provide_protects); gcMARK(m->provide_protects);
gcMARK(m->indirect_provides); gcMARK(m->indirect_provides);
gcMARK(m->indirect_syntax_provides);
gcMARK(m->et_provide_protects); gcMARK(m->et_provide_protects);
gcMARK(m->et_indirect_provides); gcMARK(m->et_indirect_provides);
@ -2390,6 +2392,8 @@ static int module_val_FIXUP(void *p) {
gcFIXUP(m->provide_protects); gcFIXUP(m->provide_protects);
gcFIXUP(m->indirect_provides); gcFIXUP(m->indirect_provides);
gcFIXUP(m->indirect_syntax_provides);
gcFIXUP(m->et_provide_protects); gcFIXUP(m->et_provide_protects);
gcFIXUP(m->et_indirect_provides); gcFIXUP(m->et_indirect_provides);

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

@ -937,6 +937,8 @@ module_val {
gcMARK(m->provide_protects); gcMARK(m->provide_protects);
gcMARK(m->indirect_provides); gcMARK(m->indirect_provides);
gcMARK(m->indirect_syntax_provides);
gcMARK(m->et_provide_protects); gcMARK(m->et_provide_protects);
gcMARK(m->et_indirect_provides); gcMARK(m->et_indirect_provides);

206
src/mzscheme/src/mzrt.c
View File

@ -5,7 +5,7 @@
/************************************************************************/ /************************************************************************/
/************************************************************************/ /************************************************************************/
/************************************************************************/ /************************************************************************/
#define MZRT_INTERNAL
#include "mzrt.h" #include "mzrt.h"
#include "schgc.h" #include "schgc.h"
@ -43,29 +43,30 @@ void mzrt_set_user_break_handler(void (*user_break_handler)(int))
#endif #endif
} }
static void segfault_handler(int signal_num) { static void rungdb() {
#ifdef WIN32 #ifdef WIN32
#else #else
pid_t pid = getpid(); pid_t pid = getpid();
char buffer[500]; char outbuffer[100];
char buf[500]; char inbuffer[10];
signal(SIGSEGV, segfault_handler);
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); fflush(stderr);
while(read(fileno(stdin), buf, 100) <= 0){ while(1) {
if(errno != EINTR){ while(read(fileno(stdin), inbuffer, 10) <= 0){
fprintf(stderr, "\nCould not read response, sleeping for 20 seconds.\n"); if(errno != EINTR){
fprintf(stderr, "Error detected %i\n", errno);
}
} }
switch(buf[0]) { switch(inbuffer[0]) {
case 'r': case 'r':
return; return;
break; break;
case 'd': case 'd':
snprintf(buffer, 500, "xterm -e gdb ./mzschemecgc %d &", pid); snprintf(outbuffer, 100, "xterm -e gdb ./mzscheme3m %d &", pid);
fprintf(stderr, "%i %i Launching GDB", signal_num, pid); fprintf(stderr, "%s\n", outbuffer);
system(buffer); system(outbuffer);
break; break;
case 'e': case 'e':
default: default:
@ -76,6 +77,13 @@ static void segfault_handler(int signal_num) {
#endif #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() void mzrt_set_segfault_debug_handler()
{ {
#ifdef WIN32 #ifdef WIN32
@ -138,42 +146,64 @@ MZ_INLINE uint32_t mzrt_atomic_incr_32(volatile unsigned int *counter) {
/***********************************************************************/ /***********************************************************************/
/* Threads */ /* 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 { void *mzrt_thread_stub(void *data){
#ifdef WIN32 mzrt_thread_stub_data *stub_data = (mzrt_thread_stub_data*) data;
HANDLE threadid; void * (*start_proc)(void *) = stub_data->start_proc;
#else void *start_proc_data = stub_data->data;
pthread_t threadid; proc_thread_self = stub_data->thread;
#endif
};
int mz_proc_thread_self() { free(data);
return start_proc(start_proc_data);
}
unsigned int mz_proc_thread_self() {
#ifdef WIN32 #ifdef WIN32
#error !!!mz_proc_thread_id not implemented!!! #error !!!mz_proc_thread_id not implemented!!!
#else #else
return (int) pthread_self(); return (unsigned int) pthread_self();
#endif #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* mz_proc_thread_create(mz_proc_thread_start start_proc, void* data) {
mz_proc_thread *thread = (mz_proc_thread*)malloc(sizeof(mz_proc_thread)); mz_proc_thread *thread = (mz_proc_thread*)malloc(sizeof(mz_proc_thread));
#ifdef WIN32 #ifdef MZ_PRECISE_GC
# ifndef 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); thread->threadid = CreateThread(NULL, 0, start_proc, data, 0, NULL);
# else # else
thread->threadid = CreateThread(NULL, 0, start_proc, data, 0, NULL); pthread_create(&thread->threadid, NULL, mzrt_thread_stub, stub_data);
# endif # endif
#else #else
# ifndef MZ_PRECISE_GC # ifdef WIN32
GC_pthread_create(&thread->threadid, NULL, start_proc, data); thread->threadid = GC_CreateThread(NULL, 0, start_proc, data, 0, NULL);
# else # else
pthread_create(&thread->threadid, NULL, start_proc, data); GC_pthread_create(&thread->threadid, NULL, start_proc, data);
# endif # endif
#endif #endif
return thread; return thread;
@ -245,7 +275,7 @@ struct mzrt_mutex {
}; };
int mzrt_mutex_create(mzrt_mutex **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); return pthread_mutex_init(&(*mutex)->mutex, NULL);
} }
@ -265,6 +295,91 @@ int mzrt_mutex_destroy(mzrt_mutex *mutex) {
return pthread_mutex_destroy(&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 #ifdef MZ_XFORM
END_XFORM_SUSPEND; END_XFORM_SUSPEND;
@ -410,6 +525,35 @@ int mzrt_mutex_destroy(mzrt_mutex *mutex) {
return 0; 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 #ifdef MZ_XFORM
END_XFORM_SUSPEND; END_XFORM_SUSPEND;
#endif #endif

46
src/mzscheme/src/mzrt.h
View File

@ -23,7 +23,15 @@ void mzrt_set_user_break_handler(void (*user_break_handler)(int));
/****************** PROCESS WEIGHT THREADS ********************************/ /****************** PROCESS WEIGHT THREADS ********************************/
/* mzrt_threads.c */ /* 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 #ifdef WIN32
typedef DWORD (WINAPI *mz_proc_thread_start)(void*); 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*); typedef void *(mz_proc_thread_start)(void*);
#endif #endif
mz_proc_thread* mzrt_proc_first_thread_init();
mz_proc_thread* mz_proc_thread_create(mz_proc_thread_start*, void* data); mz_proc_thread* mz_proc_thread_create(mz_proc_thread_start*, void* data);
void *mz_proc_thread_wait(mz_proc_thread *thread); void *mz_proc_thread_wait(mz_proc_thread *thread);
void mzrt_sleep(int seconds); void mzrt_sleep(int seconds);
int mz_proc_thread_self(); unsigned int mz_proc_thread_self();
int mz_proc_thread_id(mz_proc_thread* thread); unsigned int mz_proc_thread_id(mz_proc_thread* thread);
/****************** THREAD RWLOCK ******************************************/ /****************** THREAD RWLOCK ******************************************/
/* mzrt_rwlock_*.c */ /* mzrt_rwlock_*.c */
@ -58,6 +67,37 @@ int mzrt_mutex_trylock(mzrt_mutex *mutex);
int mzrt_mutex_unlock(mzrt_mutex *mutex); int mzrt_mutex_unlock(mzrt_mutex *mutex);
int mzrt_mutex_destroy(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 #endif

123
src/mzscheme/src/places.c
View File

@ -1,10 +1,17 @@
#include "schpriv.h" #include "schpriv.h"
/* READ ONLY SHARABLE GLOBALS */
static Scheme_Object *place_main_symbol;
#ifdef MZ_USE_PLACES #ifdef MZ_USE_PLACES
#include "mzrt.h" #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[]); 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_wait(int argc, Scheme_Object *args[]);
static Scheme_Object *scheme_place_sleep(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(); register_traversers();
#endif #endif
place_main_symbol = scheme_intern_symbol("place-main");
plenv = scheme_primitive_module(scheme_intern_symbol("#%place"), env); 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-sleep", scheme_place_sleep, 1, 1, plenv);
PLACE_PRIM_W_ARITY("place-wait", scheme_place_wait, 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); 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 /* FIXME this struct probably will need to be garbage collected as stuff
* is added to it */ * is added to it */
typedef struct Place_Start_Data { typedef struct Place_Start_Data {
int argc;
Scheme_Object *thunk; Scheme_Object *thunk;
Scheme_Object *module;
Scheme_Object *channel;
Scheme_Object *current_library_collection_paths; Scheme_Object *current_library_collection_paths;
} Place_Start_Data; } Place_Start_Data;
@ -98,7 +109,17 @@ Scheme_Object *scheme_place(int argc, Scheme_Object *args[]) {
/* pass critical info to new place */ /* pass critical info to new place */
place_data = MALLOC_ONE(Place_Start_Data); 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); collection_paths = scheme_current_library_collection_paths(0, NULL);
place_data->current_library_collection_paths = collection_paths; 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_Object *a[1];
Scheme_Thread * volatile p; Scheme_Thread * volatile p;
mz_jmp_buf * volatile saved_error_buf; 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"); nsreq = scheme_builtin_value("namespace-require");
a[0] = scheme_make_pair(scheme_intern_symbol("lib"), 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; 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) { static void *place_start_proc(void *data_arg) {
void *stack_base; void *stack_base;
Scheme_Object *thunk; Scheme_Object *thunk;
Place_Start_Data *place_data; Place_Start_Data *place_data;
Scheme_Object *a[1]; Scheme_Object *a[2];
int ptid; int ptid;
ptid = mz_proc_thread_self(); ptid = mz_proc_thread_self();
@ -165,21 +216,75 @@ static void *place_start_proc(void *data_arg) {
null_out_runtime_globals(); null_out_runtime_globals();
/* scheme_make_thread behaves differently if the above global vars are not null */ /* 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); scheme_place_instance_init(stack_base);
a[0] = place_data->current_library_collection_paths; a[0] = place_data->current_library_collection_paths;
scheme_current_library_collection_paths(1, a); 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); a[0] = scheme_places_deep_copy(place_data->channel);
scheme_apply(place_main, 1, a);
stack_base = NULL; }
return scheme_true; 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 */ /* precise GC traversers */

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

@ -1040,7 +1040,7 @@ static void do_next_finalization(void *o, void *data)
/* Makes gc2 xformer happy: */ /* Makes gc2 xformer happy: */
typedef void (*finalizer_function)(void *p, void *data); typedef void (*finalizer_function)(void *p, void *data);
static int traversers_registered; 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, static void add_finalizer(void *v, void (*f)(void*,void*), void *data,
int prim, int ext, int prim, int ext,

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

@ -166,6 +166,7 @@ void scheme_init_type(Scheme_Env *env);
void scheme_init_list(Scheme_Env *env); void scheme_init_list(Scheme_Env *env);
void scheme_init_stx(Scheme_Env *env); void scheme_init_stx(Scheme_Env *env);
void scheme_init_module(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(Scheme_Env *env);
void scheme_init_port_fun(Scheme_Env *env); void scheme_init_port_fun(Scheme_Env *env);
void scheme_init_network(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_jumping_to_continuation (scheme_current_thread->cjs.jumping_to_continuation)
#define scheme_multiple_count (scheme_current_thread->ku.multiple.count) #define scheme_multiple_count (scheme_current_thread->ku.multiple.count)
#define scheme_multiple_array (scheme_current_thread->ku.multiple.array) #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 #endif
typedef struct Scheme_Thread_Set { typedef struct Scheme_Thread_Set {
@ -2557,6 +2561,10 @@ typedef struct Scheme_Module
Scheme_Object **indirect_provides; /* symbols (internal names) */ Scheme_Object **indirect_provides; /* symbols (internal names) */
int num_indirect_provides; 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 */ char *et_provide_protects; /* 1 => protected, 0 => not */
Scheme_Object **et_indirect_provides; /* symbols (internal names) */ Scheme_Object **et_indirect_provides; /* symbols (internal names) */
int num_indirect_et_provides; int num_indirect_et_provides;
@ -2683,6 +2691,7 @@ Scheme_Object *scheme_modidx_shift(Scheme_Object *modidx,
Scheme_Object *shift_to_modidx); Scheme_Object *shift_to_modidx);
Scheme_Object *scheme_intern_resolved_module_path(Scheme_Object *o); 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 *scheme_hash_module_variable(Scheme_Env *env, Scheme_Object *modidx,
Scheme_Object *stxsym, Scheme_Object *insp, 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); 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_intern_exact_parallel_symbol(const char *name, unsigned int len);
Scheme_Object *scheme_symbol_append(Scheme_Object *s1, Scheme_Object *s2); Scheme_Object *scheme_symbol_append(Scheme_Object *s1, Scheme_Object *s2);
Scheme_Object *scheme_copy_list(Scheme_Object *l); Scheme_Object *scheme_copy_list(Scheme_Object *l);
@ -3111,13 +3121,23 @@ Scheme_Object *scheme_current_library_collection_paths(int argc, Scheme_Object *
/* places */ /* 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 { typedef struct Scheme_Place {
Scheme_Object so; Scheme_Object so;
void *proc_thread; void *proc_thread;
} Scheme_Place; } Scheme_Place;
Scheme_Env *scheme_place_instance_init(); Scheme_Env *scheme_place_instance_init();
void spawn_master_scheme_place();
Scheme_Object *scheme_places_deep_copy(Scheme_Object *so);
/*========================================================================*/ /*========================================================================*/
/* engine */ /* engine */

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

@ -13,12 +13,12 @@
consistently.) consistently.)
*/ */
#define MZSCHEME_VERSION "4.1.3.4" #define MZSCHEME_VERSION "4.1.3.5"
#define MZSCHEME_VERSION_X 4 #define MZSCHEME_VERSION_X 4
#define MZSCHEME_VERSION_Y 1 #define MZSCHEME_VERSION_Y 1
#define MZSCHEME_VERSION_Z 3 #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_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

23
src/mzscheme/src/symbol.c
View File

@ -369,7 +369,7 @@ scheme_make_exact_char_symbol(const mzchar *name, unsigned int len)
} }
Scheme_Object * 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; Scheme_Object *sym;
@ -392,6 +392,27 @@ scheme_intern_exact_symbol_in_table(Scheme_Hash_Table *symbol_table, int kind, c
return sym; 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_Object *
scheme_intern_exact_symbol(const char *name, unsigned int len) scheme_intern_exact_symbol(const char *name, unsigned int len)
{ {

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

@ -2147,7 +2147,7 @@ static Scheme_Thread *make_thread(Scheme_Config *config,
scheme_fuel_counter_ptr = &scheme_fuel_counter; scheme_fuel_counter_ptr = &scheme_fuel_counter;
#endif #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); GC_set_get_thread_stack_base(scheme_get_current_thread_stack_start);
#endif #endif
process->stack_start = stack_base; process->stack_start = stack_base;

2
src/mzscheme/src/type.c
View File

@ -51,7 +51,7 @@ static void init_type_arrays()
REGISTER_SO(scheme_type_hash2s); REGISTER_SO(scheme_type_hash2s);
maxtype = _scheme_last_type_; maxtype = _scheme_last_type_;
allocmax = maxtype + 10; allocmax = maxtype + 100;
type_names = MALLOC_N(char *, allocmax); type_names = MALLOC_N(char *, allocmax);
scheme_type_readers = MALLOC_N_ATOMIC(Scheme_Type_Reader, allocmax); scheme_type_readers = MALLOC_N_ATOMIC(Scheme_Type_Reader, allocmax);

2
src/worksp/mred/mred.manifest
View File

@ -1,7 +1,7 @@
<?xml version="1.0" encoding="UTF-8" standalone="yes"?> <?xml version="1.0" encoding="UTF-8" standalone="yes"?>
<assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0"> <assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0">
<assemblyIdentity <assemblyIdentity
version="4.1.3.4" version="4.1.3.5"
processorArchitecture="X86" processorArchitecture="X86"
name="Org.PLT-Scheme.MrEd" name="Org.PLT-Scheme.MrEd"
type="win32" type="win32"

8
src/worksp/mred/mred.rc
View File

@ -20,8 +20,8 @@ APPLICATION ICON DISCARDABLE "mred.ico"
// //
VS_VERSION_INFO VERSIONINFO VS_VERSION_INFO VERSIONINFO
FILEVERSION 4,1,3,4 FILEVERSION 4,1,3,5
PRODUCTVERSION 4,1,3,4 PRODUCTVERSION 4,1,3,5
FILEFLAGSMASK 0x3fL FILEFLAGSMASK 0x3fL
#ifdef _DEBUG #ifdef _DEBUG
FILEFLAGS 0x1L FILEFLAGS 0x1L
@ -39,11 +39,11 @@ BEGIN
VALUE "CompanyName", "PLT Scheme Inc.\0" VALUE "CompanyName", "PLT Scheme Inc.\0"
VALUE "FileDescription", "PLT Scheme GUI application\0" VALUE "FileDescription", "PLT Scheme GUI application\0"
VALUE "InternalName", "MrEd\0" VALUE "InternalName", "MrEd\0"
VALUE "FileVersion", "4, 1, 3, 4\0" VALUE "FileVersion", "4, 1, 3, 5\0"
VALUE "LegalCopyright", "Copyright © 1995-2008\0" VALUE "LegalCopyright", "Copyright © 1995-2008\0"
VALUE "OriginalFilename", "MrEd.exe\0" VALUE "OriginalFilename", "MrEd.exe\0"
VALUE "ProductName", "PLT Scheme\0" VALUE "ProductName", "PLT Scheme\0"
VALUE "ProductVersion", "4, 1, 3, 4\0" VALUE "ProductVersion", "4, 1, 3, 5\0"
END END
END END
BLOCK "VarFileInfo" BLOCK "VarFileInfo"

8
src/worksp/mzcom/mzcom.rc
View File

@ -53,8 +53,8 @@ END
// //
VS_VERSION_INFO VERSIONINFO VS_VERSION_INFO VERSIONINFO
FILEVERSION 4,1,3,4 FILEVERSION 4,1,3,5
PRODUCTVERSION 4,1,3,4 PRODUCTVERSION 4,1,3,5
FILEFLAGSMASK 0x3fL FILEFLAGSMASK 0x3fL
#ifdef _DEBUG #ifdef _DEBUG
FILEFLAGS 0x1L FILEFLAGS 0x1L
@ -70,12 +70,12 @@ BEGIN
BLOCK "040904b0" BLOCK "040904b0"
BEGIN BEGIN
VALUE "FileDescription", "MzCOM Module" VALUE "FileDescription", "MzCOM Module"
VALUE "FileVersion", "4, 1, 3, 4" VALUE "FileVersion", "4, 1, 3, 5"
VALUE "InternalName", "MzCOM" VALUE "InternalName", "MzCOM"
VALUE "LegalCopyright", "Copyright 2000-2008 PLT (Paul Steckler)" VALUE "LegalCopyright", "Copyright 2000-2008 PLT (Paul Steckler)"
VALUE "OriginalFilename", "MzCOM.EXE" VALUE "OriginalFilename", "MzCOM.EXE"
VALUE "ProductName", "MzCOM Module" VALUE "ProductName", "MzCOM Module"
VALUE "ProductVersion", "4, 1, 3, 4" VALUE "ProductVersion", "4, 1, 3, 5"
END END
END END
BLOCK "VarFileInfo" BLOCK "VarFileInfo"

6
src/worksp/mzcom/mzobj.rgs
View File

@ -1,19 +1,19 @@
HKCR HKCR
{ {
MzCOM.MzObj.4.1.3.4 = s 'MzObj Class' MzCOM.MzObj.4.1.3.5 = s 'MzObj Class'
{ {
CLSID = s '{A3B0AF9E-2AB0-11D4-B6D2-0060089002FE}' CLSID = s '{A3B0AF9E-2AB0-11D4-B6D2-0060089002FE}'
} }
MzCOM.MzObj = s 'MzObj Class' MzCOM.MzObj = s 'MzObj Class'
{ {
CLSID = s '{A3B0AF9E-2AB0-11D4-B6D2-0060089002FE}' CLSID = s '{A3B0AF9E-2AB0-11D4-B6D2-0060089002FE}'
CurVer = s 'MzCOM.MzObj.4.1.3.4' CurVer = s 'MzCOM.MzObj.4.1.3.5'
} }
NoRemove CLSID NoRemove CLSID
{ {
ForceRemove {A3B0AF9E-2AB0-11D4-B6D2-0060089002FE} = s 'MzObj Class' ForceRemove {A3B0AF9E-2AB0-11D4-B6D2-0060089002FE} = s 'MzObj Class'
{ {
ProgID = s 'MzCOM.MzObj.4.1.3.4' ProgID = s 'MzCOM.MzObj.4.1.3.5'
VersionIndependentProgID = s 'MzCOM.MzObj' VersionIndependentProgID = s 'MzCOM.MzObj'
ForceRemove 'Programmable' ForceRemove 'Programmable'
LocalServer32 = s '%MODULE%' LocalServer32 = s '%MODULE%'

8
src/worksp/mzscheme/mzscheme.rc
View File

@ -29,8 +29,8 @@ APPLICATION ICON DISCARDABLE "mzscheme.ico"
// //
VS_VERSION_INFO VERSIONINFO VS_VERSION_INFO VERSIONINFO
FILEVERSION 4,1,3,4 FILEVERSION 4,1,3,5
PRODUCTVERSION 4,1,3,4 PRODUCTVERSION 4,1,3,5
FILEFLAGSMASK 0x3fL FILEFLAGSMASK 0x3fL
#ifdef _DEBUG #ifdef _DEBUG
FILEFLAGS 0x1L FILEFLAGS 0x1L
@ -48,11 +48,11 @@ BEGIN
VALUE "CompanyName", "PLT Scheme Inc.\0" VALUE "CompanyName", "PLT Scheme Inc.\0"
VALUE "FileDescription", "PLT Scheme application\0" VALUE "FileDescription", "PLT Scheme application\0"
VALUE "InternalName", "MzScheme\0" VALUE "InternalName", "MzScheme\0"
VALUE "FileVersion", "4, 1, 3, 4\0" VALUE "FileVersion", "4, 1, 3, 5\0"
VALUE "LegalCopyright", "Copyright <20>© 1995-2008\0" VALUE "LegalCopyright", "Copyright <20>© 1995-2008\0"
VALUE "OriginalFilename", "mzscheme.exe\0" VALUE "OriginalFilename", "mzscheme.exe\0"
VALUE "ProductName", "PLT Scheme\0" VALUE "ProductName", "PLT Scheme\0"
VALUE "ProductVersion", "4, 1, 3, 4\0" VALUE "ProductVersion", "4, 1, 3, 5\0"
END END
END END
BLOCK "VarFileInfo" BLOCK "VarFileInfo"

8
src/worksp/starters/start.rc
View File

@ -22,8 +22,8 @@ APPLICATION ICON DISCARDABLE "mzstart.ico"
// //
VS_VERSION_INFO VERSIONINFO VS_VERSION_INFO VERSIONINFO
FILEVERSION 4,1,3,4 FILEVERSION 4,1,3,5
PRODUCTVERSION 4,1,3,4 PRODUCTVERSION 4,1,3,5
FILEFLAGSMASK 0x3fL FILEFLAGSMASK 0x3fL
#ifdef _DEBUG #ifdef _DEBUG
FILEFLAGS 0x1L FILEFLAGS 0x1L
@ -45,7 +45,7 @@ BEGIN
#ifdef MZSTART #ifdef MZSTART
VALUE "FileDescription", "PLT Scheme Launcher\0" VALUE "FileDescription", "PLT Scheme Launcher\0"
#endif #endif
VALUE "FileVersion", "4, 1, 3, 4\0" VALUE "FileVersion", "4, 1, 3, 5\0"
#ifdef MRSTART #ifdef MRSTART
VALUE "InternalName", "mrstart\0" VALUE "InternalName", "mrstart\0"
#endif #endif
@ -60,7 +60,7 @@ BEGIN
VALUE "OriginalFilename", "MzStart.exe\0" VALUE "OriginalFilename", "MzStart.exe\0"
#endif #endif
VALUE "ProductName", "PLT Scheme\0" VALUE "ProductName", "PLT Scheme\0"
VALUE "ProductVersion", "4, 1, 3, 4\0" VALUE "ProductVersion", "4, 1, 3, 5\0"
END END
END END
BLOCK "VarFileInfo" BLOCK "VarFileInfo"