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

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

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

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

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

@ -41,6 +41,8 @@
`(module ,modname ,spec
,@(map (λ (x) `(require ,x))
(lookup 'teachpacks table))
,@(parameterize ([read-case-sensitive (lookup 'read-case-sensitive table)])
,@(parameterize ([read-case-sensitive (lookup 'read-case-sensitive table)]
[read-decimal-as-inexact #f]
[read-accept-dot #f])
(get-all-exps source-name port))))))])
read-syntax)))

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

1
collects/scribble/eval.ss
View File

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

4
collects/scribble/reader.ss
View File

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

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

@ -176,8 +176,11 @@ environment:
@item{The evaluator works under the @scheme[sandbox-security-guard],
which restricts file system and network access.}
@item{Each evaluation is wrapped in a @scheme[call-with-limits]; see
also @scheme[sandbox-eval-limits] and @scheme[set-eval-limits].}
@item{The evaluator is contained in a memory-restricted environment,
and each evaluation is wrapped in a @scheme[call-with-limits]
(when memory accounting is available); see also
@scheme[sandbox-memory-limit], @scheme[sandbox-eval-limits] and
@scheme[set-eval-limits].}
]
Note that these limits apply to the creation of the sandbox
environment too --- so, for example, if the memory that is required to
@ -466,6 +469,15 @@ default @scheme[sandbox-security-guard]. The default forbids all
network connection.}
@defparam[sandbox-memory-limit limit (or/c exact-nonnegative-integer? #f)]{
A parameter that determines the total memory limit on the sandbox.
When this limit is exceeded, the sandbox is terminated. This value is
used when the sandbox is created and the limit cannot be changed
afterwards. See @scheme[sandbox-eval-limits] for per-evaluation
limits and a description of how the two limits work together.}
@defparam[sandbox-eval-limits limits
(or/c (list/c (or/c exact-nonnegative-integer? #f)
(or/c exact-nonnegative-integer? #f))
@ -473,12 +485,13 @@ network connection.}
A parameter that determines the default limits on @italic{each} use of
a @scheme[make-evaluator] function, including the initial evaluation
of the input program. Its value should be a list of two numbers, the
first is a timeout value in seconds, and the second is a memory limit
in megabytes. Either one can be @scheme[#f] for disabling the
corresponding limit; alternately, the parameter can be set to
@scheme[#f] to disable all limits (useful in case more limit kinds are
available in future versions). The default is @scheme[(list 30 20)].
of the input program. Its value should be a list of two numbers;
where the first is a timeout value in seconds, and the second is a
memory limit in megabytes. Either one can be @scheme[#f] for
disabling the corresponding limit; alternately, the parameter can be
set to @scheme[#f] to disable all per-evaluation limits (useful in
case more limit kinds are available in future versions). The default
is @scheme[(list 30 20)].
Note that these limits apply to the creation of the sandbox
environment too --- even @scheme[(make-evaluator 'scheme/base)] can
@ -488,7 +501,45 @@ you need to catch errors that happen when the sandbox is created.
When limits are set, @scheme[call-with-limits] (see below) is wrapped
around each use of the evaluator, so consuming too much time or memory
results in an exception. Change the limits of a running evaluator
using @scheme[set-eval-limits].}
using @scheme[set-eval-limits].
@margin-note{A custodian's limit is checked only after a garbage
collection, except that it may also be checked during
certain large allocations that are individually larger
than the custodian's limit.}
The memory limit that is specified by this parameter applies to each
individual evaluation, but not to the whole sandbox --- that limit is
specified via @scheme[sandbox-memory-limit]. When the global limit is
exceeded, the sandbox is terminated, but when the per-evaluation limit
is exceeded the @exnraise[exn:fail:resource]. For example, say that
you evaluate an expression like
@schemeblock[
(for ([i (in-range 1000)])
(set! a (cons (make-bytes 1000000) a))
(collect-garbage))
]
then, assuming sufficiently small limits,
@itemize[
@item{if a global limit is set but no per-evaluation limit, the
sandbox will eventually be terminated and no further
evaluations possible;}
@item{if there is a per-evaluation limit, but no global limit, the
evaluation will abort with an error and it can be used again
--- specifically, @scheme[a] will still hold a number of
blocks, and you can evaluate the same expression again which
will add more blocks to it;}
@item{if both limits are set, with the global one larger than the
per-evaluation limit, then the evaluation will abort and you
will be able to repeat it, but doing so several times will
eventually terminate the sandbox (this will be indicated by
the error message, and by the @scheme[evaluator-alive?]
predicate).}
]}
@defparam[sandbox-make-inspector make (-> inspector?)]{
@ -510,6 +561,12 @@ evaluator, and the default parameter value is @scheme[current-logger].}
The following functions are used to interact with a sandboxed
evaluator in addition to using it to evaluate code.
@defproc[(evaluator-alive? [evaluator (any/c . -> . any)]) boolean?]{
Determines whether the evaluator is still alive.}
@defproc[(kill-evaluator [evaluator (any/c . -> . any)]) void?]{
Releases the resources that are held by @scheme[evaluator] by shutting

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

@ -7,8 +7,14 @@
;; test call-in-nested-thread*
(let ()
(define (kill) (kill-thread (current-thread)))
(define (shut) (custodian-shutdown-all (current-custodian)))
(define-syntax-rule (nested body ...)
(call-in-nested-thread* (lambda () body ...)))
(define-syntax-rule (nested* body ...)
(call-in-nested-thread* (lambda () body ...)
(lambda () 'kill)
(lambda () 'shut)))
(test 1 values (nested 1))
;; propagates parameters
(let ([p (make-parameter #f)])
@ -19,13 +25,15 @@
;; propagates kill-thread
(test (void) thread-wait
(thread (lambda ()
(nested (kill-thread (current-thread)))
(nested (kill))
;; never reach here
(semaphore-wait (make-semaphore 0)))))
;; propagates custodian-shutdown-all
(test (void) values
(parameterize ([current-custodian (make-custodian)])
(nested (custodian-shutdown-all (current-custodian))))))
(parameterize ([current-custodian (make-custodian)]) (nested (shut))))
;; test handlers parameters
(test 'kill (lambda () (nested* (kill))))
(test 'shut (lambda () (nested* (shut)))))
(let ([ev void])
(define (run thunk)
@ -362,31 +370,33 @@
--top--
(set! ev (parameterize ([sandbox-output 'bytes]
[sandbox-error-output current-output-port]
[sandbox-memory-limit 5]
[sandbox-eval-limits '(0.25 1/2)])
(make-evaluator 'scheme/base)))
;; GCing is needed to allow these to happen
--eval-- (display (make-bytes 400000 65))
--eval-- (display (make-bytes 400000 65)) (collect-garbage)
--top-- (bytes-length (get-output ev)) => 400000
--eval-- (display (make-bytes 400000 65))
--eval-- (display (make-bytes 400000 65)) (collect-garbage)
--top-- (bytes-length (get-output ev)) => 400000
--eval-- (display (make-bytes 400000 65))
--eval-- (display (make-bytes 400000 65)) (collect-garbage)
--top-- (bytes-length (get-output ev)) => 400000
--eval-- (display (make-bytes 400000 65))
--eval-- (display (make-bytes 400000 65)) (collect-garbage)
--top-- (bytes-length (get-output ev)) => 400000
--eval-- (display (make-bytes 400000 65))
--eval-- (display (make-bytes 400000 65)) (collect-garbage)
--top-- (bytes-length (get-output ev)) => 400000
--eval-- (display (make-bytes 400000 65)) (collect-garbage)
--top-- (bytes-length (get-output ev)) => 400000
--eval-- (display (make-bytes 400000 65)) (collect-garbage)
--top-- (bytes-length (get-output ev)) => 400000
--eval-- (display (make-bytes 400000 65)) (collect-garbage)
--top-- (bytes-length (get-output ev)) => 400000
--eval-- (display (make-bytes 400000 65)) (collect-garbage)
--top-- (bytes-length (get-output ev)) => 400000
--eval-- (display (make-bytes 400000 65)) (collect-garbage)
--top-- (bytes-length (get-output ev)) => 400000
;; EB: for some reason, the first thing doesn't throw an error, and I think
;; that the second should break much sooner than 100 iterations
;; --eval-- (let ([400k (make-bytes 400000 65)])
;; (for ([i (in-range 2)]) (display 400k)))
;; --top-- (bytes-length (get-output ev))
;; =err> "out of memory"
;; --eval-- (let ([400k (make-bytes 400000 65)])
;; (for ([i (in-range 100)]) (display 400k)))
;; =err> "out of memory"
;; test that killing the custodian works fine
;; first try it without limits (which imply a nester thread/custodian)
;; first try it without limits (limits imply a nested thread/custodian)
--top--
(set! ev (parameterize ([sandbox-eval-limits #f])
(make-evaluator 'scheme/base)))
@ -426,6 +436,20 @@
(lambda () (custodian-shutdown-all (current-custodian))))
=err> "terminated"
;; when an expression is out of memory, the sandbox should stay alive
--top--
(set! ev (parameterize ([sandbox-eval-limits '(2 5)]
[sandbox-memory-limit 100])
(make-evaluator 'scheme/base)))
--eval--
(define a '())
(define b 1)
(for ([i (in-range 20)])
(set! a (cons (make-bytes 500000) a))
(collect-garbage))
=err> "out of memory"
b => 1
))
(report-errs)

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

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

4
src/mzscheme/Makefile.in
View File

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

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

@ -30,9 +30,6 @@ XSRCDIR = xsrc
XFORM = env XFORM_USE_PRECOMP=$(XSRCDIR)/precomp.h $(XFORM_NOPRECOMP)
SRCDIR = $(srcdir)/../src
XFORM_COMPACT_GC_NOPRECOMP = $(XFORM_SETUP) --cpp "$(CPP) $(CPPFLAGS) -DUSE_COMPACT_3M_GC" @XFORMFLAGS@ -o
XFORM_COMPACT_GC = env XFORM_USE_PRECOMP=$(XSRCDIR)/precomp.h $(XFORM_COMPACT_GC_NOPRECOMP)
FOREIGN_USED_OBJ = foreign.@LTO@
FOREIGN_NOT_USED_OBJ =
@ -49,6 +46,7 @@ OBJS = salloc.@LTO@ \
file.@LTO@ \
fun.@LTO@ \
hash.@LTO@ \
jit.@LTO@ \
list.@LTO@ \
module.@LTO@ \
mzrt.@LTO@ \
@ -137,6 +135,15 @@ XFORMDEP = $(srcdir)/gc2.h $(srcdir)/xform.ss $(srcdir)/xform-mod.ss \
$(srcdir)/../sconfig.h $(srcdir)/../uconfig.h $(srcdir)/../src/schemef.h \
$(srcdir)/../src/stypes.h
LIGHTNINGDEP = $(srcdir)/../src/lightning/i386/core.h $(srcdir)/../src/lightning/i386/core-common.h \
$(srcdir)/../src/lightning/i386/asm.h $(srcdir)/../src/lightning/i386/asm-common.h \
$(srcdir)/../src/lightning/i386/fp.h $(srcdir)/../src/lightning/i386/fp-common.h \
$(srcdir)/../src/lightning/i386/funcs.h $(srcdir)/../src/lightning/i386/funcs-common.h \
$(srcdir)/../src/lightning/ppc/core.h $(srcdir)/../src/lightning/ppc/core-common.h \
$(srcdir)/../src/lightning/ppc/asm.h $(srcdir)/../src/lightning/ppc/asm-common.h \
$(srcdir)/../src/lightning/ppc/fp.h $(srcdir)/../src/lightning/ppc/fp-common.h \
$(srcdir)/../src/lightning/ppc/funcs.h $(srcdir)/../src/lightning/ppc/funcs-common.h
$(XSRCDIR)/precomp.h : $(XFORMDEP) $(srcdir)/../src/schvers.h
env XFORM_PRECOMP=yes $(XFORM_NOPRECOMP) $(XSRCDIR)/precomp.h $(srcdir)/precomp.c
@ -154,7 +161,7 @@ $(XSRCDIR)/complex.c: ../src/complex.@LTO@ $(XFORMDEP)
$(XFORM) $(XSRCDIR)/complex.c $(SRCDIR)/complex.c
$(XSRCDIR)/dynext.c: ../src/dynext.@LTO@ $(XFORMDEP)
$(XFORM) $(XSRCDIR)/dynext.c $(SRCDIR)/dynext.c
$(XSRCDIR)/env.c: ../src/env.@LTO@ $(XFORMDEP)
$(XSRCDIR)/env.c: ../src/env.@LTO@ $(XFORMDEP) $(SRCDIR)/mzrt.h
$(XFORM) $(XSRCDIR)/env.c $(SRCDIR)/env.c
$(XSRCDIR)/error.c: ../src/error.@LTO@ $(XFORMDEP)
$(XFORM) $(XSRCDIR)/error.c $(SRCDIR)/error.c
@ -166,9 +173,9 @@ $(XSRCDIR)/fun.c: ../src/fun.@LTO@ $(XFORMDEP)
$(XFORM) $(XSRCDIR)/fun.c $(SRCDIR)/fun.c
$(XSRCDIR)/hash.c: ../src/hash.@LTO@ $(XFORMDEP)
$(XFORM) $(XSRCDIR)/hash.c $(SRCDIR)/hash.c
$(XSRCDIR)/jit.c: ../src/jit.@LTO@ $(XFORMDEP)
$(XSRCDIR)/jit.c: ../src/jit.@LTO@ $(XFORMDEP) $(LIGHTNINGDEP)
$(XFORM) $(XSRCDIR)/jit.c $(SRCDIR)/jit.c
$(XSRCDIR)/module.c: ../src/module.@LTO@ $(XFORMDEP)
$(XSRCDIR)/module.c: ../src/module.@LTO@ $(XFORMDEP) $(SRCDIR)/mzrt.h
$(XFORM) $(XSRCDIR)/module.c $(SRCDIR)/module.c
$(XSRCDIR)/list.c: ../src/list.@LTO@ $(XFORMDEP)
$(XFORM) $(XSRCDIR)/list.c $(SRCDIR)/list.c
@ -182,7 +189,7 @@ $(XSRCDIR)/numcomp.c: ../src/numcomp.@LTO@ $(XFORMDEP)
$(XFORM) $(XSRCDIR)/numcomp.c $(SRCDIR)/numcomp.c
$(XSRCDIR)/numstr.c: ../src/numstr.@LTO@ $(XFORMDEP)
$(XFORM) $(XSRCDIR)/numstr.c $(SRCDIR)/numstr.c
$(XSRCDIR)/places.c: ../src/places.@LTO@ $(XFORMDEP)
$(XSRCDIR)/places.c: ../src/places.@LTO@ $(XFORMDEP) $(SRCDIR)/mzrt.h
$(XFORM) $(XSRCDIR)/places.c $(SRCDIR)/places.c
$(XSRCDIR)/port.c: ../src/port.@LTO@ $(XFORMDEP)
$(XFORM) $(XSRCDIR)/port.c $(SRCDIR)/port.c
@ -206,7 +213,7 @@ $(XSRCDIR)/struct.c: ../src/struct.@LTO@ $(XFORMDEP)
$(XFORM) $(XSRCDIR)/struct.c $(SRCDIR)/struct.c
$(XSRCDIR)/stxobj.c: ../src/stxobj.@LTO@ $(XFORMDEP)
$(XFORM) $(XSRCDIR)/stxobj.c $(SRCDIR)/stxobj.c
$(XSRCDIR)/symbol.c: ../src/symbol.@LTO@ $(XFORMDEP)
$(XSRCDIR)/symbol.c: ../src/symbol.@LTO@ $(XFORMDEP) $(SRCDIR)/mzrt.h
$(XFORM) $(XSRCDIR)/symbol.c $(SRCDIR)/symbol.c
$(XSRCDIR)/syntax.c: ../src/syntax.@LTO@ $(XFORMDEP)
$(XFORM) $(XSRCDIR)/syntax.c $(SRCDIR)/syntax.c
@ -221,9 +228,6 @@ $(XSRCDIR)/foreign.c: ../../foreign/foreign.@LTO@ $(XFORMDEP)
$(XSRCDIR)/main.c: ../main.@LTO@ $(XFORMDEP)
$(XFORM_NOPRECOMP) $(XSRCDIR)/main.c $(DEF_COLLECTS_DIR) $(srcdir)/../main.c
$(XSRCDIR)/jit_compact_gc.c: ../src/jit.@LTO@ $(XFORMDEP)
$(XFORM_COMPACT_GC) $(XSRCDIR)/jit_compact_gc.c $(SRCDIR)/jit.c
salloc.@LTO@: $(XSRCDIR)/salloc.c
$(CC) $(CFLAGS) -c $(XSRCDIR)/salloc.c -o salloc.@LTO@
bignum.@LTO@: $(XSRCDIR)/bignum.c
@ -252,13 +256,11 @@ hash.@LTO@: $(XSRCDIR)/hash.c
$(CC) $(CFLAGS) -c $(XSRCDIR)/hash.c -o hash.@LTO@
jit.@LTO@: $(XSRCDIR)/jit.c
$(CC) $(CFLAGS) -c $(XSRCDIR)/jit.c -o jit.@LTO@
jit_compact_gc.@LTO@: $(XSRCDIR)/jit_compact_gc.c
$(CC) $(CFLAGS) -c $(XSRCDIR)/jit_compact_gc.c -o jit_compact_gc.@LTO@
list.@LTO@: $(XSRCDIR)/list.c
$(CC) $(CFLAGS) -c $(XSRCDIR)/list.c -o list.@LTO@
module.@LTO@: $(XSRCDIR)/module.c
$(CC) $(CFLAGS) -c $(XSRCDIR)/module.c -o module.@LTO@
mzrt.@LTO@: $(SRCDIR)/mzrt.c
mzrt.@LTO@: $(SRCDIR)/mzrt.c $(SRCDIR)/mzrt.h
$(CC) $(CFLAGS) -DMZ_PRECISE_GC -c $(SRCDIR)/mzrt.c -o mzrt.@LTO@
network.@LTO@: $(XSRCDIR)/network.c
$(CC) $(CFLAGS) -c $(XSRCDIR)/network.c -o network.@LTO@
@ -311,6 +313,7 @@ main.@LTO@: $(XSRCDIR)/main.c
gc2.@LTO@: $(srcdir)/gc2.c $(srcdir)/newgc.c $(srcdir)/gc2.h \
$(srcdir)/newgc.h $(srcdir)/blame_the_child.c \
$(srcdir)/sighand.c \
$(srcdir)/vm_osx.c $(srcdir)/vm_mmap.c $(srcdir)/vm_osk.c $(srcdir)/vm.c\
$(srcdir)/vm_memalign.c $(srcdir)/alloc_cache.c \
$(srcdir)/page_range.c $(srcdir)/protect_range.c $(srcdir)/var_stack.c $(srcdir)/stack_comp.c \
@ -318,30 +321,6 @@ gc2.@LTO@: $(srcdir)/gc2.c $(srcdir)/newgc.c $(srcdir)/gc2.h \
$(srcdir)/weak.c $(srcdir)/fnls.c $(srcdir)/../include/scheme.h $(srcdir)/../src/schpriv.h
$(CC) $(CFLAGS) -I$(builddir)/.. -c $(srcdir)/gc2.c -o gc2.@LTO@
new_gc.@LTO@: $(srcdir)/newgc.c $(srcdir)/gc2.h \
$(srcdir)/vm_osx.c $(srcdir)/vm_mmap.c $(srcdir)/vm_osk.c $(srcdir)/vm.c\
$(srcdir)/vm_memalign.c $(srcdir)/alloc_cache.c \
$(srcdir)/page_range.c $(srcdir)/protect_range.c $(srcdir)/var_stack.c $(srcdir)/stack_comp.c \
$(srcdir)/../utils/splay.c $(srcdir)/my_qsort.c $(srcdir)/backtrace.c \
$(srcdir)/weak.c $(srcdir)/fnls.c $(srcdir)/../include/scheme.h $(srcdir)/../src/schpriv.h
$(CC) $(CFLAGS) -c $(srcdir)/newgc.c -o new_gc.@LTO@
copy_gc.@LTO@: $(srcdir)/copy.c $(srcdir)/gc2.h \
$(srcdir)/vm_osx.c $(srcdir)/vm_mmap.c $(srcdir)/vm_osk.c $(srcdir)/vm.c\
$(srcdir)/vm_memalign.c $(srcdir)/alloc_cache.c \
$(srcdir)/page_range.c $(srcdir)/protect_range.c $(srcdir)/var_stack.c $(srcdir)/stack_comp.c \
$(srcdir)/../utils/splay.c $(srcdir)/my_qsort.c $(srcdir)/backtrace.c \
$(srcdir)/weak.c $(srcdir)/fnls.c $(srcdir)/../include/scheme.h $(srcdir)/../src/schpriv.h
$(CC) $(CFLAGS) -c $(srcdir)/copy.c -o copy_gc.@LTO@
compact_gc.@LTO@: $(srcdir)/compact.c $(srcdir)/gc2.h \
$(srcdir)/vm_osx.c $(srcdir)/vm_mmap.c $(srcdir)/vm_osk.c $(srcdir)/vm.c\
$(srcdir)/vm_memalign.c $(srcdir)/alloc_cache.c \
$(srcdir)/page_range.c $(srcdir)/protect_range.c $(srcdir)/var_stack.c $(srcdir)/stack_comp.c \
$(srcdir)/../utils/splay.c $(srcdir)/my_qsort.c $(srcdir)/backtrace.c \
$(srcdir)/weak.c $(srcdir)/fnls.c $(srcdir)/../include/scheme.h $(srcdir)/../src/schpriv.h
$(CC) $(CFLAGS) -c $(srcdir)/compact.c -o compact_gc.@LTO@
FOREIGN_OBJS = ../../foreign/gcc/libffi/src/*.@LTO@ ../../foreign/gcc/libffi/src/*/*.@LTO@
FOREIGN_LIB = ../../foreign/gcc/libffi/libffi@FOREIGN_CONVENIENCE@.la
FOREIGN_OBJSLIB = @FOREIGN_OBJSLIB@
@ -354,20 +333,13 @@ FOREIGN_NOT_USED_OBJSLIB =
EXTRA_OBJS_T = ../src/gmp.@LTO@ ../src/unwind.@LTO@ $(@FOREIGN_IF_USED@_LIB)
EXTRA_OBJS_L = ../src/gmp.@LTO@ ../src/unwind.@LTO@ $(@FOREIGN_IF_USED@_OBJSLIB)
../libmzscheme3m.@LIBSFX@: $(OBJS) $(EXTRA_OBJS_T) jit.@LTO@ gc2.@LTO@
$(AR) $(ARFLAGS) ../libmzscheme3m.@LIBSFX@ $(OBJS) $(EXTRA_OBJS_L) jit.@LTO@ gc2.@LTO@
../libmzscheme3m.@LIBSFX@: $(OBJS) $(EXTRA_OBJS_T) gc2.@LTO@
$(AR) $(ARFLAGS) ../libmzscheme3m.@LIBSFX@ $(OBJS) $(EXTRA_OBJS_L) gc2.@LTO@
$(RANLIB) ../libmzscheme3m.@LIBSFX@
../libmzscheme_compact_gc.@LIBSFX@: $(OBJS) $(EXTRA_OBJS_T) jit_compact_gc.@LTO@ compact_gc.@LTO@
$(AR) $(ARFLAGS) ../libmzscheme_compact_gc.@LIBSFX@ $(OBJS) $(EXTRA_OBJS_L) jit_compact_gc.@LTO@ compact_gc.@LTO@
$(RANLIB) ../libmzscheme_compact_gc.@LIBSFX@
../mzscheme@MMM@@NOT_OSX@: main.@LTO@ ../libmzscheme3m.@LIBSFX@
cd ..; @MZLINKER@ -o mzscheme@MMM@ @PROFFLAGS@ gc2/main.@LTO@ libmzscheme3m.@LIBSFX@ @LDFLAGS@ $(LIBS)
../mzscheme_compact_gc@NOT_OSX@: main.@LTO@ ../libmzscheme_compact_gc.@LIBSFX@
cd ..; @MZLINKER@ -o mzscheme_compact_gc @PROFFLAGS@ gc2/main.@LTO@ libmzscheme_compact_gc.@LIBSFX@ @LDFLAGS@ $(LIBS)
# The above "cd .." prevents a problem with libtool's generated script in --enable-shared mode,
# at least for Mac OS X. Beware of changing LIBS or LDFLAGS to inclucde something with a relative
# path.
@ -386,9 +358,6 @@ $(MZFWMMM): ../libmzscheme3m.@LIBSFX@
cp "PLT_MzScheme.framework/Versions/$(FWVERSION)_3m/PLT_MzScheme" "../PLT_MzScheme.framework/Versions/$(FWVERSION)_3m/PLT_MzScheme"
/usr/bin/install_name_tool -change "PLT_MzScheme.framework/Versions/$(FWVERSION)_3m/PLT_MzScheme" "@executable_path/PLT_MzScheme.framework/Versions/$(FWVERSION)_3m/PLT_MzScheme" "../mzscheme@MMM@"
../mzscheme_compact_gc@OSX@:
echo "../mzscheme_compact_gc does not currently build on Mac OS X; use --enable-compact with configure, instead"
clean:
/bin/rm -f ../mzscheme@MMM@ *.@LTO@ $(XSRCDIR)/*
/bin/rm -rf xform-collects

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

@ -4,6 +4,13 @@
#ifdef NEWGC_BTC_ACCOUNT
#include "../src/schpriv.h"
/* BTC_ prefixed functions are called by newgc.c */
/* btc_ prefixed functions are internal to blame_the_child.c */
static const int btc_redirect_thread = 511;
static const int btc_redirect_custodian = 510;
static const int btc_redirect_ephemeron = 509;
static const int btc_redirect_cust_box = 508;
/*****************************************************************************/
/* thread list */
@ -36,11 +43,12 @@ inline static void BTC_register_thread(void *t, void *c)
inline static void mark_threads(NewGC *gc, int owner)
{
GC_Thread_Info *work;
Mark_Proc thread_mark = gc->mark_table[btc_redirect_thread];
for(work = gc->thread_infos; work; work = work->next)
if(work->owner == owner) {
if (((Scheme_Thread *)work->thread)->running) {
gc->normal_thread_mark(work->thread);
thread_mark(work->thread);
if (work->thread == scheme_current_thread) {
GC_mark_variable_stack(GC_variable_stack, 0, get_stack_base(gc), NULL);
}
@ -249,6 +257,7 @@ inline static void mark_cust_boxes(NewGC *gc, Scheme_Custodian *cur)
{
Scheme_Object *pr, *prev = NULL, *next;
GC_Weak_Box *wb;
Mark_Proc cust_box_mark = gc->mark_table[btc_redirect_cust_box];
/* cust boxes is a list of weak boxes to cust boxes */
@ -257,7 +266,7 @@ inline static void mark_cust_boxes(NewGC *gc, Scheme_Custodian *cur)
wb = (GC_Weak_Box *)SCHEME_CAR(pr);
next = SCHEME_CDR(pr);
if (wb->val) {
gc->normal_cust_box_mark(wb->val);
cust_box_mark(wb->val);
prev = pr;
} else {
if (prev)
@ -273,21 +282,32 @@ inline static void mark_cust_boxes(NewGC *gc, Scheme_Custodian *cur)
int BTC_thread_mark(void *p)
{
return ((struct objhead *)(NUM(p) - WORD_SIZE))->size;
NewGC *gc = GC_get_GC();
if (gc->doing_memory_accounting) {
return ((struct objhead *)(NUM(p) - WORD_SIZE))->size;
}
return gc->mark_table[btc_redirect_thread](p);
}
int BTC_custodian_mark(void *p)
{
NewGC *gc = GC_get_GC();
if(custodian_to_owner_set(gc, p) == gc->current_mark_owner)
return gc->normal_custodian_mark(p);
else
return ((struct objhead *)(NUM(p) - WORD_SIZE))->size;
if (gc->doing_memory_accounting) {
if(custodian_to_owner_set(gc, p) == gc->current_mark_owner)
return gc->mark_table[btc_redirect_custodian](p);
else
return ((struct objhead *)(NUM(p) - WORD_SIZE))->size;
}
return gc->mark_table[btc_redirect_custodian](p);
}
int BTC_cust_box_mark(void *p)
{
return ((struct objhead *)(NUM(p) - WORD_SIZE))->size;
NewGC *gc = GC_get_GC();
if (gc->doing_memory_accounting) {
return ((struct objhead *)(NUM(p) - WORD_SIZE))->size;
}
return gc->mark_table[btc_redirect_cust_box](p);
}
inline static void mark_normal_obj(NewGC *gc, mpage *page, void *ptr)
@ -375,6 +395,21 @@ static void propagate_accounting_marks(NewGC *gc)
reset_pointer_stack();
}
inline static void BTC_initialize_mark_table(NewGC *gc) {
gc->mark_table[scheme_thread_type] = BTC_thread_mark;
gc->mark_table[scheme_custodian_type] = BTC_custodian_mark;
gc->mark_table[gc->ephemeron_tag] = BTC_ephemeron_mark;
gc->mark_table[gc->cust_box_tag] = BTC_cust_box_mark;
}
inline static int BTC_get_redirect_tag(NewGC *gc, int tag) {
if (tag == scheme_thread_type ) { tag = btc_redirect_thread; }
else if (tag == scheme_custodian_type ) { tag = btc_redirect_custodian; }
else if (tag == gc->ephemeron_tag ) { tag = btc_redirect_ephemeron; }
else if (tag == gc->cust_box_tag ) { tag = btc_redirect_cust_box; }
return tag;
}
static void BTC_do_accounting(NewGC *gc)
{
const int table_size = gc->owner_table_size;
@ -390,17 +425,6 @@ static void BTC_do_accounting(NewGC *gc)
gc->in_unsafe_allocation_mode = 1;
gc->unsafe_allocation_abort = btc_overmem_abort;
if(!gc->normal_thread_mark) {
gc->normal_thread_mark = gc->mark_table[scheme_thread_type];
gc->normal_custodian_mark = gc->mark_table[scheme_custodian_type];
gc->normal_cust_box_mark = gc->mark_table[gc->cust_box_tag];
}
gc->mark_table[scheme_thread_type] = BTC_thread_mark;
gc->mark_table[scheme_custodian_type] = BTC_custodian_mark;
gc->mark_table[gc->ephemeron_tag] = BTC_ephemeron_mark;
gc->mark_table[gc->cust_box_tag] = BTC_cust_box_mark;
/* clear the memory use numbers out */
for(i = 1; i < table_size; i++)
if(owner_table[i])
@ -427,11 +451,6 @@ static void BTC_do_accounting(NewGC *gc)
box = cur->global_prev; cur = box ? SCHEME_PTR1_VAL(box) : NULL;
}
gc->mark_table[scheme_thread_type] = gc->normal_thread_mark;
gc->mark_table[scheme_custodian_type] = gc->normal_custodian_mark;
gc->mark_table[gc->ephemeron_tag] = mark_ephemeron;
gc->mark_table[gc->cust_box_tag] = gc->normal_cust_box_mark;
gc->in_unsafe_allocation_mode = 0;
gc->doing_memory_accounting = 0;
gc->old_btc_mark = gc->new_btc_mark;

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
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
};

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

@ -31,10 +31,12 @@
#include <stdlib.h>
#include <stdio.h>
#include <string.h>
#include <assert.h>
#include "platforms.h"
#include "gc2.h"
#include "gc2_dump.h"
/* the number of tags to use for tagged objects */
#define NUMBER_OF_TAGS 512
@ -73,9 +75,16 @@ static const char *type_name[PAGE_TYPES] = {
#include "newgc.h"
static NewGC *MASTERGC;
static THREAD_LOCAL NewGC *GC;
#define GCTYPE NewGC
#define GC_get_GC() (GC)
#define GC_set_GC(gc) (GC = gc)
inline static int is_master_gc(NewGC *gc) {
return (MASTERGC == gc);
}
#include "msgprint.c"
@ -260,10 +269,33 @@ int GC_mtrace_union_current_with(int newval)
/*****************************************************************************/
/* Page Map Routines */
/*****************************************************************************/
inline static void free_page_maps(PageMap page_maps1) {
#ifdef SIXTY_FOUR_BIT_INTEGERS
unsigned long i;
unsigned long j;
mpage ***page_maps2;
mpage **page_maps3;
for (i=0; 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
fairly fast lookup. this is useful. */
inline static void pagemap_set(PageMap page_maps1, void *p, mpage *value) {
#ifdef SIXTY_FOUR_BIT_INTEGERS
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
the standard C stack because we'll blow it; propagation makes for a *very*
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_END(ms) ((void **)((char *)ms + STACK_PART_SIZE))
@ -1258,8 +1285,8 @@ inline static MarkSegment* mark_stack_create_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) {
mark_stack = mark_stack_create_frame();
mark_stack->prev = NULL;
@ -1381,9 +1408,8 @@ void GC_register_new_thread(void *t, void *c)
/* administration / initialization */
/*****************************************************************************/
static int designate_modified(void *p)
static int designate_modified_gc(NewGC *gc, void *p)
{
NewGC *gc = GC_get_GC();
struct mpage *page = pagemap_find_page(gc->page_maps, p);
if (gc->no_further_modifications) {
@ -1399,11 +1425,20 @@ static int designate_modified(void *p)
return 1;
}
} else {
if (gc->primoridal_gc) {
return designate_modified_gc(gc->primoridal_gc, p);
}
GCPRINT(GCOUTF, "Seg fault (internal error) at %p\n", p);
}
return 0;
}
static int designate_modified(void *p) {
NewGC *gc = GC_get_GC();
return designate_modified_gc(gc, p);
}
void GC_write_barrier(void *p)
{
(void)designate_modified(p);
@ -1411,23 +1446,76 @@ void GC_write_barrier(void *p)
#include "sighand.c"
void NewGC_initialize(NewGC *newgc) {
memset(newgc, 0, sizeof(NewGC));
newgc->mark_table = ofm_malloc_zero(NUMBER_OF_TAGS * sizeof (Mark_Proc));
newgc->fixup_table = ofm_malloc_zero(NUMBER_OF_TAGS * sizeof (Fixup_Proc));
void NewGC_initialize(NewGC *newgc, NewGC *parentgc) {
if (parentgc) {
newgc->mark_table = parentgc->mark_table;
newgc->fixup_table = parentgc->fixup_table;
}
else {
newgc->mark_table = ofm_malloc_zero(NUMBER_OF_TAGS * sizeof (Mark_Proc));
newgc->fixup_table = ofm_malloc_zero(NUMBER_OF_TAGS * sizeof (Fixup_Proc));
# ifdef NEWGC_BTC_ACCOUNT
BTC_initialize_mark_table(newgc);
#endif
}
mark_stack_initialize();
#ifdef SIXTY_FOUR_BIT_INTEGERS
newgc->page_maps = ofm_malloc_zero(PAGEMAP64_LEVEL1_SIZE * sizeof (mpage***));
#else
newgc->page_maps = ofm_malloc_zero(PAGEMAP32_SIZE * sizeof (mpage*));
#endif
newgc->vm = vm_create();
newgc->protect_range = ofm_malloc_zero(sizeof(Page_Range));
newgc->generations_available = 1;
newgc->last_full_mem_use = (20 * 1024 * 1024);
newgc->new_btc_mark = 1;
}
init_mark_stack();
/* NOTE This method sets the constructed GC as the new Thread Specific GC. */
static NewGC *init_type_tags_worker(NewGC *parentgc, int count, int pair, int mutable_pair, int weakbox, int ephemeron, int weakarray, int custbox)
{
NewGC *gc;
gc = ofm_malloc_zero(sizeof(NewGC));
/* NOTE sets the constructed GC as the new Thread Specific GC. */
GC_set_GC(gc);
gc->weak_box_tag = weakbox;
gc->ephemeron_tag = ephemeron;
gc->weak_array_tag = weakarray;
# ifdef NEWGC_BTC_ACCOUNT
gc->cust_box_tag = custbox;
# endif
NewGC_initialize(gc, parentgc);
/* Our best guess at what the OS will let us allocate: */
gc->max_pages_in_heap = determine_max_heap_size() / APAGE_SIZE;
/* Not all of that memory is available for allocating GCable
objects. There's the memory used by the stack, code,
malloc()/free()ed memory, etc., and there's also the
administrative structures for the GC itself. */
gc->max_pages_for_use = gc->max_pages_in_heap / 2;
resize_gen0(gc, GEN0_INITIAL_SIZE);
if (!parentgc) {
GC_register_traversers(gc->weak_box_tag, size_weak_box, mark_weak_box, fixup_weak_box, 0, 0);
GC_register_traversers(gc->ephemeron_tag, size_ephemeron, mark_ephemeron, fixup_ephemeron, 0, 0);
GC_register_traversers(gc->weak_array_tag, size_weak_array, mark_weak_array, fixup_weak_array, 0, 0);
}
initialize_signal_handler(gc);
GC_add_roots(&gc->park, (char *)&gc->park + sizeof(gc->park) + 1);
GC_add_roots(&gc->park_save, (char *)&gc->park_save + sizeof(gc->park_save) + 1);
initialize_protect_page_ranges(gc->protect_range, malloc_dirty_pages(gc, APAGE_SIZE, APAGE_SIZE), APAGE_SIZE);
return gc;
}
void GC_init_type_tags(int count, int pair, int mutable_pair, int weakbox, int ephemeron, int weakarray, int custbox)
@ -1435,45 +1523,56 @@ void GC_init_type_tags(int count, int pair, int mutable_pair, int weakbox, int e
static int initialized = 0;
if(!initialized) {
NewGC *gc;
initialized = 1;
gc = ofm_malloc(sizeof(NewGC));
GC = gc;
NewGC_initialize(gc);
gc->weak_box_tag = weakbox;
gc->ephemeron_tag = ephemeron;
gc->weak_array_tag = weakarray;
# ifdef NEWGC_BTC_ACCOUNT
gc->cust_box_tag = custbox;
# endif
/* Our best guess at what the OS will let us allocate: */
gc->max_pages_in_heap = determine_max_heap_size() / APAGE_SIZE;
/* Not all of that memory is available for allocating GCable
objects. There's the memory used by the stack, code,
malloc()/free()ed memory, etc., and there's also the
administrative structures for the GC itself. */
gc->max_pages_for_use = gc->max_pages_in_heap / 2;
resize_gen0(gc, GEN0_INITIAL_SIZE);
GC_register_traversers(gc->weak_box_tag, size_weak_box, mark_weak_box, fixup_weak_box, 0, 0);
GC_register_traversers(gc->ephemeron_tag, size_ephemeron, mark_ephemeron, fixup_ephemeron, 0, 0);
GC_register_traversers(gc->weak_array_tag, size_weak_array, mark_weak_array, fixup_weak_array, 0, 0);
initialize_signal_handler(gc);
GC_add_roots(&gc->park, (char *)&gc->park + sizeof(gc->park) + 1);
GC_add_roots(&gc->park_save, (char *)&gc->park_save + sizeof(gc->park_save) + 1);
initialize_protect_page_ranges(gc->protect_range, malloc_dirty_pages(gc, APAGE_SIZE, APAGE_SIZE), APAGE_SIZE);
init_type_tags_worker(NULL, count, pair, mutable_pair, weakbox, ephemeron, weakarray, custbox);
}
else {
GCPRINT(GCOUTF, "HEY WHATS UP.\n");
GCPRINT(GCOUTF, "GC_init_type_tags should only be called once!\n");
abort();
}
}
void GC_construct_child_gc() {
NewGC *gc = MASTERGC;
NewGC *newgc = init_type_tags_worker(gc, 0, 0, 0, gc->weak_box_tag, gc->ephemeron_tag, gc->weak_array_tag, gc->cust_box_tag);
newgc->primoridal_gc = MASTERGC;
}
static inline void save_globals_to_gc(NewGC *gc) {
gc->saved_mark_stack = mark_stack;
gc->saved_GC_variable_stack = GC_variable_stack;
gc->saved_GC_gen0_alloc_page_ptr = GC_gen0_alloc_page_ptr;
gc->saved_GC_gen0_alloc_page_end = GC_gen0_alloc_page_end;
}
static inline void restore_globals_from_gc(NewGC *gc) {
mark_stack = gc->saved_mark_stack;
GC_variable_stack = gc->saved_GC_variable_stack;
GC_gen0_alloc_page_ptr = gc->saved_GC_gen0_alloc_page_ptr;
GC_gen0_alloc_page_end = gc->saved_GC_gen0_alloc_page_end;
}
void GC_switch_out_master_gc() {
static int initialized = 0;
if(!initialized) {
initialized = 1;
MASTERGC = GC_get_GC();
MASTERGC->dumping_avoid_collection = 1;
save_globals_to_gc(MASTERGC);
GC_construct_child_gc();
}
else {
GCPRINT(GCOUTF, "GC_switch_out_master_gc should only be called once!\n");
abort();
}
}
void GC_switch_in_master_gc() {
GC_set_GC(MASTERGC);
restore_globals_from_gc(MASTERGC);
}
void GC_gcollect(void)
{
NewGC *gc = GC_get_GC();
@ -1484,8 +1583,15 @@ void GC_register_traversers(short tag, Size_Proc size, Mark_Proc mark,
Fixup_Proc fixup, int constant_Size, int atomic)
{
NewGC *gc = GC_get_GC();
gc->mark_table[tag] = atomic ? (Mark_Proc)PAGE_ATOMIC : mark;
gc->fixup_table[tag] = fixup;
int mark_tag = tag;
#ifdef NEWGC_BTC_ACCOUNT
mark_tag = BTC_get_redirect_tag(gc, mark_tag);
#endif
gc->mark_table[mark_tag] = atomic ? (Mark_Proc)PAGE_ATOMIC : mark;
gc->fixup_table[tag] = fixup;
}
long GC_get_memory_use(void *o)
@ -1709,8 +1815,10 @@ static void propagate_marks(NewGC *gc)
unsigned short tag = *(unsigned short*)start;
if((unsigned long)mark_table[tag] < PAGE_TYPES) {
/* atomic */
} else
} else {
assert(mark_table[tag]);
mark_table[tag](start); break;
}
}
case PAGE_ATOMIC: break;
case PAGE_ARRAY: while(start < end) gcMARK(*(start++)); break;
@ -1718,7 +1826,10 @@ static void propagate_marks(NewGC *gc)
case PAGE_TARRAY: {
unsigned short tag = *(unsigned short *)start;
end -= INSET_WORDS;
while(start < end) start += mark_table[tag](start);
while(start < end) {
assert(mark_table[tag]);
start += mark_table[tag](start);
}
break;
}
}
@ -1728,7 +1839,13 @@ static void propagate_marks(NewGC *gc)
set_backtrace_source(p, info->type);
switch(info->type) {
case PAGE_TAGGED: mark_table[*(unsigned short*)p](p); break;
case PAGE_TAGGED:
{
unsigned short tag = *(unsigned short*)p;
assert(mark_table[tag]);
mark_table[tag](p);
break;
}
case PAGE_ATOMIC: break;
case PAGE_ARRAY: {
void **start = p;
@ -1740,7 +1857,10 @@ static void propagate_marks(NewGC *gc)
void **start = p;
void **end = PPTR(info) + (info->size - INSET_WORDS);
unsigned short tag = *(unsigned short *)start;
while(start < end) start += mark_table[tag](start);
while(start < end) {
assert(mark_table[tag]);
start += mark_table[tag](start);
}
break;
}
case PAGE_XTAGGED: GC_mark_xtagged(p); break;
@ -2466,15 +2586,25 @@ static void garbage_collect(NewGC *gc, int force_full)
mark_roots(gc);
mark_immobiles(gc);
TIME_STEP("rooted");
GC_mark_variable_stack(GC_variable_stack, 0, get_stack_base(gc), NULL);
if (!is_master_gc(gc))
GC_mark_variable_stack(GC_variable_stack, 0, get_stack_base(gc), NULL);
TIME_STEP("stacked");
/* now propagate/repair the marks we got from these roots, and do the
finalizer passes */
propagate_marks(gc); mark_ready_ephemerons(gc); propagate_marks(gc);
check_finalizers(gc, 1); mark_ready_ephemerons(gc); propagate_marks(gc);
check_finalizers(gc, 2); mark_ready_ephemerons(gc); propagate_marks(gc);
propagate_marks(gc);
mark_ready_ephemerons(gc);
propagate_marks(gc);
check_finalizers(gc, 1);
mark_ready_ephemerons(gc);
propagate_marks(gc);
check_finalizers(gc, 2);
mark_ready_ephemerons(gc);
propagate_marks(gc);
if(gc->gc_full) zero_weak_finalizers(gc);
do_ordered_level3(gc); propagate_marks(gc);
check_finalizers(gc, 3); propagate_marks(gc);
@ -2514,7 +2644,8 @@ static void garbage_collect(NewGC *gc, int force_full)
repair_weak_finalizer_structs(gc);
repair_roots(gc);
repair_immobiles(gc);
GC_fixup_variable_stack(GC_variable_stack, 0, get_stack_base(gc), NULL);
if (!is_master_gc(gc))
GC_fixup_variable_stack(GC_variable_stack, 0, get_stack_base(gc), NULL);
TIME_STEP("reparied roots");
repair_heap(gc);
TIME_STEP("repaired");
@ -2679,6 +2810,13 @@ void GC_free_all(void)
}
}
free(gc->mark_table);
free(gc->fixup_table);
free_page_maps(gc->page_maps);
free(gc->protect_range);
vm_flush_freed_pages(gc->vm);
vm_free(gc->vm);
free(gc);

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

@ -35,6 +35,12 @@ typedef struct Gen0 {
unsigned long max_size;
} Gen0;
typedef struct MarkSegment {
struct MarkSegment *prev;
struct MarkSegment *next;
void **top;
} MarkSegment;
typedef struct Weak_Finalizer {
void *p;
int offset;
@ -110,10 +116,7 @@ typedef struct NewGC {
void (*unsafe_allocation_abort)(struct NewGC *);
unsigned long memory_in_use; /* the amount of memory in use */
/* blame the child saved off Mark_Proc pointers */
Mark_Proc normal_thread_mark;
Mark_Proc normal_custodian_mark;
Mark_Proc normal_cust_box_mark;
/* blame the child thread infos */
GC_Thread_Info *thread_infos;
mpage *release_pages;
@ -141,8 +144,6 @@ typedef struct NewGC {
AccountHook *hooks;
unsigned long number_of_gc_runs;
unsigned int since_last_full;
unsigned long last_full_mem_use;
@ -152,6 +153,13 @@ typedef struct NewGC {
unsigned long num_minor_collects;
unsigned long num_major_collects;
/* THREAD_LOCAL variables that need to be saved off */
MarkSegment *saved_mark_stack;
void *saved_GC_variable_stack;
unsigned long saved_GC_gen0_alloc_page_ptr;
unsigned long saved_GC_gen0_alloc_page_end;
/* Callbacks */
void (*GC_collect_start_callback)(void);
void (*GC_collect_end_callback)(void);

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

@ -14,11 +14,42 @@
/* ========== Linux signal handler ========== */
#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)
{
if (!designate_modified(si->si_addr))
void *p = si->si_addr;
if (si->si_code != SEGV_ACCERR) { /*SEGV_MAPERR*/
printf("SIGSEGV fault on %p\n", p);
launchgdb();
abort();
}
if (!designate_modified(p)) {
if (si->si_code == SEGV_ACCERR) {
printf("mprotect fault on %p\n", p);
}
else {
printf("?? %i fault on %p\n", si->si_code, p);
}
abort();
}
# define NEED_SIGACTION
# define USE_SIGACTON_SIGNAL_KIND SIGSEGV
}

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

@ -234,12 +234,17 @@ static int mark_ephemeron(void *p)
#ifdef NEWGC_BTC_ACCOUNT
static int BTC_ephemeron_mark(void *p)
{
GC_Ephemeron *eph = (GC_Ephemeron *)p;
GCTYPE *gc = GC_get_GC();
if (gc->doing_memory_accounting) {
gcMARK(eph->key);
gcMARK(eph->val);
GC_Ephemeron *eph = (GC_Ephemeron *)p;
return gcBYTES_TO_WORDS(sizeof(GC_Ephemeron));
gcMARK(eph->key);
gcMARK(eph->val);
return gcBYTES_TO_WORDS(sizeof(GC_Ephemeron));
}
return mark_ephemeron(p);
}
#endif

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

@ -776,25 +776,24 @@ static long mem_traced;
static long num_chunks;
static long num_blocks;
typedef void (*GC_collect_start_callback_Proc)(void);
typedef void (*GC_collect_end_callback_Proc)(void);
GC_collect_start_callback_Proc GC_collect_start_callback;
GC_collect_end_callback_Proc GC_collect_end_callback;
void (*GC_custom_finalize)(void);
GC_collect_start_callback_Proc GC_set_collect_start_callback(GC_collect_start_callback_Proc) {
GC_collect_start_callback_Proc GC_set_collect_start_callback(GC_collect_start_callback_Proc func) {
GC_collect_start_callback_Proc old;
old = GC_collect_start_callback;
GC_collect_start_callback = func;
return old
return old;
}
GC_collect_end_callback_Proc GC_set_collect_end_callback(GC_collect_end_callback_Proc) {
GC_collect_end_callback_Proc old
GC_collect_end_callback_Proc GC_set_collect_end_callback(GC_collect_end_callback_Proc func) {
GC_collect_end_callback_Proc old;
old = GC_collect_end_callback;
GC_collect_end_callback = func;
return old
return old;
}
static long roots_count;
static long roots_size;
static unsigned long *roots;

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_atomic_uncollectable(size_t size_in_bytes);
typedef void (*GC_collect_start_callback_Proc)(void);
typedef void (*GC_collect_end_callback_Proc)(void);
GC_collect_start_callback_Proc GC_set_collect_start_callback(GC_collect_start_callback_Proc);
GC_collect_end_callback_Proc GC_set_collect_end_callback(GC_collect_end_callback_Proc);
void GC_free(void *); /* ... but only if it's turned on in sgc.c. */
struct GC_Set;

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

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,
0,84,0,98,0,112,0,115,0,119,0,121,0,132,0,134,0,148,0,155,0,
177,0,179,0,193,0,253,0,23,1,32,1,41,1,51,1,87,1,126,1,165,
1,234,1,42,2,130,2,194,2,199,2,219,2,110,3,130,3,181,3,247,3,
132,4,34,5,84,5,107,5,186,5,0,0,201,7,0,0,65,98,101,103,105,
132,4,34,5,84,5,107,5,186,5,0,0,204,7,0,0,65,98,101,103,105,
110,29,11,11,68,104,101,114,101,45,115,116,120,63,108,101,116,72,112,97,114,
97,109,101,116,101,114,105,122,101,62,111,114,64,108,101,116,42,66,117,110,108,
101,115,115,64,99,111,110,100,64,119,104,101,110,66,108,101,116,114,101,99,66,
@ -29,15 +29,15 @@
248,22,72,248,22,66,23,195,2,248,22,65,193,249,22,190,3,80,158,38,35,
251,22,74,2,17,248,22,65,23,200,2,249,22,64,2,13,248,22,66,23,202,
1,11,18,16,2,101,10,8,31,8,30,8,29,8,28,8,27,16,4,11,11,
2,18,3,1,7,101,110,118,57,55,57,52,16,4,11,11,2,19,3,1,7,
101,110,118,57,55,57,53,93,8,224,252,60,0,0,95,9,8,224,252,60,0,
2,18,3,1,7,101,110,118,57,55,57,51,16,4,11,11,2,19,3,1,7,
101,110,118,57,55,57,52,93,8,224,252,60,0,0,95,9,8,224,252,60,0,
0,2,2,27,248,22,66,248,22,133,4,23,197,1,28,248,22,72,23,194,2,
20,15,159,36,35,36,28,248,22,72,248,22,66,23,195,2,248,22,65,193,249,
22,190,3,80,158,38,35,250,22,74,2,20,248,22,74,249,22,74,248,22,74,
2,21,248,22,65,23,202,2,251,22,74,2,17,2,21,2,21,249,22,64,2,
6,248,22,66,23,205,1,18,16,2,101,11,8,31,8,30,8,29,8,28,8,
27,16,4,11,11,2,18,3,1,7,101,110,118,57,55,57,55,16,4,11,11,
2,19,3,1,7,101,110,118,57,55,57,56,93,8,224,253,60,0,0,95,9,
27,16,4,11,11,2,18,3,1,7,101,110,118,57,55,57,54,16,4,11,11,
2,19,3,1,7,101,110,118,57,55,57,55,93,8,224,253,60,0,0,95,9,
8,224,253,60,0,0,2,2,248,22,133,4,193,27,248,22,133,4,194,249,22,
64,248,22,74,248,22,65,196,248,22,66,195,27,248,22,66,248,22,133,4,23,
197,1,249,22,190,3,80,158,38,35,28,248,22,52,248,22,191,3,248,22,65,
@ -68,48 +68,48 @@
249,22,162,8,248,22,191,3,248,22,65,23,201,2,64,101,108,115,101,10,248,
22,65,23,198,2,250,22,75,2,20,9,248,22,66,23,201,1,249,22,64,2,
9,248,22,66,23,203,1,100,8,31,8,30,8,29,8,28,8,27,16,4,11,
11,2,18,3,1,7,101,110,118,57,56,50,48,16,4,11,11,2,19,3,1,
7,101,110,118,57,56,50,49,93,8,224,254,60,0,0,18,16,2,158,94,10,
11,2,18,3,1,7,101,110,118,57,56,49,57,16,4,11,11,2,19,3,1,
7,101,110,118,57,56,50,48,93,8,224,254,60,0,0,18,16,2,158,94,10,
64,118,111,105,100,8,47,95,9,8,224,254,60,0,0,2,2,27,248,22,66,
248,22,133,4,196,249,22,190,3,80,158,38,35,28,248,22,52,248,22,191,3,
248,22,65,197,250,22,74,2,26,248,22,74,248,22,65,199,248,22,89,198,27,
248,22,191,3,248,22,65,197,250,22,74,2,26,248,22,74,248,22,65,197,250,
22,75,2,23,248,22,66,199,248,22,66,202,159,35,20,103,159,35,16,1,2,
1,16,0,83,158,41,20,100,141,69,35,37,109,105,110,45,115,116,120,2,2,
1,16,0,83,158,41,20,100,143,69,35,37,109,105,110,45,115,116,120,2,2,
11,10,11,10,35,80,158,35,35,20,103,159,35,16,0,16,0,11,11,16,1,
2,3,36,16,0,35,11,11,38,35,11,11,16,10,2,4,2,5,2,6,2,
7,2,8,2,9,2,10,2,11,2,12,2,13,16,10,11,11,11,11,11,11,
11,11,11,11,16,10,2,4,2,5,2,6,2,7,2,8,2,9,2,10,2,
11,2,12,2,13,35,45,36,11,11,16,0,16,0,16,0,35,35,11,11,11,
16,0,16,0,16,0,35,35,16,11,16,5,93,2,3,20,15,159,35,35,35,
35,20,103,159,35,16,0,16,1,33,32,10,16,5,93,2,8,89,162,8,44,
36,52,9,223,0,33,33,35,20,103,159,35,16,1,20,25,159,36,2,2,2,
3,16,0,11,16,5,93,2,10,89,162,8,44,36,52,9,223,0,33,34,35,
20,103,159,35,16,1,20,25,159,36,2,2,2,3,16,0,11,16,5,93,2,
13,89,162,8,44,36,52,9,223,0,33,35,35,20,103,159,35,16,1,20,25,
159,36,2,2,2,3,16,1,33,36,11,16,5,93,2,6,89,162,8,44,36,
55,9,223,0,33,37,35,20,103,159,35,16,1,20,25,159,36,2,2,2,3,
16,1,33,38,11,16,5,93,2,4,89,162,8,44,36,57,9,223,0,33,41,
2,3,36,16,0,35,16,0,35,11,11,38,35,11,11,16,10,2,4,2,5,
2,6,2,7,2,8,2,9,2,10,2,11,2,12,2,13,16,10,11,11,11,
11,11,11,11,11,11,11,16,10,2,4,2,5,2,6,2,7,2,8,2,9,
2,10,2,11,2,12,2,13,35,45,36,11,11,16,0,16,0,16,0,35,35,
11,11,11,16,0,16,0,16,0,35,35,16,11,16,5,93,2,3,20,15,159,
35,35,35,35,20,103,159,35,16,0,16,1,33,32,10,16,5,93,2,8,89,
162,8,44,36,52,9,223,0,33,33,35,20,103,159,35,16,1,20,25,159,36,
2,2,2,3,16,0,11,16,5,93,2,10,89,162,8,44,36,52,9,223,0,
33,34,35,20,103,159,35,16,1,20,25,159,36,2,2,2,3,16,0,11,16,
5,93,2,13,89,162,8,44,36,52,9,223,0,33,35,35,20,103,159,35,16,
1,20,25,159,36,2,2,2,3,16,1,33,36,11,16,5,93,2,6,89,162,
8,44,36,55,9,223,0,33,37,35,20,103,159,35,16,1,20,25,159,36,2,
2,2,3,16,1,33,38,11,16,5,93,2,4,89,162,8,44,36,57,9,223,
0,33,41,35,20,103,159,35,16,1,20,25,159,36,2,2,2,3,16,0,11,
16,5,93,2,11,89,162,8,44,36,52,9,223,0,33,43,35,20,103,159,35,
16,1,20,25,159,36,2,2,2,3,16,0,11,16,5,93,2,7,89,162,8,
44,36,53,9,223,0,33,44,35,20,103,159,35,16,1,20,25,159,36,2,2,
2,3,16,0,11,16,5,93,2,5,89,162,8,44,36,54,9,223,0,33,45,
35,20,103,159,35,16,1,20,25,159,36,2,2,2,3,16,0,11,16,5,93,
2,11,89,162,8,44,36,52,9,223,0,33,43,35,20,103,159,35,16,1,20,
25,159,36,2,2,2,3,16,0,11,16,5,93,2,7,89,162,8,44,36,53,
9,223,0,33,44,35,20,103,159,35,16,1,20,25,159,36,2,2,2,3,16,
0,11,16,5,93,2,5,89,162,8,44,36,54,9,223,0,33,45,35,20,103,
159,35,16,1,20,25,159,36,2,2,2,3,16,0,11,16,5,93,2,9,89,
162,8,44,36,57,9,223,0,33,46,35,20,103,159,35,16,1,20,25,159,36,
2,2,2,3,16,1,33,48,11,16,5,93,2,12,89,162,8,44,36,53,9,
223,0,33,49,35,20,103,159,35,16,1,20,25,159,36,2,2,2,3,16,0,
11,16,0,94,2,15,2,16,93,2,15,9,9,35,0};
EVAL_ONE_SIZED_STR((char *)expr, 2114);
2,9,89,162,8,44,36,57,9,223,0,33,46,35,20,103,159,35,16,1,20,
25,159,36,2,2,2,3,16,1,33,48,11,16,5,93,2,12,89,162,8,44,
36,53,9,223,0,33,49,35,20,103,159,35,16,1,20,25,159,36,2,2,2,
3,16,0,11,16,0,94,2,15,2,16,93,2,15,9,9,35,0};
EVAL_ONE_SIZED_STR((char *)expr, 2117);
}
{
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,52,60,0,0,0,1,0,0,3,0,16,0,
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,53,60,0,0,0,1,0,0,3,0,16,0,
21,0,38,0,53,0,71,0,87,0,97,0,115,0,135,0,151,0,169,0,200,
0,229,0,251,0,9,1,15,1,29,1,34,1,44,1,52,1,80,1,112,1,
157,1,202,1,226,1,9,2,11,2,68,2,158,3,199,3,33,5,137,5,241,
5,102,6,116,6,150,6,166,6,16,8,30,8,193,8,194,9,194,10,201,10,
208,10,215,10,90,11,103,11,58,12,160,12,173,12,195,12,147,13,51,14,122,
15,130,15,138,15,164,15,18,16,0,0,67,19,0,0,29,11,11,72,112,97,
15,130,15,138,15,164,15,18,16,0,0,70,19,0,0,29,11,11,72,112,97,
116,104,45,115,116,114,105,110,103,63,64,98,115,98,115,76,110,111,114,109,97,
108,45,99,97,115,101,45,112,97,116,104,74,45,99,104,101,99,107,45,114,101,
108,112,97,116,104,77,45,99,104,101,99,107,45,99,111,108,108,101,99,116,105,
@ -306,7 +306,7 @@
173,3,23,202,1,28,192,192,35,249,22,151,5,23,197,1,83,158,39,20,97,
95,89,162,8,44,35,47,9,224,3,2,33,58,23,195,1,23,196,1,27,248,
22,136,5,23,195,1,248,80,159,38,53,36,193,159,35,20,103,159,35,16,1,
65,98,101,103,105,110,16,0,83,158,41,20,100,141,67,35,37,117,116,105,108,
65,98,101,103,105,110,16,0,83,158,41,20,100,143,67,35,37,117,116,105,108,
115,2,1,11,11,10,10,42,80,158,35,35,20,103,159,37,16,17,30,2,1,
2,2,193,30,2,1,2,3,193,30,2,1,2,4,193,30,2,1,2,5,193,
30,2,1,2,6,193,30,2,1,2,7,193,30,2,1,2,8,193,30,2,1,
@ -315,63 +315,63 @@
2,16,193,30,2,18,1,20,112,97,114,97,109,101,116,101,114,105,122,97,116,
105,111,110,45,107,101,121,4,30,2,18,1,23,101,120,116,101,110,100,45,112,
97,114,97,109,101,116,101,114,105,122,97,116,105,111,110,3,16,0,11,11,16,
0,35,16,4,2,6,2,5,2,3,2,9,39,11,11,38,35,11,11,16,11,
2,8,2,7,2,16,2,15,2,13,2,12,2,4,2,11,2,14,2,10,2,
2,16,11,11,11,11,11,11,11,11,11,11,11,11,16,11,2,8,2,7,2,
16,2,15,2,13,2,12,2,4,2,11,2,14,2,10,2,2,46,46,36,11,
11,16,0,16,0,16,0,35,35,11,11,11,16,0,16,0,16,0,35,35,16,
0,16,17,83,158,35,16,2,89,162,43,36,48,2,19,223,0,33,29,80,159,
35,53,36,83,158,35,16,2,89,162,8,44,36,55,2,19,223,0,33,30,80,
159,35,52,36,83,158,35,16,2,32,0,89,162,43,36,44,2,2,222,33,31,
80,159,35,35,36,83,158,35,16,2,249,22,159,6,7,92,7,92,80,159,35,
36,36,83,158,35,16,2,89,162,43,36,53,2,4,223,0,33,32,80,159,35,
37,36,83,158,35,16,2,32,0,89,162,8,44,37,49,2,5,222,33,33,80,
159,35,38,36,83,158,35,16,2,32,0,89,162,8,44,38,50,2,6,222,33,
35,80,159,35,39,36,83,158,35,16,2,89,162,8,45,37,47,2,7,223,0,
33,37,80,159,35,40,36,83,158,35,16,2,32,0,89,162,43,39,51,2,8,
222,33,40,80,159,35,41,36,83,158,35,16,2,32,0,89,162,43,38,49,2,
9,222,33,41,80,159,35,42,36,83,158,35,16,2,32,0,89,162,43,37,52,
2,10,222,33,42,80,159,35,43,36,83,158,35,16,2,32,0,89,162,43,37,
53,2,11,222,33,43,80,159,35,44,36,83,158,35,16,2,32,0,89,162,43,
36,43,2,12,222,33,44,80,159,35,45,36,83,158,35,16,2,83,158,38,20,
96,96,2,13,89,162,43,35,43,9,223,0,33,45,89,162,43,36,44,9,223,
0,33,46,89,162,43,37,54,9,223,0,33,47,80,159,35,46,36,83,158,35,
16,2,27,248,22,182,13,248,22,168,7,27,28,249,22,162,8,247,22,176,7,
2,21,6,1,1,59,6,1,1,58,250,22,141,7,6,14,14,40,91,94,126,
97,93,42,41,126,97,40,46,42,41,23,196,2,23,196,1,89,162,8,44,37,
47,2,14,223,0,33,50,80,159,35,47,36,83,158,35,16,2,83,158,38,20,
96,96,2,15,89,162,8,44,38,53,9,223,0,33,55,89,162,43,37,46,9,
223,0,33,56,89,162,43,36,45,9,223,0,33,57,80,159,35,48,36,83,158,
35,16,2,89,162,43,38,51,2,16,223,0,33,59,80,159,35,49,36,94,29,
94,2,17,68,35,37,107,101,114,110,101,108,11,29,94,2,17,69,35,37,109,
105,110,45,115,116,120,11,9,9,9,35,0};
EVAL_ONE_SIZED_STR((char *)expr, 5072);
0,35,16,0,35,16,4,2,6,2,5,2,3,2,9,39,11,11,38,35,11,
11,16,11,2,8,2,7,2,16,2,15,2,13,2,12,2,4,2,11,2,14,
2,10,2,2,16,11,11,11,11,11,11,11,11,11,11,11,11,16,11,2,8,
2,7,2,16,2,15,2,13,2,12,2,4,2,11,2,14,2,10,2,2,46,
46,36,11,11,16,0,16,0,16,0,35,35,11,11,11,16,0,16,0,16,0,
35,35,16,0,16,17,83,158,35,16,2,89,162,43,36,48,2,19,223,0,33,
29,80,159,35,53,36,83,158,35,16,2,89,162,8,44,36,55,2,19,223,0,
33,30,80,159,35,52,36,83,158,35,16,2,32,0,89,162,43,36,44,2,2,
222,33,31,80,159,35,35,36,83,158,35,16,2,249,22,159,6,7,92,7,92,
80,159,35,36,36,83,158,35,16,2,89,162,43,36,53,2,4,223,0,33,32,
80,159,35,37,36,83,158,35,16,2,32,0,89,162,8,44,37,49,2,5,222,
33,33,80,159,35,38,36,83,158,35,16,2,32,0,89,162,8,44,38,50,2,
6,222,33,35,80,159,35,39,36,83,158,35,16,2,89,162,8,45,37,47,2,
7,223,0,33,37,80,159,35,40,36,83,158,35,16,2,32,0,89,162,43,39,
51,2,8,222,33,40,80,159,35,41,36,83,158,35,16,2,32,0,89,162,43,
38,49,2,9,222,33,41,80,159,35,42,36,83,158,35,16,2,32,0,89,162,
43,37,52,2,10,222,33,42,80,159,35,43,36,83,158,35,16,2,32,0,89,
162,43,37,53,2,11,222,33,43,80,159,35,44,36,83,158,35,16,2,32,0,
89,162,43,36,43,2,12,222,33,44,80,159,35,45,36,83,158,35,16,2,83,
158,38,20,96,96,2,13,89,162,43,35,43,9,223,0,33,45,89,162,43,36,
44,9,223,0,33,46,89,162,43,37,54,9,223,0,33,47,80,159,35,46,36,
83,158,35,16,2,27,248,22,182,13,248,22,168,7,27,28,249,22,162,8,247,
22,176,7,2,21,6,1,1,59,6,1,1,58,250,22,141,7,6,14,14,40,
91,94,126,97,93,42,41,126,97,40,46,42,41,23,196,2,23,196,1,89,162,
8,44,37,47,2,14,223,0,33,50,80,159,35,47,36,83,158,35,16,2,83,
158,38,20,96,96,2,15,89,162,8,44,38,53,9,223,0,33,55,89,162,43,
37,46,9,223,0,33,56,89,162,43,36,45,9,223,0,33,57,80,159,35,48,
36,83,158,35,16,2,89,162,43,38,51,2,16,223,0,33,59,80,159,35,49,
36,94,29,94,2,17,68,35,37,107,101,114,110,101,108,11,29,94,2,17,69,
35,37,109,105,110,45,115,116,120,11,9,9,9,35,0};
EVAL_ONE_SIZED_STR((char *)expr, 5075);
}
{
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,52,8,0,0,0,1,0,0,6,0,19,0,
34,0,48,0,62,0,76,0,111,0,0,0,3,1,0,0,65,113,117,111,116,
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,53,8,0,0,0,1,0,0,6,0,19,0,
34,0,48,0,62,0,76,0,111,0,0,0,6,1,0,0,65,113,117,111,116,
101,29,94,2,1,67,35,37,117,116,105,108,115,11,29,94,2,1,69,35,37,
110,101,116,119,111,114,107,11,29,94,2,1,68,35,37,112,97,114,97,109,122,
11,29,94,2,1,68,35,37,101,120,112,111,98,115,11,29,94,2,1,68,35,
37,107,101,114,110,101,108,11,98,10,35,11,8,186,245,97,159,2,2,35,35,
159,2,3,35,35,159,2,4,35,35,159,2,5,35,35,159,2,6,35,35,16,
0,159,35,20,103,159,35,16,1,65,98,101,103,105,110,16,0,83,158,41,20,
100,141,69,35,37,98,117,105,108,116,105,110,29,11,11,11,10,10,18,96,11,
100,143,69,35,37,98,117,105,108,116,105,110,29,11,11,11,10,10,18,96,11,
42,42,42,35,80,158,35,35,20,103,159,35,16,0,16,0,11,11,16,0,35,
16,0,35,11,11,38,35,11,11,16,0,16,0,16,0,35,35,36,11,11,16,
0,16,0,16,0,35,35,11,11,11,16,0,16,0,16,0,35,35,16,0,16,
0,99,2,6,2,5,29,94,2,1,69,35,37,102,111,114,101,105,103,110,11,
2,4,2,3,2,2,29,94,2,1,67,35,37,112,108,97,99,101,11,9,9,
9,35,0};
EVAL_ONE_SIZED_STR((char *)expr, 296);
16,0,35,16,0,35,11,11,38,35,11,11,16,0,16,0,16,0,35,35,36,
11,11,16,0,16,0,16,0,35,35,11,11,11,16,0,16,0,16,0,35,35,
16,0,16,0,99,2,6,2,5,29,94,2,1,69,35,37,102,111,114,101,105,
103,110,11,2,4,2,3,2,2,29,94,2,1,67,35,37,112,108,97,99,101,
11,9,9,9,35,0};
EVAL_ONE_SIZED_STR((char *)expr, 299);
}
{
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,52,53,0,0,0,1,0,0,3,0,14,0,
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,53,53,0,0,0,1,0,0,3,0,14,0,
41,0,47,0,60,0,74,0,96,0,122,0,134,0,152,0,172,0,184,0,200,
0,223,0,3,1,8,1,13,1,18,1,27,1,32,1,63,1,67,1,75,1,
83,1,91,1,194,1,239,1,3,2,31,2,62,2,117,2,127,2,174,2,184,
2,191,2,78,4,91,4,110,4,229,4,241,4,137,5,151,5,15,6,21,6,
35,6,62,6,147,6,149,6,214,6,149,12,208,12,240,12,0,0,168,15,0,
35,6,62,6,147,6,149,6,214,6,149,12,208,12,240,12,0,0,171,15,0,
0,29,11,11,70,100,108,108,45,115,117,102,102,105,120,1,25,100,101,102,97,
117,108,116,45,108,111,97,100,47,117,115,101,45,99,111,109,112,105,108,101,100,
65,113,117,111,116,101,29,94,2,4,67,35,37,117,116,105,108,115,11,29,94,
@ -530,7 +530,7 @@
33,43,89,162,43,38,48,9,223,1,33,44,89,162,43,39,8,30,9,225,2,
3,0,33,50,208,87,95,248,22,150,4,248,80,158,37,49,247,22,183,11,248,
22,188,4,80,158,36,36,248,22,174,12,80,159,36,41,36,159,35,20,103,159,
35,16,1,65,98,101,103,105,110,16,0,83,158,41,20,100,141,66,35,37,98,
35,16,1,65,98,101,103,105,110,16,0,83,158,41,20,100,143,66,35,37,98,
111,111,116,2,1,11,11,10,10,36,80,158,35,35,20,103,159,39,16,19,30,
2,1,2,2,193,30,2,1,2,3,193,30,2,5,72,112,97,116,104,45,115,
116,114,105,110,103,63,10,30,2,5,75,112,97,116,104,45,97,100,100,45,115,
@ -542,26 +542,27 @@
1,2,14,193,30,2,1,2,15,193,30,2,5,69,45,102,105,110,100,45,99,
111,108,0,30,2,5,76,110,111,114,109,97,108,45,99,97,115,101,45,112,97,
116,104,6,30,2,5,79,112,97,116,104,45,114,101,112,108,97,99,101,45,115,
117,102,102,105,120,9,30,2,1,2,16,193,16,0,11,11,16,0,35,16,11,
2,10,2,11,2,8,2,9,2,12,2,13,2,3,2,7,2,2,2,15,2,
14,46,11,11,38,35,11,11,16,1,2,16,16,1,11,16,1,2,16,36,36,
36,11,11,16,0,16,0,16,0,35,35,11,11,11,16,0,16,0,16,0,35,
35,16,0,16,16,83,158,35,16,2,89,162,43,36,44,9,223,0,33,24,80,
159,35,57,36,83,158,35,16,2,89,162,43,36,44,9,223,0,33,25,80,159,
35,56,36,83,158,35,16,2,89,162,43,36,48,67,103,101,116,45,100,105,114,
223,0,33,26,80,159,35,55,36,83,158,35,16,2,89,162,43,37,48,68,119,
105,116,104,45,100,105,114,223,0,33,27,80,159,35,54,36,83,158,35,16,2,
248,22,176,7,69,115,111,45,115,117,102,102,105,120,80,159,35,35,36,83,158,
35,16,2,89,162,43,37,59,2,3,223,0,33,36,80,159,35,36,36,83,158,
35,16,2,32,0,89,162,8,44,36,41,2,7,222,192,80,159,35,41,36,83,
158,35,16,2,247,22,125,80,159,35,42,36,83,158,35,16,2,247,22,124,80,
159,35,43,36,83,158,35,16,2,247,22,60,80,159,35,44,36,83,158,35,16,
2,248,22,18,74,109,111,100,117,108,101,45,108,111,97,100,105,110,103,80,159,
35,45,36,83,158,35,16,2,11,80,158,35,46,83,158,35,16,2,11,80,158,
35,47,83,158,35,16,2,32,0,89,162,43,37,44,2,14,222,33,42,80,159,
35,48,36,83,158,35,16,2,89,162,8,44,36,44,2,15,223,0,33,51,80,
159,35,49,36,83,158,35,16,2,89,162,43,35,43,2,16,223,0,33,52,80,
159,35,53,36,95,29,94,2,4,68,35,37,107,101,114,110,101,108,11,29,94,
2,4,69,35,37,109,105,110,45,115,116,120,11,2,5,9,9,9,35,0};
EVAL_ONE_SIZED_STR((char *)expr, 4135);
117,102,102,105,120,9,30,2,1,2,16,193,16,0,11,11,16,0,35,16,0,
35,16,11,2,10,2,11,2,8,2,9,2,12,2,13,2,3,2,7,2,2,
2,15,2,14,46,11,11,38,35,11,11,16,1,2,16,16,1,11,16,1,2,
16,36,36,36,11,11,16,0,16,0,16,0,35,35,11,11,11,16,0,16,0,
16,0,35,35,16,0,16,16,83,158,35,16,2,89,162,43,36,44,9,223,0,
33,24,80,159,35,57,36,83,158,35,16,2,89,162,43,36,44,9,223,0,33,
25,80,159,35,56,36,83,158,35,16,2,89,162,43,36,48,67,103,101,116,45,
100,105,114,223,0,33,26,80,159,35,55,36,83,158,35,16,2,89,162,43,37,
48,68,119,105,116,104,45,100,105,114,223,0,33,27,80,159,35,54,36,83,158,
35,16,2,248,22,176,7,69,115,111,45,115,117,102,102,105,120,80,159,35,35,
36,83,158,35,16,2,89,162,43,37,59,2,3,223,0,33,36,80,159,35,36,
36,83,158,35,16,2,32,0,89,162,8,44,36,41,2,7,222,192,80,159,35,
41,36,83,158,35,16,2,247,22,125,80,159,35,42,36,83,158,35,16,2,247,
22,124,80,159,35,43,36,83,158,35,16,2,247,22,60,80,159,35,44,36,83,
158,35,16,2,248,22,18,74,109,111,100,117,108,101,45,108,111,97,100,105,110,
103,80,159,35,45,36,83,158,35,16,2,11,80,158,35,46,83,158,35,16,2,
11,80,158,35,47,83,158,35,16,2,32,0,89,162,43,37,44,2,14,222,33,
42,80,159,35,48,36,83,158,35,16,2,89,162,8,44,36,44,2,15,223,0,
33,51,80,159,35,49,36,83,158,35,16,2,89,162,43,35,43,2,16,223,0,
33,52,80,159,35,53,36,95,29,94,2,4,68,35,37,107,101,114,110,101,108,
11,29,94,2,4,69,35,37,109,105,110,45,115,116,120,11,2,5,9,9,9,
35,0};
EVAL_ONE_SIZED_STR((char *)expr, 4138);
}

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 */
Scheme_Env *scheme_engine_instance_init() {
Scheme_Env *env;
@ -326,6 +325,16 @@ Scheme_Env *scheme_engine_instance_init() {
scheme_init_ephemerons();
#endif
/* These calls must be made here so that they allocate out of the master GC */
scheme_init_symbol_table();
scheme_init_module_path_table();
#if defined(MZ_PRECISE_GC) && defined(MZ_USE_PLACES)
GC_switch_out_master_gc();
spawn_master_scheme_place();
#endif
place_instance_init_pre_kernel(stack_base);
make_kernel_env();
scheme_init_parameterization_readonly_globals();
@ -455,7 +464,6 @@ static void make_kernel_env(void)
/* The ordering of the first few init calls is important, so add to
the end of the list, not the beginning. */
MZTIMEIT(symbol-table, scheme_init_symbol_table());
MZTIMEIT(type, scheme_init_type(env));
MZTIMEIT(symbol-type, scheme_init_symbol_type(env));
MZTIMEIT(fun, scheme_init_fun(env));

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:
{
Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)obj;
GC_CAN_IGNORE Scheme_Object *key, *val;
Scheme_Object *key;
GC_CAN_IGNORE Scheme_Object *val;
UPDATE_THREAD_RSPTR();
key = wcm->key;
if (SCHEME_TYPE(key) < _scheme_values_types_)
key = _scheme_eval_linked_expr_wp(wcm->key, p);
key = _scheme_eval_linked_expr_wp(key, p);
val = wcm->val;
if (SCHEME_TYPE(val) < _scheme_values_types_)
val = _scheme_eval_linked_expr_wp(wcm->val, p);
val = _scheme_eval_linked_expr_wp(val, p);
scheme_set_cont_mark(key, val);

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);
static Scheme_Object **compute_indirects(Scheme_Env *genv,
Scheme_Module_Phase_Exports *pt,
int *_count);
int *_count,
int vars);
static void start_module(Scheme_Module *m, Scheme_Env *env, int restart, Scheme_Object *syntax_idx,
int eval_exp, int eval_run, long base_phase, Scheme_Object *cycle_list);
static void finish_expstart_module(Scheme_Env *menv);
@ -2369,6 +2370,11 @@ void scheme_prep_namespace_rename(Scheme_Env *menv)
scheme_extend_module_rename(one_rn, m->self_modidx, name, name, m->self_modidx, name, 0,
scheme_make_integer(0), NULL, 0);
}
for (i = 0; i < m->num_indirect_syntax_provides; i++) {
name = m->indirect_syntax_provides[i];
scheme_extend_module_rename(one_rn, m->self_modidx, name, name, m->self_modidx, name, 0,
scheme_make_integer(0), NULL, 0);
}
one_rn = scheme_get_module_rename_from_set(rns, scheme_make_integer(1), 1);
@ -2710,7 +2716,13 @@ static Scheme_Object *module_path_index_join(int argc, Scheme_Object *argv[])
return scheme_make_modidx(argv[0], argv[1], scheme_false);
}
Scheme_Object *scheme_intern_resolved_module_path(Scheme_Object *o)
void scheme_init_module_path_table()
{
REGISTER_SO(modpath_table);
modpath_table = scheme_make_weak_equal_table();
}
Scheme_Object *scheme_intern_resolved_module_path_worker(Scheme_Object *o)
{
Scheme_Object *rmp;
Scheme_Bucket *b;
@ -2718,11 +2730,6 @@ Scheme_Object *scheme_intern_resolved_module_path(Scheme_Object *o)
mzrt_mutex_lock(modpath_table_mutex);
if (!modpath_table) {
REGISTER_SO(modpath_table);
modpath_table = scheme_make_weak_equal_table();
}
rmp = scheme_alloc_small_object();
rmp->type = scheme_resolved_module_path_type;
SCHEME_PTR_VAL(rmp) = o;
@ -2738,6 +2745,21 @@ Scheme_Object *scheme_intern_resolved_module_path(Scheme_Object *o)
return return_value;
}
Scheme_Object *scheme_intern_resolved_module_path(Scheme_Object *o)
{
#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
mz_proc_thread *self;
self = proc_thread_self;
if ( scheme_master_proc_thread && scheme_master_proc_thread != proc_thread_self ) {
int return_msg_type;
void *return_payload;
pt_mbox_send_recv(scheme_master_proc_thread->mbox, 1, o, self->mbox, &return_msg_type, &return_payload);
return (Scheme_Object*) return_payload;
}
#endif
return scheme_intern_resolved_module_path_worker(o);
}
static Scheme_Object *resolved_module_path_p(int argc, Scheme_Object *argv[])
{
return (SCHEME_MODNAMEP(argv[0])
@ -5678,9 +5700,9 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
Scheme_Object *post_ex_rn_set; /* phase -> post_ex_rn-like rename */
Scheme_Hash_Table *tables; /* phase -> (vector toplevels requires syntaxes) */
Scheme_Object *exclude_hint = scheme_false, *lift_data;
Scheme_Object **exis, **et_exis;
Scheme_Object **exis, **et_exis, **exsis;
Scheme_Object *lift_ctx;
int exicount, et_exicount;
int exicount, et_exicount, exsicount;
char *exps, *et_exps;
int all_simple_renames = 1;
int maybe_has_lifts = 0;
@ -6395,8 +6417,9 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
form, &et_exps);
/* Compute indirect provides (which is everything at the top-level): */
exis = compute_indirects(env->genv, env->genv->module->me->rt, &exicount);
et_exis = compute_indirects(env->genv->exp_env, env->genv->module->me->et, &et_exicount);
exis = compute_indirects(env->genv, env->genv->module->me->rt, &exicount, 1);
exsis = compute_indirects(env->genv, env->genv->module->me->rt, &exsicount, 0);
et_exis = compute_indirects(env->genv->exp_env, env->genv->module->me->et, &et_exicount, 1);
if (rec[drec].comp || (rec[drec].depth != -2)) {
scheme_clean_dead_env(env->genv);
@ -6519,6 +6542,14 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
env->genv->module->indirect_provides = exis;
env->genv->module->num_indirect_provides = exicount;
if (all_simple_renames) {
env->genv->module->indirect_syntax_provides = exsis;
env->genv->module->num_indirect_syntax_provides = exsicount;
} else {
env->genv->module->indirect_syntax_provides = NULL;
env->genv->module->num_indirect_syntax_provides = 0;
}
env->genv->module->et_indirect_provides = et_exis;
env->genv->module->num_indirect_et_provides = et_exicount;
@ -6930,18 +6961,34 @@ int compute_reprovides(Scheme_Hash_Table *all_provided,
static Scheme_Object **compute_indirects(Scheme_Env *genv,
Scheme_Module_Phase_Exports *pt,
int *_count)
int *_count,
int vars)
{
int i, count, j;
int i, count, j, start, end;
Scheme_Bucket **bs, *b;
Scheme_Object **exsns = pt->provide_src_names, **exis;
int exvcount = pt->num_var_provides, exicount;
int exicount;
Scheme_Bucket_Table *t;
if (!genv->toplevel)
if (vars) {
start = 0;
end = pt->num_var_provides;
} else {
start = pt->num_var_provides;
end = pt->num_provides;
}
if (vars)
t = genv->toplevel;
else
t = genv->syntax;
if (!t)
count = 0;
else {
bs = genv->toplevel->buckets;
for (count = 0, i = genv->toplevel->size; i--; ) {
bs = t->buckets;
for (count = 0, i = t->size; i--; ) {
b = bs[i];
if (b && b->val)
count++;
@ -6955,7 +7002,7 @@ static Scheme_Object **compute_indirects(Scheme_Env *genv,
exis = MALLOC_N(Scheme_Object *, count);
for (count = 0, i = genv->toplevel->size; i--; ) {
for (count = 0, i = t->size; i--; ) {
b = bs[i];
if (b && b->val) {
Scheme_Object *name;
@ -6963,12 +7010,12 @@ static Scheme_Object **compute_indirects(Scheme_Env *genv,
name = (Scheme_Object *)b->key;
/* If the name is directly provided, no need for indirect... */
for (j = 0; j < exvcount; j++) {
for (j = start; j < end; j++) {
if (SAME_OBJ(name, exsns[j]))
break;
}
if (j == exvcount)
if (j == end)
exis[count++] = name;
}
}
@ -9099,6 +9146,14 @@ static Scheme_Object *write_module(Scheme_Object *obj)
}
l = cons(v, l);
count = m->num_indirect_syntax_provides;
l = cons(scheme_make_integer(count), l);
v = scheme_make_vector(count, NULL);
for (i = 0; i < count; i++) {
SCHEME_VEC_ELS(v)[i] = m->indirect_syntax_provides[i];
}
l = cons(v, l);
count = m->num_indirect_et_provides;
l = cons(scheme_make_integer(count), l);
v = scheme_make_vector(count, NULL);
@ -9249,6 +9304,24 @@ static Scheme_Object *read_module(Scheme_Object *obj)
count = SCHEME_INT_VAL(nie);
if (!SCHEME_VECTORP(ie) || (SCHEME_VEC_SIZE(ie) != count)) return_NULL();
v = MALLOC_N(Scheme_Object *, count);
for (i = 0; i < count; i++) {
v[i] = SCHEME_VEC_ELS(ie)[i];
}
m->indirect_syntax_provides = v;
m->num_indirect_syntax_provides = count;
if (!SCHEME_PAIRP(obj)) return_NULL();
ie = SCHEME_CAR(obj);
obj = SCHEME_CDR(obj);
if (!SCHEME_PAIRP(obj)) return_NULL();
nie = SCHEME_CAR(obj);
obj = SCHEME_CDR(obj);
count = SCHEME_INT_VAL(nie);
if (!SCHEME_VECTORP(ie) || (SCHEME_VEC_SIZE(ie) != count)) return_NULL();
v = MALLOC_N(Scheme_Object *, count);
for (i = 0; i < count; i++) {

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->indirect_provides);
gcMARK(m->indirect_syntax_provides);
gcMARK(m->et_provide_protects);
gcMARK(m->et_indirect_provides);
@ -2390,6 +2392,8 @@ static int module_val_FIXUP(void *p) {
gcFIXUP(m->provide_protects);
gcFIXUP(m->indirect_provides);
gcFIXUP(m->indirect_syntax_provides);
gcFIXUP(m->et_provide_protects);
gcFIXUP(m->et_indirect_provides);

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

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

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

@ -5,7 +5,7 @@
/************************************************************************/
/************************************************************************/
/************************************************************************/
#define MZRT_INTERNAL
#include "mzrt.h"
#include "schgc.h"
@ -43,29 +43,30 @@ void mzrt_set_user_break_handler(void (*user_break_handler)(int))
#endif
}
static void segfault_handler(int signal_num) {
static void rungdb() {
#ifdef WIN32
#else
pid_t pid = getpid();
char buffer[500];
char buf[500];
signal(SIGSEGV, segfault_handler);
char outbuffer[100];
char inbuffer[10];
fprintf(stderr, "%i %i resume(r)/gdb(d)/exit(e)?\n", signal_num, pid);
fprintf(stderr, "pid # %i resume(r)/gdb(d)/exit(e)?\n", pid);
fflush(stderr);
while(read(fileno(stdin), buf, 100) <= 0){
if(errno != EINTR){
fprintf(stderr, "\nCould not read response, sleeping for 20 seconds.\n");
while(1) {
while(read(fileno(stdin), inbuffer, 10) <= 0){
if(errno != EINTR){
fprintf(stderr, "Error detected %i\n", errno);
}
}
switch(buf[0]) {
switch(inbuffer[0]) {
case 'r':
return;
break;
case 'd':
snprintf(buffer, 500, "xterm -e gdb ./mzschemecgc %d &", pid);
fprintf(stderr, "%i %i Launching GDB", signal_num, pid);
system(buffer);
snprintf(outbuffer, 100, "xterm -e gdb ./mzscheme3m %d &", pid);
fprintf(stderr, "%s\n", outbuffer);
system(outbuffer);
break;
case 'e':
default:
@ -76,6 +77,13 @@ static void segfault_handler(int signal_num) {
#endif
}
static void segfault_handler(int signal_num) {
pid_t pid = getpid();
fprintf(stderr, "sig# %i pid# %i\n", signal_num, pid);
rungdb();
}
void mzrt_set_segfault_debug_handler()
{
#ifdef WIN32
@ -138,42 +146,64 @@ MZ_INLINE uint32_t mzrt_atomic_incr_32(volatile unsigned int *counter) {
/***********************************************************************/
/* Threads */
/***********************************************************************/
typedef struct mzrt_thread_stub_data {
void * (*start_proc)(void *);
void *data;
mz_proc_thread *thread;
} mzrt_thread_stub_data;
struct mz_proc_thread {
#ifdef WIN32
HANDLE threadid;
#else
pthread_t threadid;
#endif
};
void *mzrt_thread_stub(void *data){
mzrt_thread_stub_data *stub_data = (mzrt_thread_stub_data*) data;
void * (*start_proc)(void *) = stub_data->start_proc;
void *start_proc_data = stub_data->data;
proc_thread_self = stub_data->thread;
int mz_proc_thread_self() {
free(data);
return start_proc(start_proc_data);
}
unsigned int mz_proc_thread_self() {
#ifdef WIN32
#error !!!mz_proc_thread_id not implemented!!!
#else
return (int) pthread_self();
return (unsigned int) pthread_self();
#endif
}
int mz_proc_thread_id(mz_proc_thread* thread) {
unsigned int mz_proc_thread_id(mz_proc_thread* thread) {
return (int) thread->threadid;
return (unsigned int) thread->threadid;
}
mz_proc_thread* mzrt_proc_first_thread_init() {
/* initialize mz_proc_thread struct for first thread myself that wasn't created with mz_proc_thread_create,
* so it can communicate with other mz_proc_thread_created threads via pt_mboxes */
mz_proc_thread *thread = (mz_proc_thread*)malloc(sizeof(mz_proc_thread));
thread->mbox = pt_mbox_create();
thread->threadid = mz_proc_thread_self();
proc_thread_self = thread;
return thread;
}
mz_proc_thread* mz_proc_thread_create(mz_proc_thread_start start_proc, void* data) {
mz_proc_thread *thread = (mz_proc_thread*)malloc(sizeof(mz_proc_thread));
#ifdef WIN32
# ifndef MZ_PRECISE_GC
#ifdef MZ_PRECISE_GC
mzrt_thread_stub_data *stub_data = (mzrt_thread_stub_data*)malloc(sizeof(mzrt_thread_stub_data));
thread->mbox = pt_mbox_create();
stub_data->start_proc = start_proc;
stub_data->data = data;
stub_data->thread = thread;
# ifdef WIN32
thread->threadid = CreateThread(NULL, 0, start_proc, data, 0, NULL);
# else
thread->threadid = CreateThread(NULL, 0, start_proc, data, 0, NULL);
pthread_create(&thread->threadid, NULL, mzrt_thread_stub, stub_data);
# endif
#else
# ifndef MZ_PRECISE_GC
GC_pthread_create(&thread->threadid, NULL, start_proc, data);
# ifdef WIN32
thread->threadid = GC_CreateThread(NULL, 0, start_proc, data, 0, NULL);
# else
pthread_create(&thread->threadid, NULL, start_proc, data);
GC_pthread_create(&thread->threadid, NULL, start_proc, data);
# endif
#endif
return thread;
@ -245,7 +275,7 @@ struct mzrt_mutex {
};
int mzrt_mutex_create(mzrt_mutex **mutex) {
*mutex = malloc(sizeof(mzrt_mutex));
*mutex = malloc(sizeof(struct mzrt_mutex));
return pthread_mutex_init(&(*mutex)->mutex, NULL);
}
@ -265,6 +295,91 @@ int mzrt_mutex_destroy(mzrt_mutex *mutex) {
return pthread_mutex_destroy(&mutex->mutex);
}
struct mzrt_cond {
pthread_cond_t cond;
};
int mzrt_cond_create(mzrt_cond **cond) {
*cond = malloc(sizeof(struct mzrt_cond));
return pthread_cond_init(&(*cond)->cond, NULL);
}
int mzrt_cond_wait(mzrt_cond *cond, mzrt_mutex *mutex) {
return pthread_cond_wait(&cond->cond, &mutex->mutex);
}
int mzrt_cond_timedwait(mzrt_cond *cond, mzrt_mutex *mutex, long seconds, long nanoseconds) {
struct timespec timeout;
timeout.tv_sec = seconds;
timeout.tv_nsec = nanoseconds;
return pthread_cond_timedwait(&cond->cond, &mutex->mutex, &timeout);
}
int mzrt_cond_signal(mzrt_cond *cond) {
return pthread_cond_signal(&cond->cond);
}
int mzrt_cond_broadcast(mzrt_cond *cond) {
return pthread_cond_broadcast(&cond->cond);
}
int mzrt_cond_destroy(mzrt_cond *cond) {
return pthread_cond_destroy(&cond->cond);
}
/****************** PROCESS THREAD MAIL BOX *******************************/
pt_mbox *pt_mbox_create() {
pt_mbox *mbox = (pt_mbox *)malloc(sizeof(pt_mbox));
mbox->count = 0;
mbox->in = 0;
mbox->out = 0;
mzrt_mutex_create(&mbox->mutex);
mzrt_cond_create(&mbox->nonempty);
mzrt_cond_create(&mbox->nonfull);
return mbox;
}
void pt_mbox_send(pt_mbox *mbox, int type, void *payload, pt_mbox *origin) {
mzrt_mutex_lock(mbox->mutex);
while ( mbox->count == 5 ) {
mzrt_cond_wait(mbox->nonfull, mbox->mutex);
}
mbox->queue[mbox->in].type = type;
mbox->queue[mbox->in].payload = payload;
mbox->queue[mbox->in].origin = origin;
mbox->in = (mbox->in + 1) % 5;
mbox->count++;
mzrt_cond_signal(mbox->nonempty);
mzrt_mutex_unlock(mbox->mutex);
}
void pt_mbox_recv(pt_mbox *mbox, int *type, void **payload, pt_mbox **origin){
mzrt_mutex_lock(mbox->mutex);
while ( mbox->count == 0 ) {
mzrt_cond_wait(mbox->nonempty, mbox->mutex);
}
*type = mbox->queue[mbox->out].type;
*payload = mbox->queue[mbox->out].payload;
*origin = mbox->queue[mbox->out].origin;
mbox->out = (mbox->out + 1) % 5;
mbox->count--;
mzrt_cond_signal(mbox->nonfull);
mzrt_mutex_unlock(mbox->mutex);
}
void pt_mbox_send_recv(pt_mbox *mbox, int type, void *payload, pt_mbox *origin, int *return_type, void **return_payload) {
pt_mbox *return_origin;
pt_mbox_send(mbox, type, payload, origin);
pt_mbox_recv(origin, return_type, return_payload, &return_origin);
}
void pt_mbox_destroy(pt_mbox *mbox) {
mzrt_mutex_destroy(mbox->mutex);
mzrt_cond_destroy(mbox->nonempty);
mzrt_cond_destroy(mbox->nonfull);
free(mbox);
}
#ifdef MZ_XFORM
END_XFORM_SUSPEND;
@ -410,6 +525,35 @@ int mzrt_mutex_destroy(mzrt_mutex *mutex) {
return 0;
}
struct mzrt_cond {
pthread_cond_t cond;
};
int mzrt_cond_create(mzrt_cond **cond) {
*cond = malloc(sizeof(mzrt_cond));
return pthread_cond_init(&(*cond)->cond, NULL);
}
int mzrt_cond_wait(mzrt_cond *cond, mzrt_mutex *mutex) {
return pthread_cond_wait(&cond->cond, &mutex->mutex);
}
int mzrt_cond_timedwait(mzrt_cond *cond, mzrt_mutex *mutex) {
return pthread_cond_timedwait(&cond->cond, &mutex->mutex);
}
int mzrt_cond_signal(mzrt_cond *cond) {
return pthread_cond_signal(&cond->cond);
}
int mzrt_cond_broadcast(mzrt_cond *cond) {
return pthread_cond_broadcast(&cond->cond);
}
int mzrt_cond_destroy(mzrt_cond *cond) {
return pthread_cond_destroy(&cond->cond);
}
#ifdef MZ_XFORM
END_XFORM_SUSPEND;
#endif

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 ********************************/
/* mzrt_threads.c */
typedef struct mz_proc_thread mz_proc_thread; /* OPAQUE DEFINITION */
typedef struct mz_proc_thread {
#ifdef WIN32
HANDLE threadid;
#else
pthread_t threadid;
#endif
struct pt_mbox *mbox;
} mz_proc_thread;
#ifdef WIN32
typedef DWORD (WINAPI *mz_proc_thread_start)(void*);
@ -31,13 +39,14 @@ typedef DWORD (WINAPI *mz_proc_thread_start)(void*);
typedef void *(mz_proc_thread_start)(void*);
#endif
mz_proc_thread* mzrt_proc_first_thread_init();
mz_proc_thread* mz_proc_thread_create(mz_proc_thread_start*, void* data);
void *mz_proc_thread_wait(mz_proc_thread *thread);
void mzrt_sleep(int seconds);
int mz_proc_thread_self();
int mz_proc_thread_id(mz_proc_thread* thread);
unsigned int mz_proc_thread_self();
unsigned int mz_proc_thread_id(mz_proc_thread* thread);
/****************** THREAD RWLOCK ******************************************/
/* mzrt_rwlock_*.c */
@ -58,6 +67,37 @@ int mzrt_mutex_trylock(mzrt_mutex *mutex);
int mzrt_mutex_unlock(mzrt_mutex *mutex);
int mzrt_mutex_destroy(mzrt_mutex *mutex);
/****************** THREAD COND *******************************************/
typedef struct mzrt_cond mzrt_cond; /* OPAQUE DEFINITION */
int mzrt_cond_create(mzrt_cond **cond);
int mzrt_cond_wait(mzrt_cond *cond, mzrt_mutex *mutex);
int mzrt_cond_timedwait(mzrt_cond *cond, mzrt_mutex *mutex, long seconds, long nanoseconds);
int mzrt_cond_signal(mzrt_cond *cond);
int mzrt_cond_broadcast(mzrt_cond *cond);
int mzrt_cond_destroy(mzrt_cond *cond);
/****************** PROCESS THREAD MAIL BOX *******************************/
typedef struct pt_mbox_msg {
int type;
void *payload;
struct pt_mbox *origin;
} pt_mbox_msg;
typedef struct pt_mbox {
struct pt_mbox_msg queue[5];
int count;
int in;
int out;
mzrt_mutex *mutex;
mzrt_cond *nonempty;
mzrt_cond *nonfull;
} pt_mbox;
pt_mbox *pt_mbox_create();
void pt_mbox_send(pt_mbox *mbox, int type, void *payload, pt_mbox *origin);
void pt_mbox_recv(pt_mbox *mbox, int *type, void **payload, pt_mbox **origin);
void pt_mbox_send_recv(pt_mbox *mbox, int type, void *payload, pt_mbox *origin, int *return_type, void **return_payload);
void pt_mbox_destroy(pt_mbox *mbox);
#endif

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

@ -1,10 +1,17 @@
#include "schpriv.h"
/* READ ONLY SHARABLE GLOBALS */
static Scheme_Object *place_main_symbol;
#ifdef MZ_USE_PLACES
#include "mzrt.h"
mz_proc_thread *scheme_master_proc_thread;
THREAD_LOCAL mz_proc_thread *proc_thread_self;
Scheme_Object *scheme_place(int argc, Scheme_Object *args[]);
static Scheme_Object *scheme_place_wait(int argc, Scheme_Object *args[]);
static Scheme_Object *scheme_place_sleep(int argc, Scheme_Object *args[]);
@ -47,9 +54,10 @@ void scheme_init_place(Scheme_Env *env)
register_traversers();
#endif
place_main_symbol = scheme_intern_symbol("place-main");
plenv = scheme_primitive_module(scheme_intern_symbol("#%place"), env);
PLACE_PRIM_W_ARITY("place", scheme_place, 1, 1, plenv);
PLACE_PRIM_W_ARITY("place", scheme_place, 1, 2, plenv);
PLACE_PRIM_W_ARITY("place-sleep", scheme_place_sleep, 1, 1, plenv);
PLACE_PRIM_W_ARITY("place-wait", scheme_place_wait, 1, 1, plenv);
PLACE_PRIM_W_ARITY("place?", scheme_place_p, 1, 1, plenv);
@ -66,7 +74,10 @@ void scheme_init_place(Scheme_Env *env)
/* FIXME this struct probably will need to be garbage collected as stuff
* is added to it */
typedef struct Place_Start_Data {
int argc;
Scheme_Object *thunk;
Scheme_Object *module;
Scheme_Object *channel;
Scheme_Object *current_library_collection_paths;
} Place_Start_Data;
@ -98,7 +109,17 @@ Scheme_Object *scheme_place(int argc, Scheme_Object *args[]) {
/* pass critical info to new place */
place_data = MALLOC_ONE(Place_Start_Data);
place_data->thunk = args[0];
place_data->argc = argc;
if (argc == 1) {
place_data->thunk = args[0];
}
else if (argc == 2 ) {
place_data->module = args[0];
place_data->channel = args[1];
}
else {
scheme_wrong_count_m("place", 1, 2, argc, args, 0);
}
collection_paths = scheme_current_library_collection_paths(0, NULL);
place_data->current_library_collection_paths = collection_paths;
@ -133,7 +154,7 @@ static void load_namespace_utf8(Scheme_Object *namespace_name) {
Scheme_Object *a[1];
Scheme_Thread * volatile p;
mz_jmp_buf * volatile saved_error_buf;
mz_jmp_buf volatile new_error_buf;
mz_jmp_buf new_error_buf;
nsreq = scheme_builtin_value("namespace-require");
a[0] = scheme_make_pair(scheme_intern_symbol("lib"),
@ -147,11 +168,41 @@ static void load_namespace_utf8(Scheme_Object *namespace_name) {
p->error_buf = saved_error_buf;
}
Scheme_Object *scheme_places_deep_copy(Scheme_Object *so)
{
Scheme_Object *new_so = so;
if (SCHEME_INTP(so)) {
return so;
}
switch (so->type) {
case scheme_char_string_type: /*43*/
new_so = scheme_make_sized_offset_char_string(SCHEME_CHAR_STR_VAL(so), 0, SCHEME_CHAR_STRLEN_VAL(so), 1);
break;
case scheme_unix_path_type:
new_so = scheme_make_sized_offset_path(SCHEME_BYTE_STR_VAL(so), 0, SCHEME_BYTE_STRLEN_VAL(so), 1);
break;
case scheme_symbol_type:
{
Scheme_Symbol *sym = (Scheme_Symbol *)so;
new_so = scheme_intern_exact_symbol(sym->s, sym->len);
}
break;
case scheme_resolved_module_path_type:
abort();
break;
default:
abort();
break;
}
return new_so;
}
static void *place_start_proc(void *data_arg) {
void *stack_base;
Scheme_Object *thunk;
Place_Start_Data *place_data;
Scheme_Object *a[1];
Scheme_Object *a[2];
int ptid;
ptid = mz_proc_thread_self();
@ -165,21 +216,75 @@ static void *place_start_proc(void *data_arg) {
null_out_runtime_globals();
/* scheme_make_thread behaves differently if the above global vars are not null */
#ifdef MZ_PRECISE_GC
GC_construct_child_gc();
#endif
scheme_place_instance_init(stack_base);
a[0] = place_data->current_library_collection_paths;
scheme_current_library_collection_paths(1, a);
load_namespace("scheme/init");
thunk = place_data->thunk;
if (place_data->argc == 1)
{
load_namespace("scheme/init");
thunk = place_data->thunk;
scheme_apply(thunk, 0, NULL);
stack_base = NULL;
} else {
Scheme_Object *place_main;
a[0] = scheme_places_deep_copy(place_data->module);
a[1] = place_main_symbol;
place_main = scheme_dynamic_require(2, a);
scheme_apply(thunk, 0, NULL);
stack_base = NULL;
a[0] = scheme_places_deep_copy(place_data->channel);
scheme_apply(place_main, 1, a);
}
return scheme_true;
}
#ifdef MZ_PRECISE_GC
static void *master_scheme_place(void *data) {
mz_proc_thread *myself;
myself = proc_thread_self;
GC_switch_in_master_gc();
while(1) {
int recv_type;
void *recv_payload;
pt_mbox *origin;
Scheme_Object *o;
Scheme_Object *copied_o;
pt_mbox_recv(myself->mbox, &recv_type, &recv_payload, &origin);
switch(recv_type) {
case 1:
copied_o = scheme_places_deep_copy((Scheme_Object *)recv_payload);
o = scheme_intern_resolved_module_path_worker(copied_o);
pt_mbox_send(origin, 2, (void *) o, NULL);
break;
case 3:
{
Scheme_Symbol_Parts *parts;
parts = (Scheme_Symbol_Parts *) recv_payload;
o = (Scheme_Object *)scheme_intern_exact_symbol_in_table_worker(parts->table, parts->kind, parts->name, parts->len);
pt_mbox_send(origin, 4, (void *) o, NULL);
}
break;
case 5:
break;
}
}
return NULL;
}
void spawn_master_scheme_place() {
mzrt_proc_first_thread_init();
scheme_master_proc_thread = mz_proc_thread_create(master_scheme_place, NULL);
}
#endif
/*========================================================================*/
/* precise GC traversers */

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: */
typedef void (*finalizer_function)(void *p, void *data);
static int traversers_registered;
static Finalizations **save_fns_ptr;
static THREAD_LOCAL Finalizations **save_fns_ptr;
static void add_finalizer(void *v, void (*f)(void*,void*), void *data,
int prim, int ext,

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_stx(Scheme_Env *env);
void scheme_init_module(Scheme_Env *env);
void scheme_init_module_path_table(void);
void scheme_init_port(Scheme_Env *env);
void scheme_init_port_fun(Scheme_Env *env);
void scheme_init_network(Scheme_Env *env);
@ -356,6 +357,9 @@ extern THREAD_LOCAL Scheme_Thread *scheme_first_thread;
#define scheme_jumping_to_continuation (scheme_current_thread->cjs.jumping_to_continuation)
#define scheme_multiple_count (scheme_current_thread->ku.multiple.count)
#define scheme_multiple_array (scheme_current_thread->ku.multiple.array)
#include "mzrt.h"
extern mz_proc_thread *scheme_master_proc_thread;
extern THREAD_LOCAL mz_proc_thread *proc_thread_self;
#endif
typedef struct Scheme_Thread_Set {
@ -2557,6 +2561,10 @@ typedef struct Scheme_Module
Scheme_Object **indirect_provides; /* symbols (internal names) */
int num_indirect_provides;
/* Only if needed to reconstruct the renaming: */
Scheme_Object **indirect_syntax_provides; /* symbols (internal names) */
int num_indirect_syntax_provides;
char *et_provide_protects; /* 1 => protected, 0 => not */
Scheme_Object **et_indirect_provides; /* symbols (internal names) */
int num_indirect_et_provides;
@ -2683,6 +2691,7 @@ Scheme_Object *scheme_modidx_shift(Scheme_Object *modidx,
Scheme_Object *shift_to_modidx);
Scheme_Object *scheme_intern_resolved_module_path(Scheme_Object *o);
Scheme_Object *scheme_intern_resolved_module_path_worker(Scheme_Object *o);
Scheme_Object *scheme_hash_module_variable(Scheme_Env *env, Scheme_Object *modidx,
Scheme_Object *stxsym, Scheme_Object *insp,
@ -3080,6 +3089,7 @@ int scheme_hash_tree_equal_rec(Scheme_Hash_Tree *t1, Scheme_Hash_Tree *t2, void
void scheme_set_root_param(int p, Scheme_Object *v);
Scheme_Object *scheme_intern_exact_symbol_in_table_worker(Scheme_Hash_Table *symbol_table, int kind, const char *name, unsigned int len);
Scheme_Object *scheme_intern_exact_parallel_symbol(const char *name, unsigned int len);
Scheme_Object *scheme_symbol_append(Scheme_Object *s1, Scheme_Object *s2);
Scheme_Object *scheme_copy_list(Scheme_Object *l);
@ -3111,13 +3121,23 @@ Scheme_Object *scheme_current_library_collection_paths(int argc, Scheme_Object *
/* places */
/*========================================================================*/
#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
typedef struct Scheme_Symbol_Parts {
Scheme_Hash_Table *table;
int kind;
unsigned int len;
const char *name;
} Scheme_Symbol_Parts;
#endif
typedef struct Scheme_Place {
Scheme_Object so;
void *proc_thread;
} Scheme_Place;
Scheme_Env *scheme_place_instance_init();
void spawn_master_scheme_place();
Scheme_Object *scheme_places_deep_copy(Scheme_Object *so);
/*========================================================================*/
/* engine */

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

@ -13,12 +13,12 @@
consistently.)
*/
#define MZSCHEME_VERSION "4.1.3.4"
#define MZSCHEME_VERSION "4.1.3.5"
#define MZSCHEME_VERSION_X 4
#define MZSCHEME_VERSION_Y 1
#define MZSCHEME_VERSION_Z 3
#define MZSCHEME_VERSION_W 4
#define MZSCHEME_VERSION_W 5
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

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_intern_exact_symbol_in_table(Scheme_Hash_Table *symbol_table, int kind, const char *name, unsigned int len)
scheme_intern_exact_symbol_in_table_worker(Scheme_Hash_Table *symbol_table, int kind, const char *name, unsigned int len)
{
Scheme_Object *sym;
@ -392,6 +392,27 @@ scheme_intern_exact_symbol_in_table(Scheme_Hash_Table *symbol_table, int kind, c
return sym;
}
Scheme_Object *
scheme_intern_exact_symbol_in_table(Scheme_Hash_Table *symbol_table, int kind, const char *name, unsigned int len)
{
#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
mz_proc_thread *self;
self = proc_thread_self;
if ( scheme_master_proc_thread && scheme_master_proc_thread != proc_thread_self ) {
int return_msg_type;
void *return_payload;
Scheme_Symbol_Parts parts;
parts.table = symbol_table;
parts.kind = kind;
parts.len = len;
parts.name = name;
pt_mbox_send_recv(scheme_master_proc_thread->mbox, 3, &parts, self->mbox, &return_msg_type, &return_payload);
return (Scheme_Object*) return_payload;
}
#endif
return scheme_intern_exact_symbol_in_table_worker(symbol_table, kind, name, len);
}
Scheme_Object *
scheme_intern_exact_symbol(const char *name, unsigned int len)
{

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;
#endif
#if defined(MZ_PRECISE_GC) || defined(USE_SENORA_GC)
#if defined(MZ_PRECISE_GC)
GC_set_get_thread_stack_base(scheme_get_current_thread_stack_start);
#endif
process->stack_start = stack_base;

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

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

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

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

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

@ -20,8 +20,8 @@ APPLICATION ICON DISCARDABLE "mred.ico"
//
VS_VERSION_INFO VERSIONINFO
FILEVERSION 4,1,3,4
PRODUCTVERSION 4,1,3,4
FILEVERSION 4,1,3,5
PRODUCTVERSION 4,1,3,5
FILEFLAGSMASK 0x3fL
#ifdef _DEBUG
FILEFLAGS 0x1L
@ -39,11 +39,11 @@ BEGIN
VALUE "CompanyName", "PLT Scheme Inc.\0"
VALUE "FileDescription", "PLT Scheme GUI application\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 "OriginalFilename", "MrEd.exe\0"
VALUE "ProductName", "PLT Scheme\0"
VALUE "ProductVersion", "4, 1, 3, 4\0"
VALUE "ProductVersion", "4, 1, 3, 5\0"
END
END
BLOCK "VarFileInfo"

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

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

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

@ -1,19 +1,19 @@
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}'
}
MzCOM.MzObj = s 'MzObj Class'
{
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
{
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'
ForceRemove 'Programmable'
LocalServer32 = s '%MODULE%'

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

@ -29,8 +29,8 @@ APPLICATION ICON DISCARDABLE "mzscheme.ico"
//
VS_VERSION_INFO VERSIONINFO
FILEVERSION 4,1,3,4
PRODUCTVERSION 4,1,3,4
FILEVERSION 4,1,3,5
PRODUCTVERSION 4,1,3,5
FILEFLAGSMASK 0x3fL
#ifdef _DEBUG
FILEFLAGS 0x1L
@ -48,11 +48,11 @@ BEGIN
VALUE "CompanyName", "PLT Scheme Inc.\0"
VALUE "FileDescription", "PLT Scheme application\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 "OriginalFilename", "mzscheme.exe\0"
VALUE "ProductName", "PLT Scheme\0"
VALUE "ProductVersion", "4, 1, 3, 4\0"
VALUE "ProductVersion", "4, 1, 3, 5\0"
END
END
BLOCK "VarFileInfo"

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

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