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

toward deterministic bytecode generation

Browse Source 
Progress toward making the bytecode compiler deterministic, so that a
fresh `make base` always produces exactly the same bytecode from the
same sources. Most changes involve avoiding hash-table order
dependencies and adjusting scope identity. The namespace used to load
a reader extension is also better defined. Plus many other little
changes.

The identity of a scope that is unmarshaled from a bytecode file now
incorporates the hash of the file, and the relative order of scopes is
preserved in a bytecode file. This combination allows compilation to
start with modules that loaded and compiled in different orders
(including delayed loading of bytecode fragments within one file).

Formerly, a reader extension triggered by `#lang` or `#reader` was
loaded in whatever namespace happens to be current. That's
unpredictable and can pollute a module build at the level of bytecode.
To help make builds deterministic, reader extensions are now loaded in
a root namespace of the current namespace.

Deterministic compilation in general relies on deterministic macros.
The two most common ways for a macro to be non-deterministic are by
using `gensym` (use `generate-temporaries`, instead) and by using an
unsorted hash-table traversal (don't do that).

At this point, bytecode generation is unlikely to be completely
deterministic, since I uncovered non-determinism mostly by iterating
attempts over the base collections. For now, the intent is not to
provide guarantees outside of the compilation of the base collections
--- but "more deterministic" is likely to be useful in the short run,
and we can improve further in the long run.
This commit is contained in:
Matthew Flatt 2015-08-05 16:25:08 -06:00
parent a55eed9718
commit 2661d46929
45 changed files with 2476 additions and 1760 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/base/info.rkt
View File

@ -12,7 +12,7 @@
(define collection 'multi)
(define version "6.2.900.6")
(define version "6.2.900.8")
(define deps `("racket-lib"
["racket" #:version ,version]))

12
pkgs/racket-doc/scribblings/raco/make.scrbl
View File

@ -497,6 +497,18 @@ result will not call @racket[proc] with @racket['unlock].)
compilations of the same racket source files in multiple places.
}
@defproc[(install-module-hashes! [bstr btyes?]
[start exact-nonnegatve-integer? 0]
[end exact-nonnegatve-integer? (bytes-length bstr)])
void?]{
Adjusts the bytecode representation in @racket[bstr] (from bytes
@racket[start] to @racket[end]) to install a hash code, including any
submodules within the region. The existing representation should have
zero bytes in place of each hash string, which is what @racket[write]
produces for a compiled form.
@history[#:added "6.2.900.8"]}
@; ----------------------------------------------------------------------

25
pkgs/racket-doc/scribblings/reference/hashes.scrbl
View File

@ -355,13 +355,15 @@ procedure and mutability of @racket[hash].}
@defproc[(hash-map [hash hash?]
[proc (any/c any/c . -> . any/c)])
[proc (any/c any/c . -> . any/c)]
[try-order? any/c #f])
(listof any/c)]{
Applies the procedure @racket[proc] to each element in
@racket[hash] in an unspecified order, accumulating the results
into a list. The procedure @racket[proc] is called each time with a
key and its value.
key and its value, and the procedure's individual results appear in
order in the result list.
If a hash table is extended with new keys (either through
@racket[proc] or by another thread) while a @racket[hash-map] or
@ -372,7 +374,14 @@ change does not affect a traversal if the key has been seen already,
otherwise the traversal skips a deleted key or uses the remapped key's
new value.
@see-also-concurrency-caveat[]}
If @racket[try-order?] is true, then the order of keys and values
passed to @racket[proc] is normalized under certain circumstances,
such as when the keys are all symbols and @racket[hash] is not an
@tech{impersonator}.
@see-also-concurrency-caveat[]
@history[#:changed "6.2.900.8" @elem{Added the @racket[try-order?] argument.}]}
@defproc[(hash-keys [hash hash?])
(listof any/c)]{
@ -396,15 +405,19 @@ See @racket[hash-map] for information about modifying @racket[hash]
during @racket[hash->list]. @see-also-concurrency-caveat[]}
@defproc[(hash-for-each [hash hash?]
[proc (any/c any/c . -> . any)])
[proc (any/c any/c . -> . any)]
[try-order? any/c #f])
void?]{
Applies @racket[proc] to each element in @racket[hash] (for the
side-effects of @racket[proc]) in an unspecified order. The procedure
@racket[proc] is called each time with a key and its value.
See @racket[hash-map] for information about modifying @racket[hash]
within @racket[proc]. @see-also-concurrency-caveat[]}
See @racket[hash-map] for information about @racket[try-order?] and
about modifying @racket[hash] within @racket[proc].
@see-also-concurrency-caveat[]
@history[#:changed "6.2.900.8" @elem{Added the @racket[try-order?] argument.}]}
@defproc[(hash-count [hash hash?])

18
pkgs/racket-doc/scribblings/reference/namespaces.scrbl
View File

@ -21,16 +21,22 @@ otherwise.}
@defproc[(make-empty-namespace) namespace?]{
Creates a new namespace that is empty, and whose @tech{module
Creates a new @tech{namespace} that is empty, and whose @tech{module
registry} contains no mappings. The namespace's @tech{base phase} is
the same as the @tech{base phase} of the @tech{current
namespace}. Attach modules from an existing namespace to the new one
with @racket[namespace-attach-module].}
with @racket[namespace-attach-module].
The new namespace is associated with a new @deftech{root namespace},
which has the same @tech{module registry} as the returned namespace
and has a @tech{base phase} of 0. The new @tech{root namespace} is
the same as the returned namespace if both have @tech{base phase} 0.}
@defproc[(make-base-empty-namespace) namespace?]{
Creates a new empty namespace, but with @racketmodname[racket/base]
Creates a new empty @tech{namespace} like @racket[make-empty-namespace],
but with @racketmodname[racket/base]
attached. The namespace's @tech{base phase} is the same as the
@tech{phase} in which the @racket[make-base-empty-namespace]
function was created.}
@ -38,7 +44,8 @@ function was created.}
@defproc[(make-base-namespace) namespace?]{
Creates a new namespace with @racketmodname[racket/base] attached and
Creates a new @tech{namespace} like @racket[make-empty-namespace], but
with @racketmodname[racket/base] attached and
@racket[require]d into the top-level environment. The namespace's
@tech{base phase} is the same as the @tech{phase} in which the
@racket[make-base-namespace] function was created.}
@ -62,7 +69,8 @@ Returns @racket[#t] if @racket[v] is a namespace-anchor value,
@defproc[(namespace-anchor->empty-namespace [a namespace-anchor?]) namespace?]{
Returns an empty namespace that shares a @tech{module registry} with
Returns an empty namespace that shares a @tech{module registry}
and @tech{root namespace} with
the source of the anchor, and whose @tech{base phase} is the
@tech{phase} in which the anchor was created.

4
pkgs/racket-doc/scribblings/reference/read.scrbl
View File

@ -121,7 +121,9 @@ See @secref["readtables"] for an extended example that uses
(or/c (any/c any/c . -> . any) #f)]{
Reads from @racket[in] in the same way as @racket[read], but stopping as
soon as a @tech{reader language} (or its absence) is determined.
soon as a @tech{reader language} (or its absence) is determined, and
using the @tech{current namespace} to load a reader module instead
of its @tech{root namespace} (if those are different).
A @deftech{reader language} is specified by @litchar{#lang} or
@litchar{#!} (see @secref["parse-reader"]) at the beginning of the

3
pkgs/racket-doc/scribblings/reference/reader.scrbl
View File

@ -866,7 +866,8 @@ and passes it to the procedure that is the value of the
module path. The module path is passed to @racket[dynamic-require]
with either @racket['read] or @racket['read-syntax] (depending on
whether the reader is in @racket[read] or @racket[read-syntax]
mode).
mode). The module is loaded in a @tech{root namespace} of the
@tech{current namespace}.
The arity of the resulting procedure determines whether it accepts
extra source-location information: a @racketidfont{read} procedure

4
pkgs/racket-test-core/tests/racket/basic.rktl
View File

@ -2548,8 +2548,8 @@
(arity-test hash-set 3 3)
(arity-test hash-remove! 2 2)
(arity-test hash-remove 2 2)
(arity-test hash-map 2 2)
(arity-test hash-for-each 2 2)
(arity-test hash-map 2 3)
(arity-test hash-for-each 2 3)
(arity-test hash? 1 1)
(arity-test hash-eq? 1 1)
(arity-test hash-weak? 1 1)

68
pkgs/racket-test/tests/racket/deterministic-zo.rkt Normal file
View File

@ -0,0 +1,68 @@
#lang racket/base
(require syntax/modread
racket/file
compiler/compilation-path
compiler/cm)
(define (go dir collects-dir fn)
(parameterize ([current-load-relative-directory dir])
(define path (build-path dir fn))
(define stx
(check-module-form
(call-with-input-file*
path
(lambda (i)
(port-count-lines! i)
(with-module-reading-parameterization
(lambda ()
(read-syntax path i)))))
'mod
#f))
(define o (open-output-bytes))
(parameterize ([current-namespace (make-base-namespace)]
[current-write-relative-directory (cons dir collects-dir)])
(dynamic-require 'racket/private/base #f)
(write (compile stx) o))
(define bstr (get-output-bytes o))
(install-module-hashes! bstr)
bstr))
(define (check-file dir collects-dir sub-dir f)
(printf "~a\n" (build-path sub-dir f))
(define c1 (go dir collects-dir f))
(define c2 (go dir collects-dir f))
(unless (equal? c1 c2)
(call-with-output-file* "/tmp/c1" #:exists 'truncate (lambda (o) (write-bytes c1 o)))
(call-with-output-file* "/tmp/c2" #:exists 'truncate (lambda (o) (write-bytes c2 o)))
(error "failed"))
(define zo (get-compilation-bytecode-file (build-path dir f) #:modes '("compiled")))
(when (file-exists? zo)
(define c3 (file->bytes zo))
(unless (equal? c3 c1)
(call-with-output-file* "/tmp/c1" #:exists 'truncate (lambda (o) (write-bytes c1 o)))
(call-with-output-file* "/tmp/c2" #:exists 'truncate (lambda (o) (write-bytes c3 o)))
(error "failed relative to built"))))
(define (check dir [collects-dir dir] [sub-dir 'same] #:limit [limit +inf.0])
(for/fold ([limit limit]) ([f (in-list (directory-list dir))]
#:when (positive? limit))
(cond
[(and (regexp-match? #rx"[.]rkt$" f)
(file-exists? (build-path dir f)))
(check-file dir collects-dir sub-dir f)
(sub1 limit)]
[(directory-exists? (build-path dir f))
(check (build-path dir f) collects-dir (build-path sub-dir f) #:limit limit)]
[else limit])))
(define (check-one collects-dir collects file)
(check-file (build-path collects-dir collects) collects-dir collects file))
(let-values ([(dir name dir?)
(split-path
(collection-file-path "sc.rkt" "racket/private"))])
(define collects-dir (simplify-path (build-path dir 'up 'up)))
;; To check just one:
#; (check-one collects-dir "syntax" "free-vars.rkt")
(check (simplify-path collects-dir))
(void))

13
racket/collects/compiler/cm.rkt
View File

@ -31,7 +31,9 @@
parallel-lock-client
make-compile-lock
compile-lock->parallel-lock-client)
compile-lock->parallel-lock-client
install-module-hashes!)
(define cm-logger (make-logger 'compiler/cm (current-logger)))
(define (default-manager-trace-handler str)
@ -308,10 +310,13 @@
(write (list* (version)
(cons (or src-sha1 (get-source-sha1 path))
(get-dep-sha1s deps up-to-date collection-cache read-src-syntax mode roots #t #hash()))
deps)
(sort deps s-exp<?))
op)
(newline op))))))
(define (s-exp<? a b)
(string<? (format "~s" a) (format "~s" b)))
(define (format-time sec)
(let ([d (seconds->date sec)])
(format "~a-~a-~a ~a:~a:~a"
@ -459,7 +464,7 @@
(write code b)
;; Compute SHA1 over modules within bytecode
(let* ([s (get-output-bytes b)])
(install-module-hashes! s 0 (bytes-length s))
(install-module-hashes! s)
;; Write out the bytecode with module hash
(write-bytes s out)))))
;; redundant, but close as early as possible:
@ -471,7 +476,7 @@
external-deps external-module-deps reader-deps
up-to-date collection-cache read-src-syntax)))))
(define (install-module-hashes! s start len)
(define (install-module-hashes! s [start 0] [len (bytes-length s)])
(define vlen (bytes-ref s (+ start 2)))
(define mode (integer->char (bytes-ref s (+ start 3 vlen))))
(case mode

9
racket/collects/racket/contract/private/arrow-higher-order.rkt
View File

@ -1,6 +1,7 @@
#lang racket/base
(require (for-syntax racket/base
"arr-util.rkt")
"arr-util.rkt"
"helpers.rkt")
"arity-checking.rkt"
"kwd-info-struct.rkt"
"blame.rkt"
@ -151,7 +152,7 @@
[(rng-x ...) (if rngs (generate-temporaries rngs) '())])
(with-syntax ([(rng-checker-name ...)
(if rngs
(list (gensym 'rng-checker))
(list (gen-id 'rng-checker))
null)]
[(rng-checker ...)
(if rngs
@ -274,7 +275,7 @@
(arrow:check-tail-contract #'(rng-ctc ...)
#'(rng-checker-name ...)
outer-stx-gen))))])
(with-syntax ([basic-lambda-name (gensym 'basic-lambda)]
(with-syntax ([basic-lambda-name (gen-id 'basic-lambda)]
[basic-lambda #'(λ basic-params
;; Arrow contract domain checking is instrumented
;; both here, and in `arity-checking-wrapper'.
@ -290,7 +291,7 @@
(cons blame neg-party)
(let ()
pre ... basic-return)))]
[kwd-lambda-name (gensym 'kwd-lambda)]
[kwd-lambda-name (gen-id 'kwd-lambda)]
[kwd-lambda #`(λ kwd-lam-params
(with-continuation-mark
contract-continuation-mark-key

6
racket/collects/racket/contract/private/arrow.rkt
View File

@ -229,7 +229,7 @@
[(rng-x ...) (if rngs (generate-temporaries rngs) '())])
(with-syntax ([(rng-checker-name ...)
(if rngs
(list (gensym 'rng-checker))
(list (gen-id 'rng-checker))
null)]
[(rng-checker ...)
(if rngs
@ -322,7 +322,7 @@
#,(if no-rng-checking?
(outer-stx-gen #'())
(check-tail-contract #'(rng-ctc ...) #'(rng-checker-name ...) outer-stx-gen))))])
(with-syntax ([basic-lambda-name (gensym 'basic-lambda)]
(with-syntax ([basic-lambda-name (gen-id 'basic-lambda)]
[basic-lambda #'(λ basic-params
;; Arrow contract domain checking is instrumented
;; both here, and in `arity-checking-wrapper'.
@ -337,7 +337,7 @@
contract-continuation-mark-key blame
(let ()
pre ... basic-return)))]
[kwd-lambda-name (gensym 'kwd-lambda)]
[kwd-lambda-name (gen-id 'kwd-lambda)]
[kwd-lambda #`(λ kwd-lam-params
(with-continuation-mark
contract-continuation-mark-key blame

8
racket/collects/racket/contract/private/helpers.rkt
View File

@ -8,7 +8,8 @@
all-but-last
known-good-contract?
known-good-contracts
update-loc)
update-loc
gen-id)
(require setup/main-collects
racket/struct-info
@ -373,5 +374,8 @@
(free-identifier=? id (datum->syntax #'here r-id))))
(define (known-good-contracts)
(for/list ([(k v) (in-hash known-good-syms-ht)])
(for/list ([k (in-list (sort (hash-keys known-good-syms-ht) symbol<?))])
(datum->syntax #'here k)))
(define (gen-id sym)
(car (generate-temporaries (list sym))))

24
racket/collects/racket/match/compiler.rkt
View File

@ -15,17 +15,27 @@
(define vars-seen (make-parameter null))
(define (hash-on f elems #:equal? [eql #t])
(define-values (ht ref set!)
(define-values (ht h-ref h-set!)
(case eql
[(#t) (values (make-hash) hash-ref hash-set!)]
[(#f) (values (make-hasheq) hash-ref hash-set!)]))
(define keys null)
;; put all the elements e in the ht, indexed by (f e)
(for ([r
;; they need to be in the original order when they come out
(reverse elems)])
(define k (f r))
(set! ht k (cons r (ref ht k (lambda () null)))))
ht)
(h-set! ht k (cons r (h-ref ht k (lambda ()
(set! keys (cons k keys))
null)))))
;; Return a list, instead of a hash, to make order deterministic
;; based on the recorded order of keys
(for/list ([k (in-list keys)])
(cons k (hash-ref ht k))))
;; Like `hash-map`, bu for a list produced by `hash-on`:
(define (hash-on-map ht-l f)
(map (lambda (p) (f (car p) (cdr p))) ht-l))
;; generate a clause of kind k
;; for rows rows, with matched variable x and rest variable xs
@ -74,7 +84,7 @@
(let ([ht (hash-on (lambda (r)
(length (Vector-ps (Row-first-pat r)))) rows)])
(with-syntax ([(clauses ...)
(hash-map
(hash-on-map
ht
(lambda (arity rows)
(define ns (build-list arity values))
@ -123,7 +133,7 @@
[(Exact? first)
(let ([ht (hash-on (compose Exact-v Row-first-pat) block #:equal? #t)])
(with-syntax ([(clauses ...)
(hash-map
(hash-on-map
ht
(lambda (k v)
#`[(equal? #,x '#,k)
@ -188,7 +198,7 @@
(let ;; put all the rows in the hash, indexed by their constructor
([ht (hash-on (lambda (r) (pat-key (Row-first-pat r))) block)])
(with-syntax ([(clauses ...)
(hash-map
(hash-on-map
ht (lambda (k v) (gen-clause k v x xs esc)))])
#`(cond clauses ... [else (#,esc)])))]
;; the Or rule
@ -298,7 +308,7 @@
;; we use the pattern so that it can have a custom equal+hash
(define ht (hash-on (lambda (r) (Row-first-pat r)) block #:equal? #t))
(with-syntax ([(clauses ...)
(hash-map
(hash-on-map
ht (lambda (k v)
(gen-clause (Pred-pred k) v x xs esc)))])
#`(cond clauses ... [else (#,esc)]))]

9
racket/collects/racket/match/patterns.rkt
View File

@ -146,10 +146,13 @@
(define (merge l)
(cond [(null? l) null]
[(null? (cdr l)) (car l)]
[else (let ([m (make-module-identifier-mapping)])
[else (let ([m (make-module-identifier-mapping)]
[in-order null])
(for* ([ids l] [id ids])
(module-identifier-mapping-put! m id #t))
(module-identifier-mapping-map m (lambda (k v) k)))]))
(unless (module-identifier-mapping-get m id (lambda () #f))
(set! in-order (cons id in-order))
(module-identifier-mapping-put! m id #t)))
(reverse in-order))]))
;; bound-vars : Pat -> listof identifiers
(define (bound-vars p)
(cond

2
racket/collects/racket/private/define-et-al.rkt
View File

@ -81,7 +81,7 @@
[exprs (stx-cdr (stx-cdr code))])
(datum->syntax
(quote-syntax here)
`(call/ec (lambda (,var) ,@(stx->list exprs)))
`(call-with-escape-continuation (lambda (,var) ,@(stx->list exprs)))
code))
(raise-syntax-error
#f

2
racket/collects/racket/private/more-scheme.rkt
View File

@ -303,7 +303,7 @@
(lambda (stx)
(syntax-case stx ()
[(_ var body1 body ...)
(syntax/loc stx (call/cc (lambda (var) body1 body ...)))])))
(syntax/loc stx (call-with-current-continuation (lambda (var) body1 body ...)))])))
(define-syntax fluid-let
(lambda (stx)

6
racket/collects/racket/private/pre-base.rkt
View File

@ -149,6 +149,9 @@
stx)
(raise-syntax-error #f "bad syntax" stx)))))
(define-values (call/cc) call-with-current-continuation)
(define-values (call/ec) call-with-escape-continuation)
(#%provide (all-from-except "more-scheme.rkt" old-case fluid-let)
(all-from-except "misc.rkt" collection-path collection-file-path)
(all-from "define.rkt")
@ -207,4 +210,5 @@
define-struct/derived
struct-field-index
struct-copy
double-flonum?))
double-flonum?
call/cc call/ec))

2
racket/collects/racket/private/qq-and-or.rkt
View File

@ -421,7 +421,7 @@
(list (quote-syntax quote)
rest)
rest)))))))))
(let-values (((l0) (hash-map (syntax-e x) cons)))
(let-values (((l0) (hash-map (syntax-e x) cons #t)))
(let-values
(((l) (qq-hash-assocs l0 level)))
(if (eq? l0 l)

7
racket/collects/racket/private/sc.rkt
View File

@ -730,6 +730,7 @@
(let* ([ht (if proto-r
#f
(make-hasheq))]
[in-order null] ; same content as ht, but in deterministic order
[l (expander p proto-r p #t
(and proto-r (sub1 (length proto-r)))
(if proto-r
@ -742,7 +743,9 @@
l))])
(if pr
(set-mcdr! pr (cons r (mcdr pr)))
(hash-set! ht (syntax-e r) (cons (mcons r (list r)) l)))))))
(let ([pr (mcons r (list r))])
(set! in-order (cons pr in-order))
(hash-set! ht (syntax-e r) (cons pr l))))))))
#f)])
(if proto-r
`(lambda (r)
@ -766,7 +769,7 @@
;; This is a trick to minimize the syntax structure we keep:
(quote-syntax ,(datum->syntax #f '... p)))
main)))
(let ([l (apply append (hash-map ht (lambda (k v) v)))])
(let ([l in-order])
(values
;; Get list of unique vars:
(map mcar l)

2
racket/collects/setup/main.rkt
View File

@ -120,7 +120,7 @@
(let loop ([skip-zo? (null? (use-compiled-file-paths))])
(when skip-zo?
(print-bootstrapping))
((call/ec
((call-with-escape-continuation
(lambda (escape)
;; Create a new namespace, and also install load handlers
;; to check file dates, if necessary.

54
racket/collects/syntax/parse/experimental/dset.rkt Normal file
View File

@ -0,0 +1,54 @@
#lang racket/base
;; A dset is an `equal?`-based set, but it preserves order based on
;; the history of additions, so that if items are added in a
;; deterministic order, they come back out in a deterministic order.
(provide dset
dset-empty?
dset->list
dset-add
dset-union
dset-subtract
dset-filter)
(define dset
(case-lambda
[() (hash)]
[(e) (hash e 0)]))
(define (dset-empty? ds)
(zero? (hash-count ds)))
(define (dset->list ds)
(map cdr
(sort (for/list ([(k v) (in-hash ds)])
(cons v k))
<
#:key car)))
(define (dset-add ds e)
(if (hash-ref ds e #f)
ds
(hash-set ds e (hash-count ds))))
(define (dset-union ds1 ds2)
(cond
[((hash-count ds1) . > . (hash-count ds2))
(dset-union ds2 ds1)]
[else
(for/fold ([ds2 ds2]) ([e (dset->list ds1)])
(dset-add ds2 e))]))
(define (dset-subtract ds1 ds2)
;; ! takes O(size(ds2)) time !
(for/fold ([r (dset)]) ([e (in-list (dset->list ds1))])
(if (hash-ref ds2 e #f)
r
(dset-add r e))))
(define (dset-filter ds pred)
(for/fold ([r (dset)]) ([e (in-list (dset->list ds))])
(if (pred e)
(dset-add r e)
r)))

52
racket/collects/syntax/parse/experimental/template.rkt
View File

@ -1,6 +1,6 @@
#lang racket/base
(require (for-syntax racket/base
racket/set
"dset.rkt"
racket/syntax
syntax/parse/private/minimatch
racket/private/stx ;; syntax/stx
@ -229,19 +229,19 @@ instead of integers and integer vectors.
(if loc-id
(let* ([loc-sm (make-syntax-mapping 0 loc-id)]
[loc-pvar (pvar loc-sm #f #f)])
(values (set-union drivers (set loc-pvar))
(values (dset-add drivers loc-pvar)
(relocate-guide pre-guide loc-pvar)))
(values drivers pre-guide))])
(let* ([main-env (set->env drivers (hash))]
(let* ([main-env (dset->env drivers (hash))]
[guide (guide-resolve-env pre-guide main-env)])
(values guide
(index-hash->vector main-env)
props-guide))))
;; set->env : (setof env-entry) -> hash[env-entry => nat]
(define (set->env drivers init-env)
;; dset->env : (dsetof env-entry) -> hash[env-entry => nat]
(define (dset->env drivers init-env)
(for/fold ([env init-env])
([pvar (in-set drivers)]
([pvar (in-list (dset->list drivers))]
[n (in-naturals (+ 1 (hash-count init-env)))])
(hash-set env pvar n)))
@ -265,7 +265,7 @@ instead of integers and integer vectors.
(let-values ([(sub-loop-env r-uptos)
(for/fold ([env (hash)] [r-uptos null])
([new-hdrivers (in-list new-hdrivers/level)])
(let ([new-env (set->env new-hdrivers env)])
(let ([new-env (dset->env new-hdrivers env)])
(values new-env (cons (hash-count new-env) r-uptos))))])
(let ([sub-loop-vector (index-hash->vector sub-loop-env get-index)])
(vector 'dots
@ -414,7 +414,7 @@ instead of integers and integer vectors.
(define (list-guide . gs)
(foldr cons-guide '_ gs))
;; parse-t : stx nat boolean -> (values (setof env-entry) pre-guide props-guide)
;; parse-t : stx nat boolean -> (values (dsetof env-entry) pre-guide props-guide)
(define (parse-t t depth esc?)
(syntax-case t (?? ?@ unsyntax quasitemplate)
[id
@ -430,18 +430,18 @@ instead of integers and integer vectors.
[else
(let ([pvar (lookup #'id depth)])
(cond [(pvar? pvar)
(values (set pvar) pvar '_)]
(values (dset pvar) pvar '_)]
[(template-metafunction? pvar)
(wrong-syntax t "illegal use of syntax metafunction")]
[else
(wrap-props #'id (set) '_ '_)]))])]
(wrap-props #'id (dset) '_ '_)]))])]
[(mf . template)
(and (not esc?)
(identifier? #'mf)
(template-metafunction? (lookup #'mf #f)))
(let-values ([(mf) (lookup #'mf #f)]
[(drivers guide props-guide) (parse-t #'template depth esc?)])
(values (set-union (set mf) drivers)
(values (dset-add drivers mf)
(vector 'metafun mf guide)
(cons-guide '_ props-guide)))]
[(unsyntax t1)
@ -452,7 +452,7 @@ instead of integers and integer vectors.
(set-box! qval (cons (cons #'tmp t) (unbox qval)))
(let* ([fake-sm (make-syntax-mapping 0 #'tmp)]
[fake-pvar (pvar fake-sm #f #f)])
(values (set fake-pvar) (vector 'unsyntax fake-pvar) '_)))]
(values (dset fake-pvar) (vector 'unsyntax fake-pvar) '_)))]
[else
(parameterize ((quasi (car qval)))
(let-values ([(drivers guide props-guide) (parse-t #'t1 depth esc?)])
@ -479,7 +479,7 @@ instead of integers and integer vectors.
(not esc?)
(let-values ([(drivers1 guide1 props-guide1) (parse-t #'t1 depth esc?)]
[(drivers2 guide2 props-guide2) (parse-t #'t2 depth esc?)])
(values (set-union drivers1 drivers2)
(values (dset-union drivers1 drivers2)
(vector 'orelse guide1 guide2)
(list-guide '_ props-guide1 props-guide2)))]
[(head DOTS . tail)
@ -496,26 +496,26 @@ instead of integers and integer vectors.
(parse-h #'head (+ depth nesting) esc?)]
[(tdrivers tguide tprops-guide)
(parse-t tail depth esc?)])
(when (set-empty? hdrivers)
(when (dset-empty? hdrivers)
(wrong-syntax #'head "no pattern variables before ellipsis in template"))
(when (set-empty? (set-filter hdrivers (pvar/dd<=? depth)))
(when (dset-empty? (dset-filter hdrivers (pvar/dd<=? depth)))
;; FIXME: improve error message?
(let ([bad-dots
;; select the nestingth (last) ellipsis as the bad one
(stx-car (stx-drop nesting t))])
(wrong-syntax bad-dots "too many ellipses in template")))
(wrap-props t
(set-union hdrivers tdrivers)
(dset-union hdrivers tdrivers)
;; pre-guide hdrivers is (listof (setof pvar))
;; set of pvars new to each level
(let* ([hdrivers/level
(for/list ([i (in-range nesting)])
(set-filter hdrivers (pvar/dd<=? (+ depth i))))]
(dset-filter hdrivers (pvar/dd<=? (+ depth i))))]
[new-hdrivers/level
(let loop ([raw hdrivers/level] [last (set)])
(let loop ([raw hdrivers/level] [last (dset)])
(cond [(null? raw) null]
[else
(cons (set-subtract (car raw) last)
(cons (dset-subtract (car raw) last)
(loop (cdr raw) (car raw)))]))])
(vector 'dots hguide new-hdrivers/level nesting #f tguide))
(cons-guide hprops-guide (cons-guide '_ tprops-guide)))))]
@ -525,7 +525,7 @@ instead of integers and integer vectors.
[(tdrivers tguide tprops-guide)
(parse-t #'tail depth esc?)])
(wrap-props t
(set-union hdrivers tdrivers)
(dset-union hdrivers tdrivers)
(cond [(and (eq? hguide '_) (eq? tguide '_)) '_]
[hsplice? (vector 'app hguide tguide)]
[else (cons hguide tguide)])
@ -551,9 +551,9 @@ instead of integers and integer vectors.
(if (eq? guide '_) '_ (vector 'box guide))
(if (eq? props-guide '_) '_ (vector 'box props-guide))))]
[const
(wrap-props t (set) '_ '_)]))
(wrap-props t (dset) '_ '_)]))
;; parse-h : stx nat boolean -> (values (setof env-entry) boolean pre-head-guide props-guide)
;; parse-h : stx nat boolean -> (values (dsetof env-entry) boolean pre-head-guide props-guide)
(define (parse-h h depth esc?)
(syntax-case h (?? ?@ unsyntax-splicing)
[(?? t)
@ -567,7 +567,7 @@ instead of integers and integer vectors.
(not esc?)
(let-values ([(drivers1 splice?1 guide1 props-guide1) (parse-h #'t1 depth esc?)]
[(drivers2 splice?2 guide2 props-guide2) (parse-h #'t2 depth esc?)])
(values (set-union drivers1 drivers2)
(values (dset-union drivers1 drivers2)
(or splice?1 splice?2)
(vector (if (or splice?1 splice?2) 'orelse-h 'orelse)
guide1 guide2)
@ -584,7 +584,7 @@ instead of integers and integer vectors.
(set-box! qval (cons (cons #'tmp h) (unbox qval)))
(let* ([fake-sm (make-syntax-mapping 0 #'tmp)]
[fake-pvar (pvar fake-sm #f #f)])
(values (set fake-pvar) #t (vector 'unsyntax-splicing fake-pvar) '_)))]
(values (dset fake-pvar) #t (vector 'unsyntax-splicing fake-pvar) '_)))]
[else
(parameterize ((quasi (car qval)))
(let*-values ([(drivers guide props-guide) (parse-t #'t1 depth esc?)]
@ -598,10 +598,6 @@ instead of integers and integer vectors.
(let-values ([(drivers guide props-guide) (parse-t #'t depth esc?)])
(values drivers #f guide props-guide))]))
;; Note: always creates equal?-based set.
(define (set-filter s pred?)
(for/set ([el (in-set s)] #:when (pred? el)) el))
(define (lookup id depth)
(let ([v (syntax-local-value id (lambda () #f))])
(cond [(syntax-pattern-variable? v)

5
racket/collects/syntax/parse/private/rep-attrs.rkt
View File

@ -89,13 +89,16 @@ of signatures easier for reified syntax-classes.
(define count-t (make-bound-id-table))
(define attr-t (make-bound-id-table))
(define list-count (length attrss))
(define attr-keys null)
(for* ([attrs (in-list attrss)] [attr (in-list attrs)])
(define name (attr-name attr))
(define prev (bound-id-table-ref attr-t name #f))
(unless prev (set! attr-keys (cons name attr-keys)))
(bound-id-table-set! attr-t name (join-attrs attr prev))
(let ([pc (bound-id-table-ref count-t name 0)])
(bound-id-table-set! count-t name (add1 pc))))
(for/list ([a (in-list (bound-id-table-map attr-t (lambda (_ v) v)))])
(for/list ([k (in-list attr-keys)])
(define a (bound-id-table-ref attr-t k))
(if (= (bound-id-table-ref count-t (attr-name a)) list-count)
a
(attr-make-uncertain a))))

2
racket/src/racket/gc2/check-sdep.rkt
View File

@ -12,7 +12,7 @@
[(regexp-match? #rx"[.][ch]$" path)
(define-values (ts) (file-or-directory-modify-seconds path))
(define-values (sdep) (path-replace-suffix path ".sdep"))
(call/ec
(call-with-escape-continuation
(lambda (esc)
(with-continuation-mark
exception-handler-key

2
racket/src/racket/gc2/xform.rkt
View File

@ -71,7 +71,7 @@
;; In case multiple xforms run in parallel, use a lock file
;; so that only one is building.
(let ([lock-file "XFORM-LOCK"])
((call/ec
((call-with-escape-continuation
(lambda (escape)
(parameterize ([uncaught-exception-handler
(lambda (exn)

12
racket/src/racket/src/bool.c
View File

@ -858,19 +858,19 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
}
case scheme_module_index_type:
{
if (!eql->eq_for_modidx) {
Scheme_Modidx *midx1, *midx2;
# include "mzeqchk.inc"
midx1 = (Scheme_Modidx *)obj1;
midx2 = (Scheme_Modidx *)obj2;
if (is_equal(midx1->path, midx2->path, eql)) {
if (eql->eq_for_modidx
&& (SCHEME_FALSEP(midx1->path)
|| SCHEME_FALSEP(midx2->path)))
return 0;
else if (is_equal(midx1->path, midx2->path, eql)) {
obj1 = midx1->base;
obj2 = midx2->base;
goto top;
} else
return 0;
} else
return 0;
}
}
case scheme_scope_table_type:
{

2
racket/src/racket/src/compenv.c
View File

@ -944,7 +944,7 @@ Scheme_Object *scheme_hash_module_variable(Scheme_Env *env, Scheme_Object *modid
Scheme_Hash_Table *ht;
if (!env->modvars) {
ht = scheme_make_hash_table(SCHEME_hash_ptr);
ht = scheme_make_hash_table_equal_modix_eq();
env->modvars = ht;
}

3054
racket/src/racket/src/cstartup.inc
View File

File diff suppressed because it is too large Load Diff

5
racket/src/racket/src/env.c
View File

@ -999,6 +999,7 @@ scheme_new_module_env(Scheme_Env *env, Scheme_Module *m,
menv->module = m;
menv->instance_env = env;
menv->reader_env = (env->reader_env ? env->reader_env : env);
if (new_exp_module_tree) {
/* It would be nice to share the label env with `env`, but we need
@ -1065,6 +1066,7 @@ void scheme_prepare_exp_env(Scheme_Env *env)
eenv->template_env = env;
eenv->label_env = env->label_env;
eenv->instance_env = env->instance_env;
eenv->reader_env = (env->reader_env ? env->reader_env : env);
scheme_prepare_env_stx_context(env);
mc = scheme_module_context_at_phase(env->stx_context, scheme_env_phase(eenv));
@ -1113,6 +1115,7 @@ void scheme_prepare_template_env(Scheme_Env *env)
eenv->exp_env = env;
eenv->label_env = env->label_env;
eenv->instance_env = env->instance_env;
eenv->reader_env = (env->reader_env ? env->reader_env : env);
if (env->disallow_unbound)
eenv->disallow_unbound = env->disallow_unbound;
@ -1149,6 +1152,7 @@ void scheme_prepare_label_env(Scheme_Env *env)
lenv->label_env = lenv;
lenv->template_env = lenv;
lenv->instance_env = env->instance_env;
lenv->reader_env = (env->reader_env ? env->reader_env : env);
}
}
@ -1276,6 +1280,7 @@ Scheme_Env *scheme_copy_module_env(Scheme_Env *menv, Scheme_Env *ns, Scheme_Obje
scheme_prepare_label_env(ns);
menv2->label_env = ns->label_env;
menv2->reader_env = (ns->reader_env ? ns->reader_env : ns);
return menv2;
}

2
racket/src/racket/src/fun.c
View File

@ -331,7 +331,6 @@ scheme_init_fun (Scheme_Env *env)
1, 1,
0, -1);
scheme_add_global_constant("call-with-escape-continuation", o, env);
scheme_add_global_constant("call/ec", o, env);
REGISTER_SO(internal_call_cc_prim);
internal_call_cc_prim = scheme_make_prim_w_arity2(internal_call_cc,
@ -351,7 +350,6 @@ scheme_init_fun (Scheme_Env *env)
0, -1);
scheme_add_global_constant("call-with-current-continuation", o, env);
scheme_add_global_constant("call/cc", o, env);
scheme_add_global_constant("continuation?",
scheme_make_folding_prim(continuation_p,

46
racket/src/racket/src/list.c
View File

@ -604,12 +604,12 @@ scheme_init_list (Scheme_Env *env)
scheme_add_global_constant("hash-map",
scheme_make_noncm_prim(hash_table_map,
"hash-map",
2, 2),
2, 3),
env);
scheme_add_global_constant("hash-for-each",
scheme_make_noncm_prim(hash_table_for_each,
"hash-for-each",
2, 2),
2, 3),
env);
scheme_add_global_constant("hash-iterate-first",
@ -2552,10 +2552,11 @@ static void no_post_key(const char *name, Scheme_Object *key, int chap)
static Scheme_Object *do_map_hash_table(int argc,
Scheme_Object *argv[],
char *name,
int keep)
int keep,
int try_sorted)
{
int i;
Scheme_Object *f;
Scheme_Object *f, **sorted_keys;
Scheme_Object *first, *last = NULL, *v, *p[2], *obj, *chaperone;
obj = argv[0];
@ -2576,7 +2577,38 @@ static Scheme_Object *do_map_hash_table(int argc,
else
first = scheme_void;
if (SCHEME_BUCKTP(obj)) {
/* In simple cases, sort keys. This is useful for quasiquote
expansion over hash tables, for example. */
if (try_sorted && !chaperone && (SCHEME_HASHTP(obj) || SCHEME_HASHTRP(obj)))
sorted_keys = scheme_extract_sorted_keys(obj);
else
sorted_keys = NULL;
if (sorted_keys) {
if (sorted_keys) {
int i, count;
count = (SCHEME_HASHTP(obj) ? ((Scheme_Hash_Table *)obj)->count : ((Scheme_Hash_Tree *)obj)->count);
for (i = 0; i < count; i++) {
if (SCHEME_HASHTP(obj))
v = scheme_hash_get((Scheme_Hash_Table *)obj, sorted_keys[i]);
else
v = scheme_hash_tree_get((Scheme_Hash_Tree *)obj, sorted_keys[i]);
if (v) {
p[0] = sorted_keys[i];
p[1] = v;
v = _scheme_apply(f, 2, p);
if (keep) {
v = lcons(v, scheme_null);
if (last)
SCHEME_CDR(last) = v;
else
first = v;
last = v;
}
}
}
}
} else if (SCHEME_BUCKTP(obj)) {
Scheme_Bucket_Table *hash;
Scheme_Bucket *bucket;
@ -2683,12 +2715,12 @@ static Scheme_Object *do_map_hash_table(int argc,
static Scheme_Object *hash_table_map(int argc, Scheme_Object *argv[])
{
return do_map_hash_table(argc, argv, "hash-map", 1);
return do_map_hash_table(argc, argv, "hash-map", 1, (argc > 2) && SCHEME_TRUEP(argv[2]));
}
static Scheme_Object *hash_table_for_each(int argc, Scheme_Object *argv[])
{
return do_map_hash_table(argc, argv, "hash-for-each", 0);
return do_map_hash_table(argc, argv, "hash-for-each", 0, (argc > 2) && SCHEME_TRUEP(argv[2]));
}
static Scheme_Object *hash_table_next(const char *name, mzlonglong start, int argc, Scheme_Object *argv[])

44
racket/src/racket/src/marshal.c
View File

@ -792,7 +792,6 @@ static Scheme_Object *write_compiled_closure(Scheme_Object *obj)
case scheme_toplevel_type:
case scheme_local_type:
case scheme_local_unbox_type:
case scheme_integer_type:
case scheme_true_type:
case scheme_false_type:
case scheme_void_type:
@ -800,6 +799,9 @@ static Scheme_Object *write_compiled_closure(Scheme_Object *obj)
ds = code;
break;
default:
if (SCHEME_NUMBERP(code))
ds = code;
else
ds = NULL;
break;
}
@ -1255,6 +1257,7 @@ static Scheme_Object *ht_to_vector(Scheme_Object *ht)
/* recurs for values in hash table; we assume that such nesting is shallow */
{
intptr_t i, j, c;
Scheme_Object **sorted_keys;
Scheme_Object *k, *val, *vec;
if (!ht)
@ -1281,10 +1284,13 @@ static Scheme_Object *ht_to_vector(Scheme_Object *ht)
vec = scheme_make_vector(2 * c, NULL);
j = 0;
sorted_keys = scheme_extract_sorted_keys(ht);
if (SCHEME_HASHTRP(ht)) {
Scheme_Hash_Tree *t = (Scheme_Hash_Tree *)ht;
for (i = scheme_hash_tree_next(t, -1); i != -1; i = scheme_hash_tree_next(t, i)) {
scheme_hash_tree_index(t, i, &k, &val);
for (i = 0; i < c; i++) {
k = sorted_keys[i];
val = scheme_hash_tree_get(t, k);
if (SCHEME_HASHTRP(val) || SCHEME_HASHTP(val))
val = ht_to_vector(val);
else if (!SAME_OBJ(val, scheme_true))
@ -1294,18 +1300,17 @@ static Scheme_Object *ht_to_vector(Scheme_Object *ht)
}
} else {
Scheme_Hash_Table *t = (Scheme_Hash_Table *)ht;
for (i = t->size; i--; ) {
if (t->vals[i]) {
val = t->vals[i];
for (i = 0; i < c; i++) {
k = sorted_keys[i];
val = scheme_hash_get(t, k);
if (SCHEME_HASHTRP(val) || SCHEME_HASHTP(val))
val = ht_to_vector(val);
else if (!SAME_OBJ(val, scheme_true))
val = make_delayed_syntax(val);
SCHEME_VEC_ELS(vec)[j++] = t->keys[i];
SCHEME_VEC_ELS(vec)[j++] = k;
SCHEME_VEC_ELS(vec)[j++] = val;
}
}
}
return vec;
}
@ -1316,19 +1321,20 @@ static Scheme_Object *write_module(Scheme_Object *obj)
Scheme_Module_Phase_Exports *pt;
Scheme_Object *l, *v, *phase;
int i, j, k, count, cnt;
Scheme_Object **sorted_keys;
l = scheme_null;
cnt = 0;
if (m->other_requires) {
for (i = 0; i < m->other_requires->size; i++) {
if (m->other_requires->vals[i]) {
cnt++;
l = scheme_make_pair(m->other_requires->keys[i],
scheme_make_pair(m->other_requires->vals[i],
sorted_keys = scheme_extract_sorted_keys((Scheme_Object *)m->other_requires);
cnt = m->other_requires->count;
for (i = 0; i < cnt; i++) {
l = scheme_make_pair(sorted_keys[i],
scheme_make_pair(scheme_hash_get(m->other_requires,
sorted_keys[i]),
l));
}
}
}
l = cons(scheme_make_integer(cnt), l);
l = cons(m->dt_requires, l);
@ -1341,7 +1347,11 @@ static Scheme_Object *write_module(Scheme_Object *obj)
}
cnt = 0;
for (k = -3; k < (m->me->other_phases ? m->me->other_phases->size : 0); k++) {
if (m->me->other_phases)
sorted_keys = scheme_extract_sorted_keys((Scheme_Object *)m->me->other_phases);
else
sorted_keys = NULL;
for (k = -3; k < (m->me->other_phases ? m->me->other_phases->count : 0); k++) {
switch (k) {
case -3:
phase = scheme_make_integer(-1);
@ -1356,8 +1366,8 @@ static Scheme_Object *write_module(Scheme_Object *obj)
pt = m->me->rt;
break;
default:
phase = m->me->other_phases->keys[k];
pt = (Scheme_Module_Phase_Exports *)m->me->other_phases->vals[k];
phase = sorted_keys[k];
pt = (Scheme_Module_Phase_Exports *)scheme_hash_get(m->me->other_phases, phase);
}
if (pt) {

8
racket/src/racket/src/module.c
View File

@ -10617,6 +10617,9 @@ void compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table *
having a consistent provide arrays. */
qsort_provides(exs, exsns, exss, exps, exets, exsnoms, 0, exvcount, 1);
/* Sort syntax, too, for deterministic output */
qsort_provides(exs, exsns, exss, exps, exets, exsnoms, exvcount, excount-exvcount, 0);
pt->num_provides = excount;
pt->num_var_provides = exvcount;
pt->provides = exs;
@ -11888,7 +11891,8 @@ void scheme_do_module_context_unmarshal(Scheme_Object *modidx, Scheme_Object *re
Scheme_Object *bind_phase, Scheme_Object *pt_phase, Scheme_Object *src_phase,
Scheme_Object *prefix, /* a sybmol; not included in `excepts` keys */
Scheme_Hash_Tree *excepts, /* NULL => empty */
Scheme_Hash_Table *export_registry, Scheme_Object *insp_desc,
Scheme_Hash_Table *export_registry,
Scheme_Object *insp_desc, Scheme_Object *req_insp_desc,
Scheme_Object *replace_at)
{
Scheme_Object *name;
@ -11935,7 +11939,7 @@ void scheme_do_module_context_unmarshal(Scheme_Object *modidx, Scheme_Object *re
if (pt) {
if (!pt->src_modidx && me->src_modidx)
pt->src_modidx = me->src_modidx;
scheme_extend_module_context_with_shared(scheme_make_pair(bind_phase, insp_desc),
scheme_extend_module_context_with_shared(scheme_make_pair(bind_phase, req_insp_desc),
req_modidx, pt,
prefix, excepts,
src_phase, context,

2
racket/src/racket/src/mzmark_print.inc
View File

@ -44,6 +44,7 @@ static int mark_marshal_tables_MARK(void *p, struct NewGC *gc) {
gcMARK2(mt->reachable_scopes, gc);
gcMARK2(mt->reachable_scope_stack, gc);
gcMARK2(mt->pending_reachable_ids, gc);
gcMARK2(mt->conditionally_reachable_scopes, gc);
gcMARK2(mt->intern_map, gc);
gcMARK2(mt->identity_map, gc);
gcMARK2(mt->top_map, gc);
@ -65,6 +66,7 @@ static int mark_marshal_tables_FIXUP(void *p, struct NewGC *gc) {
gcFIXUP2(mt->reachable_scopes, gc);
gcFIXUP2(mt->reachable_scope_stack, gc);
gcFIXUP2(mt->pending_reachable_ids, gc);
gcFIXUP2(mt->conditionally_reachable_scopes, gc);
gcFIXUP2(mt->intern_map, gc);
gcFIXUP2(mt->identity_map, gc);
gcFIXUP2(mt->top_map, gc);

2
racket/src/racket/src/mzmark_type.inc
View File

@ -2297,6 +2297,7 @@ static int namespace_val_MARK(void *p, struct NewGC *gc) {
gcMARK2(e->template_env, gc);
gcMARK2(e->label_env, gc);
gcMARK2(e->instance_env, gc);
gcMARK2(e->reader_env, gc);
gcMARK2(e->shadowed_syntax, gc);
@ -2342,6 +2343,7 @@ static int namespace_val_FIXUP(void *p, struct NewGC *gc) {
gcFIXUP2(e->template_env, gc);
gcFIXUP2(e->label_env, gc);
gcFIXUP2(e->instance_env, gc);
gcFIXUP2(e->reader_env, gc);
gcFIXUP2(e->shadowed_syntax, gc);

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

@ -928,6 +928,7 @@ namespace_val {
gcMARK2(e->template_env, gc);
gcMARK2(e->label_env, gc);
gcMARK2(e->instance_env, gc);
gcMARK2(e->reader_env, gc);
gcMARK2(e->shadowed_syntax, gc);
@ -1803,6 +1804,7 @@ mark_marshal_tables {
gcMARK2(mt->reachable_scopes, gc);
gcMARK2(mt->reachable_scope_stack, gc);
gcMARK2(mt->pending_reachable_ids, gc);
gcMARK2(mt->conditionally_reachable_scopes, gc);
gcMARK2(mt->intern_map, gc);
gcMARK2(mt->identity_map, gc);
gcMARK2(mt->top_map, gc);

2
racket/src/racket/src/number.c
View File

@ -4175,7 +4175,7 @@ scheme_bitwise_shift(int argc, Scheme_Object *argv[])
v = scheme_make_bignum(i);
}
if (scheme_current_thread->constant_folding)
if (scheme_current_thread->constant_folding && (shift > 100))
scheme_signal_error("too big");
return scheme_bignum_shift(v, shift);

104
racket/src/racket/src/print.c
View File

@ -182,6 +182,8 @@ static Scheme_Object *writable_struct_subs(Scheme_Object *s, int for_write, Prin
#define ssQUICKp(x, isbox) (pp ? x : isbox)
#define ssALLp(x, isbox) isbox
#define make_hash_table_symtab() scheme_make_hash_table_eqv()
void scheme_init_print(Scheme_Env *env)
{
int i;
@ -1438,7 +1440,7 @@ static int compare_keys(const void *a, const void *b)
Scheme_Object *av, *bv;
/* Atomic things first, because they could be used by
marshaled syntax. This cuts donw on recursive reads
marshaled syntax. Sorting cuts down on recursive reads
at load time. */
# define SCHEME_FIRSTP(v) (SCHEME_SYMBOLP(v) \
|| SCHEME_PATHP(v) \
@ -1699,7 +1701,7 @@ void scheme_marshal_push_refs(Scheme_Marshal_Tables *mt)
mt->st_ref_stack);
mt->st_ref_stack = p;
st_refs = scheme_make_hash_table(SCHEME_hash_ptr);
st_refs = make_hash_table_symtab();
mt->st_refs = st_refs;
}
@ -1739,6 +1741,39 @@ Scheme_Object *scheme_make_marshal_shared(Scheme_Object *v)
return b;
}
static Scheme_Object *intern_modidx(Scheme_Hash_Table *interned, Scheme_Object *modidx)
{
Scheme_Object *l = scheme_null;
Scheme_Modidx *midx;
while (SAME_TYPE(SCHEME_TYPE(modidx), scheme_module_index_type)) {
midx = (Scheme_Modidx *)modidx;
modidx = scheme_hash_get(interned, modidx);
if (!modidx) {
modidx = (Scheme_Object *)midx;
if (SCHEME_FALSEP(midx->path)) {
scheme_hash_set(interned, modidx, modidx);
break;
} else {
l = scheme_make_pair(modidx, l);
modidx = midx->base;
}
} else
break;
}
while (!SCHEME_NULLP(l)) {
midx = (Scheme_Modidx *)SCHEME_CAR(l);
modidx = scheme_make_modidx(midx->path,
modidx,
midx->resolved);
scheme_hash_set(interned, modidx, modidx);
l = SCHEME_CDR(l);
}
return modidx;
}
static void print_escaped(PrintParams *pp, int notdisplay,
Scheme_Object *obj, Scheme_Hash_Table *ht,
Scheme_Marshal_Tables *mt, int shared)
@ -2321,8 +2356,8 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
{
Scheme_Hash_Table *t;
Scheme_Hash_Tree *tr;
Scheme_Object **keys, **vals, *val, *key, *orig;
intptr_t i, size;
Scheme_Object **keys, **vals, *val, *key, *orig, **sorted_keys;
intptr_t i, size, count;
int did_one = 0;
mzlonglong pos;
@ -2373,22 +2408,39 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
tr = (Scheme_Hash_Tree *)obj;
}
if (compact)
print_compact_number(pp, t ? t->count : tr->count);
if (t) {
keys = t->keys;
vals = t->vals;
size = t->size;
count = t->count;
} else {
keys = NULL;
vals = NULL;
size = tr->count;
count = size;
}
if (compact)
print_compact_number(pp, count);
/* For determinism, get sorted keys if possible: */
if (SAME_OBJ(obj, orig)) {
sorted_keys = scheme_extract_sorted_keys(obj);
if (sorted_keys)
size = count;
} else
sorted_keys = NULL;
pos = -1;
for (i = 0; i < size; i++) {
if (!vals || vals[i]) {
if (!vals) {
if (!vals || vals[i] || sorted_keys) {
if (sorted_keys) {
key = sorted_keys[i];
if (t)
val = scheme_hash_get(t, key);
else
val = scheme_hash_tree_get(tr, key);
} else if (!vals) {
pos = scheme_hash_tree_next(tr, pos);
scheme_hash_tree_index(tr, pos, &key, &val);
if (!SAME_OBJ(obj, orig))
@ -2400,7 +2452,7 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
if (!SAME_OBJ(obj, orig))
val = scheme_chaperone_hash_traversal_get(orig, key, &key);
} else
val = 0;
val = NULL;
}
if (val) {
@ -2986,6 +3038,13 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
print_compact(pp, CPT_SCOPE);
print_symtab_set(pp, mt, obj);
idx = get_symtab_idx(mt, obj);
if (mt->reachable_scopes) {
idx = scheme_hash_get(mt->reachable_scopes, obj);
if (!idx)
scheme_signal_error("internal error: found supposedly unreachable scope");
} else
idx = scheme_make_integer(0);
print_compact_number(pp, SCHEME_INT_VAL(idx));
print(scheme_scope_marshal_content(obj, mt), notdisplay, 1, ht, mt, pp);
}
}
@ -3009,6 +3068,7 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
Scheme_Object *idx;
if (compact) {
obj = intern_modidx(mt->intern_map, obj);
idx = get_symtab_idx(mt, obj);
if (idx) {
print_symtab_ref(pp, idx);
@ -3263,7 +3323,7 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
} else if (!mt->pass) {
if (!mt->delay_map) {
Scheme_Hash_Table *delay_map;
delay_map = scheme_make_hash_table(SCHEME_hash_ptr);
delay_map = make_hash_table_symtab();
mt->delay_map = delay_map;
}
scheme_hash_set(mt->delay_map, key, obj);
@ -3400,7 +3460,7 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
if (compact)
closed = print(v, notdisplay, 1, NULL, mt, pp);
else {
Scheme_Hash_Table *st_refs, *symtab, *reachable_scopes;
Scheme_Hash_Table *st_refs, *symtab, *reachable_scopes, *intern_map;
intptr_t *shared_offsets;
intptr_t st_len, j, shared_offset, start_offset;
@ -3408,13 +3468,20 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
SET_REQUIRED_TAG(mt->type = scheme_rt_marshal_info);
scheme_current_thread->current_mt = mt;
/* We need to compare a modidx using `eq?`, because shifting
is based on `eq`ness. */
intern_map = scheme_make_hash_table_equal_modix_eq();
mt->intern_map = intern_map;
/* "Print" the string once to find out which scopes are reachable;
dropping unreachable scopes drops potentialy large binding tables. */
mt->pass = -1;
reachable_scopes = scheme_make_hash_table(SCHEME_hash_ptr);
mt->conditionally_reachable_scopes = reachable_scopes;
reachable_scopes = scheme_make_hash_table(SCHEME_hash_ptr);
mt->reachable_scopes = reachable_scopes;
mt->reachable_scope_stack = scheme_null;
symtab = scheme_make_hash_table(SCHEME_hash_ptr);
symtab = make_hash_table_symtab();
mt->symtab = symtab;
print_substring(v, notdisplay, 1, NULL, mt, pp, NULL, &slen, 0, NULL);
scheme_iterate_reachable_scopes(mt);
@ -3425,9 +3492,10 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
SET_REQUIRED_TAG(mt->type = scheme_rt_marshal_info);
scheme_current_thread->current_mt = mt;
mt->reachable_scopes = reachable_scopes;
mt->intern_map = intern_map;
/* Track which shared values are referenced: */
st_refs = scheme_make_hash_table(SCHEME_hash_ptr);
st_refs = make_hash_table_symtab();
mt->st_refs = st_refs;
mt->st_ref_stack = scheme_null;
@ -3436,7 +3504,7 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
keys, but we also keep track of which things are actually shared;
we'll map the original keys to a compacted set of keys for the
later passes. */
symtab = scheme_make_hash_table(SCHEME_hash_ptr);
symtab = make_hash_table_symtab();
mt->symtab = symtab;
mt->pass = 0;
scheme_hash_set(symtab, scheme_void, scheme_true); /* indicates registration phase */
@ -3450,7 +3518,7 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
are re-computed with the compacted keys. */
shared_offsets = MALLOC_N_ATOMIC(intptr_t, mt->st_refs->count);
mt->shared_offsets = shared_offsets;
symtab = scheme_make_hash_table(SCHEME_hash_ptr);
symtab = make_hash_table_symtab();
mt->symtab = symtab;
mt->top_map = NULL;
mt->pass = 1;
@ -3458,7 +3526,7 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
1, &st_len);
/* "Print" the string again to get a measurement and symtab size. */
symtab = scheme_make_hash_table(SCHEME_hash_ptr);
symtab = make_hash_table_symtab();
mt->symtab = symtab;
mt->top_map = NULL;
mt->pass = 2;
@ -3498,7 +3566,7 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
/* Make symtab again to ensure the same results
for the final print: */
symtab = scheme_make_hash_table(SCHEME_hash_ptr);
symtab = make_hash_table_symtab();
mt->symtab = symtab;
mt->top_map = NULL;
mt->pass = 3;

65
racket/src/racket/src/read.c
View File

@ -4366,6 +4366,7 @@ typedef struct Scheme_Load_Delay {
struct Scheme_Load_Delay *clear_bytes_prev;
struct Scheme_Load_Delay *clear_bytes_next;
int unsafe_ok;
mzlonglong bytecode_hash;
} Scheme_Load_Delay;
#define ZO_CHECK(x) if (!(x)) scheme_ill_formed_code(port);
@ -4389,6 +4390,7 @@ typedef struct CPort {
Scheme_Object *relto;
intptr_t *shared_offsets;
Scheme_Load_Delay *delay_info;
mzlonglong bytecode_hash;
} CPort;
#define CP_GETC(cp) ((int)(cp->start[cp->pos++]))
#define CP_TELL(port) (port->pos + port->base)
@ -4436,6 +4438,8 @@ static void make_ut(CPort *port)
memset(decoded, 0, port->symtab_size);
ut->decoded = decoded;
ut->bytecode_hash = port->bytecode_hash;
rht = scheme_make_hash_table(SCHEME_hash_ptr);
port->ut->rns = rht;
}
@ -5239,7 +5243,10 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
port->symtab[l] = v;
}
l = read_compact_number(port);
v2 = read_compact(port, 0);
v2 = scheme_make_pair(scheme_make_integer(l), v2);
SCHEME_BOX_VAL(v) = v2;
return v;
@ -5380,6 +5387,25 @@ static intptr_t read_simple_number_from_port(Scheme_Object *port)
+ (d << 24));
}
static void install_byecode_hash_code(CPort *rp, char *hash_code)
{
mzlonglong l = 0;
int i;
for (i = 0; i < 20; i++) {
l ^= ((mzlonglong)(hash_code[i]) << ((i % 8) * 8));
}
/* Make sure the hash code leaves lots of room for
run-time generated indices: */
# define LARGE_SPAN ((mzlonglong)1 << 40)
if (!l) l = LARGE_SPAN;
if (l > 0) l = -l;
if (l > (-LARGE_SPAN)) l -= LARGE_SPAN;
rp->bytecode_hash = l;
}
char *scheme_submodule_path_to_string(Scheme_Object *p, intptr_t *_len)
{
Scheme_Object *pr;
@ -5661,6 +5687,8 @@ static Scheme_Object *read_compiled(Scheme_Object *port,
rp->magic_sym = params->magic_sym;
rp->magic_val = params->magic_val;
install_byecode_hash_code(rp, hash_code);
rp->shared_offsets = so;
rp->delay_info = delay_info;
@ -5693,6 +5721,7 @@ static Scheme_Object *read_compiled(Scheme_Object *port,
delay_info->shared_offsets = rp->shared_offsets;
delay_info->relto = rp->relto;
delay_info->unsafe_ok = rp->unsafe_ok;
delay_info->bytecode_hash = rp->bytecode_hash;
if (SAME_OBJ(delay_info->path, scheme_true))
perma_cache = 1;
@ -5934,6 +5963,7 @@ Scheme_Object *scheme_load_delayed_code(int _which, Scheme_Load_Delay *_delay_in
rp->size = size;
rp->ut = delay_info->ut;
rp->unsafe_ok = delay_info->unsafe_ok;
rp->bytecode_hash = delay_info->bytecode_hash;
if (delay_info->ut)
delay_info->ut->rp = rp;
@ -6494,6 +6524,10 @@ static Scheme_Object *do_reader(Scheme_Object *try_modpath,
{
Scheme_Object *modpath, *name, *a[3], *proc, *v, *no_val;
int num_a;
Scheme_Env *env;
Scheme_Cont_Frame_Data cframe;
Scheme_Config *config;
int pop_frame;
if (stxsrc)
modpath = scheme_syntax_to_datum(modpath_stx, 0, NULL);
@ -6534,14 +6568,31 @@ static Scheme_Object *do_reader(Scheme_Object *try_modpath,
num_a = 2;
}
if (get_info)
pop_frame = 0;
else {
config = scheme_current_config();
env = scheme_get_env(config);
if (env->reader_env) {
config = scheme_extend_config(config,
MZCONFIG_ENV,
(Scheme_Object *)env->reader_env);
scheme_push_continuation_frame(&cframe);
scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config);
pop_frame = 1;
} else
pop_frame = 0;
}
proc = scheme_dynamic_require(num_a, a);
if (get_info) {
proc = scheme_force_value(proc);
}
if (get_info && SAME_OBJ(proc, no_val))
return scheme_false;
if (get_info && SAME_OBJ(proc, no_val)) {
v = scheme_false;
} else {
a[0] = proc;
if (scheme_check_proc_arity(NULL, stxsrc ? 6 : 5, 0, 1, a)) {
/* provide modpath_stx to reader */
@ -6563,8 +6614,12 @@ static Scheme_Object *do_reader(Scheme_Object *try_modpath,
get_info, ht, modpath_stx);
if (!get_info && scheme_special_comment_value(v))
return NULL;
else
v = NULL;
}
if (pop_frame)
scheme_pop_continuation_frame(&cframe);
return v;
}

4
racket/src/racket/src/schminc.h
View File

@ -12,9 +12,9 @@
finally, set EXPECTED_PRIM_COUNT to the right value and
USE_COMPILED_STARTUP to 1 and `make' again. */
#define USE_COMPILED_STARTUP 0
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 1134
#define EXPECTED_PRIM_COUNT 1132
#define EXPECTED_UNSAFE_COUNT 106
#define EXPECTED_FLFXNUM_COUNT 69
#define EXPECTED_EXTFL_COUNT 45

8
racket/src/racket/src/schpriv.h
View File

@ -1235,7 +1235,8 @@ void scheme_do_module_context_unmarshal(Scheme_Object *modidx, Scheme_Object *re
Scheme_Object *bind_phase, Scheme_Object *pt_phase, Scheme_Object *src_phase,
Scheme_Object *prefix,
Scheme_Hash_Tree *excepts,
Scheme_Hash_Table *export_registry, Scheme_Object *insp,
Scheme_Hash_Table *export_registry,
Scheme_Object *insp, Scheme_Object *req_insp,
Scheme_Object *replace_at);
int scheme_stx_equal_module_context(Scheme_Object *stx, Scheme_Object *mc_as_stx);
@ -3327,6 +3328,7 @@ typedef struct Scheme_Marshal_Tables {
Scheme_Hash_Table *reachable_scopes; /* filled on -1 pass */
Scheme_Object *reachable_scope_stack; /* used on -1 pass */
Scheme_Hash_Table *pending_reachable_ids; /* use on -1 pass */
Scheme_Hash_Table *conditionally_reachable_scopes; /* filled/used on -1 pass */
Scheme_Hash_Table *intern_map; /* filled on first pass */
Scheme_Hash_Table *identity_map; /* filled on first pass */
Scheme_Hash_Table *top_map; /* used on every pass */
@ -3352,6 +3354,7 @@ typedef struct Scheme_Unmarshal_Tables {
Scheme_Hash_Table *rns;
struct CPort *rp;
char *decoded;
mzlonglong bytecode_hash;
} Scheme_Unmarshal_Tables;
Scheme_Object *scheme_unmarshal_wrap_get(Scheme_Unmarshal_Tables *ut,
@ -3407,6 +3410,7 @@ struct Scheme_Env {
struct Scheme_Env *template_env;
struct Scheme_Env *label_env;
struct Scheme_Env *instance_env; /* shortcut to env where module is instantiated */
struct Scheme_Env *reader_env; /* namespace to use for #reader or #lang */
Scheme_Hash_Table *shadowed_syntax; /* top level only */
@ -4370,6 +4374,8 @@ void scheme_place_set_memory_use(intptr_t amt);
void scheme_place_check_memory_use();
void scheme_clear_place_ifs_stack();
Scheme_Object **scheme_extract_sorted_keys(Scheme_Object *ht);
#ifdef MZ_USE_PLACES
Scheme_Object *scheme_place_make_async_channel();
void scheme_place_async_channel_send(Scheme_Object *ch, Scheme_Object *uo);

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

@ -13,12 +13,12 @@
consistently.)
*/
#define MZSCHEME_VERSION "6.2.900.7"
#define MZSCHEME_VERSION "6.2.900.8"
#define MZSCHEME_VERSION_X 6
#define MZSCHEME_VERSION_Y 2
#define MZSCHEME_VERSION_Z 900
#define MZSCHEME_VERSION_W 7
#define MZSCHEME_VERSION_W 8
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

2
racket/src/racket/src/startup.inc
View File

@ -527,7 +527,7 @@
"(not(car a)))))"
"(define-values(get-linked-collections)"
"(lambda(links-path)"
"(call/ec(lambda(esc)"
"(call-with-escape-continuation (lambda(esc)"
"(define-values(make-handler)"
"(lambda(ts)"
"(lambda(exn)"

3
racket/src/racket/src/startup.rktl
View File

@ -629,7 +629,8 @@
(lambda (links-path)
;; Use/save information in `links-cache', relying on filesystem-change events
;; or a copy of the file to detect when the cache is stale.
(call/ec (lambda (esc)
(call-with-escape-continuation
(lambda (esc)
(define-values (make-handler)
(lambda (ts)
(lambda (exn)

438
racket/src/racket/src/syntax.c
View File

@ -58,7 +58,7 @@ typedef struct Scheme_Scope {
Scheme_Inclhash_Object iso; /* 0x1 => Scheme_Scope_With_Owner */
mzlonglong id; /* low SCHEME_STX_SCOPE_KIND_SHIFT bits indicate kind */
Scheme_Object *bindings; /* NULL, vector for one binding, hash table for multiple bindings,
or (rcons hash-table (rcons pes-info ... NULL));
or (rcons hash-table (rcons (cons scope-set pes-info) ... NULL));
each hash table maps symbols to (cons scope-set binding)
or (mlist (cons scope-set binding) ...) */
} Scheme_Scope;
@ -165,6 +165,10 @@ static Scheme_Object *scope_unmarshal_content(Scheme_Object *c, struct Scheme_Un
static Scheme_Object *scopes_to_sorted_list(Scheme_Scope_Set *scopes);
static void sort_vector_symbols(Scheme_Object *vec);
static void sort_scope_array(Scheme_Object **a, intptr_t count);
static void sort_symbol_array(Scheme_Object **a, intptr_t count);
static void sort_number_array(Scheme_Object **a, intptr_t count);
XFORM_NONGCING static void extract_module_binding_parts(Scheme_Object *l,
Scheme_Object *phase,
Scheme_Object **_insp_desc,
@ -203,6 +207,10 @@ XFORM_NONGCING static void clear_binding_cache_stx(Scheme_Stx *stx);
#define SCHEME_TL_MULTI_SCOPEP(o) (MZ_OPT_HASH_KEY(&(((Scheme_Hash_Table *)o)->iso)) & 0x2)
/* A hash tabel for a multi scope has meta information mapped from void: */
#define MULTI_SCOPE_METAP(v) SCHEME_VOIDP(v)
#define MULTI_SCOPE_META_HASHEDP(v) SCHEME_MPAIRP(v)
/* Represent fallback as vectors, either of size 2 (for normal scope
sets) or size 4 (for sets of propagation instructions, because adding
a fallback layer is an action): */
@ -774,6 +782,7 @@ Scheme_Object *scheme_scope_printed_form(Scheme_Object *m)
if (multi_scope) {
name = scheme_eq_hash_get((Scheme_Hash_Table *)multi_scope, scheme_void);
if (!name) name = scheme_false;
if (MULTI_SCOPE_META_HASHEDP(name)) name = SCHEME_CAR(name);
if (SCHEME_TL_MULTI_SCOPEP(multi_scope))
kind_sym = top_symbol;
@ -866,6 +875,14 @@ Scheme_Object *extract_simple_scope(Scheme_Object *multi_scope, Scheme_Object *p
((Scheme_Scope_With_Owner *)m)->owner_multi_scope = (Scheme_Object *)ht;
((Scheme_Scope_With_Owner *)m)->phase = phase;
scheme_hash_set(ht, phase, m);
if (SCHEME_MPAIRP(scheme_hash_get(ht, scheme_void))) {
/* pair indicates loading from bytecode;
zero out id, so that ordering is based on the owner plus the phase;
this approach helps ensure determinstic ordering independent of
the time at which simple scopes are generated */
((Scheme_Scope *)m)->id &= SCHEME_STX_SCOPE_KIND_MASK;
}
}
return m;
@ -4645,11 +4662,13 @@ static Scheme_Object *unmarshal_key_adjust(Scheme_Object *sym, Scheme_Object *pe
static void unmarshal_module_context_additions(Scheme_Stx *stx, Scheme_Object *vec, Scheme_Scope_Set *scopes, Scheme_Object *replace_at)
{
Scheme_Object *req_modidx, *modidx, *unmarshal_info, *context, *src_phase, *pt_phase, *bind_phase, *insp;
Scheme_Object *req_modidx, *modidx, *unmarshal_info, *context, *src_phase, *pt_phase, *bind_phase;
Scheme_Object *insp, *req_insp;
Scheme_Hash_Table *export_registry;
req_modidx = SCHEME_VEC_ELS(vec)[0];
insp = SCHEME_VEC_ELS(vec)[3];
req_insp = insp;
if (stx) {
modidx = apply_modidx_shifts(stx->shifts, req_modidx, &insp, &export_registry);
@ -4657,6 +4676,7 @@ static void unmarshal_module_context_additions(Scheme_Stx *stx, Scheme_Object *v
modidx = req_modidx;
export_registry = NULL;
insp = scheme_false;
req_insp = scheme_false;
}
src_phase = SCHEME_VEC_ELS(vec)[1];
@ -4679,7 +4699,7 @@ static void unmarshal_module_context_additions(Scheme_Stx *stx, Scheme_Object *v
bind_phase, pt_phase, src_phase,
extract_unmarshal_prefix(unmarshal_info),
extract_unmarshal_excepts(unmarshal_info),
export_registry, insp,
export_registry, insp, req_insp,
replace_at);
}
@ -5177,40 +5197,104 @@ Scheme_Object *scheme_flatten_syntax_list(Scheme_Object *lst, int *islist)
/* wraps->datum */
/*========================================================================*/
static void sort_added_scopes(Scheme_Object *scopes, int added)
{
Scheme_Object **a, *l;
int i;
if (!added)
return;
a = MALLOC_N(Scheme_Object *, added);
for (i = 0, l = scopes; i < added; i++, l = SCHEME_CDR(l)) {
a[i] = SCHEME_CAR(l);
}
sort_scope_array(a, added);
for (i = 0, l = scopes; i < added; i++, l = SCHEME_CDR(l)) {
SCHEME_CAR(l) = a[i];
}
}
static void add_reachable_scopes(Scheme_Scope_Set *scopes, Scheme_Marshal_Tables *mt)
{
intptr_t i;
intptr_t i, added = 0;
Scheme_Object *key, *val;
i = -1;
while ((i = scope_set_next(scopes, i)) != -1) {
scope_set_index(scopes, i, &key, &val);
if (!scheme_eq_hash_get(mt->reachable_scopes, key)) {
scheme_hash_set(mt->conditionally_reachable_scopes, key, NULL);
scheme_hash_set(mt->reachable_scopes, key, scheme_true);
val = scheme_make_pair(key, mt->reachable_scope_stack);
mt->reachable_scope_stack = val;
added++;
}
}
sort_added_scopes(mt->reachable_scope_stack, added);
}
static void add_conditional_as_reachable(Scheme_Scope_Set *scopes, Scheme_Marshal_Tables *mt)
{
int added = 0;
intptr_t i;
Scheme_Object *key, *val;
STX_ASSERT(SCHEME_SCOPE_SETP(scopes));
i = -1;
while ((i = scope_set_next(scopes, i)) != -1) {
scope_set_index(scopes, i, &key, &val);
if (SCHEME_SCOPE_HAS_OWNER((Scheme_Scope *)key)
&& scheme_eq_hash_get(mt->conditionally_reachable_scopes, key)
&& !scheme_eq_hash_get(mt->reachable_scopes, key)) {
scheme_hash_set(mt->conditionally_reachable_scopes, key, NULL);
scheme_hash_set(mt->reachable_scopes, key, scheme_true);
val = scheme_make_pair(key, mt->reachable_scope_stack);
mt->reachable_scope_stack = val;
added++;
}
}
sort_added_scopes(mt->reachable_scope_stack, added);
}
static void add_reachable_multi_scope(Scheme_Object *ms, Scheme_Marshal_Tables *mt)
{
Scheme_Hash_Table *ht = (Scheme_Hash_Table *)ms;
Scheme_Scope_Set *binding_scopes = empty_scope_set;
Scheme_Object *scope;
int j;
for (j = ht->size; j--; ) {
scope = ht->vals[j];
if (scope) {
if (!SCHEME_VOIDP(ht->keys[j])) {
if (!scheme_eq_hash_get(mt->reachable_scopes, scope)) {
scheme_hash_set(mt->reachable_scopes, scope, scheme_true);
scope = scheme_make_pair(scope, mt->reachable_scope_stack);
mt->reachable_scope_stack = scope;
if (!MULTI_SCOPE_METAP(ht->keys[j])) {
if (!scheme_eq_hash_get(mt->reachable_scopes, scope)
&& !scheme_eq_hash_get(mt->conditionally_reachable_scopes, scope)) {
/* This scope is reachable via its multi-scope, but it only
matters if it's reachable through a binding (otherwise it
can be re-generated later). We don't want to keep a scope
that can be re-generated, because pruning it makes
compilation more deterministic relative to other
compilations that involve a shared module. If the scope
itself has any bindings, then we count it as reachable
through a binding (which is an approxmation, because other scopes
in the binding may be unreachable, but it seems good enough for
determinism). */
scheme_hash_set(mt->conditionally_reachable_scopes, scope, scheme_true);
if (((Scheme_Scope *)scope)->bindings)
binding_scopes = scope_set_set(binding_scopes, scope, scheme_true);
}
}
}
}
if (!SAME_OBJ(binding_scopes, empty_scope_set))
add_conditional_as_reachable(binding_scopes, mt);
}
static void add_reachable_multi_scopes(Scheme_Object *multi_scopes, Scheme_Marshal_Tables *mt)
@ -5233,17 +5317,28 @@ static void add_reachable_multi_scopes(Scheme_Object *multi_scopes, Scheme_Marsh
}
}
static Scheme_Object *any_unreachable_scope(Scheme_Scope_Set *scopes, Scheme_Marshal_Tables *mt)
static Scheme_Object *any_unreachable_scope(Scheme_Scope_Set *scopes, Scheme_Marshal_Tables *mt,
int check_conditionals)
{
intptr_t i;
int saw_conditional = 0;
Scheme_Object *key, *val;
i = -1;
while ((i = scope_set_next(scopes, i)) != -1) {
scope_set_index(scopes, i, &key, &val);
if (!scheme_eq_hash_get(mt->reachable_scopes, key))
if (!scheme_eq_hash_get(mt->reachable_scopes, key)) {
if (check_conditionals && scheme_eq_hash_get(mt->conditionally_reachable_scopes, key))
saw_conditional = 1;
else
return key;
}
}
if (saw_conditional) {
/* since this binding is reachable, move any conditional to reachable */
add_conditional_as_reachable(scopes, mt);
}
return NULL;
}
@ -5263,7 +5358,7 @@ static void possiblly_reachable_free_id(Scheme_Object *val, /* mpair or stx */
STX_ASSERT(SCHEME_STXP((Scheme_Object *)free_id));
unreachable_scope = any_unreachable_scope(scopes, mt);
unreachable_scope = any_unreachable_scope(scopes, mt, 1);
if (!unreachable_scope) {
/* causes the free-id mapping's scopes to be reachable: */
@ -5283,12 +5378,84 @@ static void possiblly_reachable_free_id(Scheme_Object *val, /* mpair or stx */
}
}
static int all_symbols(Scheme_Object **a, int c)
{
while (c--) {
if (!SCHEME_SYMBOLP(a[c]))
return 0;
}
return 1;
}
static int all_reals(Scheme_Object **a, int c)
{
while (c--) {
if (!SCHEME_REALP(a[c]))
return 0;
}
return 1;
}
Scheme_Object **scheme_extract_sorted_keys(Scheme_Object *tree)
{
intptr_t j, i, count;
Scheme_Object **a, *key;
if (SCHEME_HASHTRP(tree)) {
Scheme_Hash_Tree *ht = (Scheme_Hash_Tree *)tree;
count = ht->count;
if (!count)
return NULL;
a = MALLOC_N(Scheme_Object *, count);
j = -1;
i = 0;
while ((j = scheme_hash_tree_next(ht, j)) != -1) {
scheme_hash_tree_index(ht, j, &key, NULL);
a[i++] = key;
}
STX_ASSERT(i == count);
} else {
Scheme_Hash_Table *t = (Scheme_Hash_Table *)tree;
count = t->count;
if (!count)
return NULL;
a = MALLOC_N(Scheme_Object *, count);
j = 0;
for (i = t->size; i--; ) {
if (t->vals[i]) {
a[j++] = t->keys[i];
}
}
STX_ASSERT(j == count);
}
if (SCHEME_SYMBOLP(a[0]) && all_symbols(a, count))
sort_symbol_array(a, count);
else if (SCHEME_SCOPEP(a[0]))
sort_scope_array(a, count);
else if (all_reals(a, count))
sort_number_array(a, count);
else
return NULL;
return a;
}
void scheme_iterate_reachable_scopes(Scheme_Marshal_Tables *mt)
{
Scheme_Scope *scope;
Scheme_Object *l, *val, *key;
Scheme_Object *l, *val, *key, **sorted_keys, *pesl;
Scheme_Hash_Tree *ht;
int j;
intptr_t j, count;
/* For each scope, recur on `free-identifier=?` mappings */
while (!SCHEME_NULLP(mt->reachable_scope_stack)) {
@ -5298,23 +5465,29 @@ void scheme_iterate_reachable_scopes(Scheme_Marshal_Tables *mt)
if (scope->bindings) {
val = scope->bindings;
if (SCHEME_VECTORP(val)) {
add_conditional_as_reachable(SCHEME_VEC_BINDING_SCOPES(val), mt);
l = SCHEME_VEC_BINDING_VAL(val);
if (SCHEME_MPAIRP(l)) {
/* It's a free-id mapping: */
possiblly_reachable_free_id(l, SCHEME_VEC_BINDING_SCOPES(val), mt);
}
} else {
if (SCHEME_RPAIRP(val))
if (SCHEME_RPAIRP(val)) {
ht = (Scheme_Hash_Tree *)SCHEME_CAR(val);
else {
pesl = SCHEME_CDR(val);
} else {
STX_ASSERT(SCHEME_HASHTRP(val));
ht = (Scheme_Hash_Tree *)val;
pesl = NULL;
}
j = -1;
while ((j = scheme_hash_tree_next(ht, j)) != -1) {
scheme_hash_tree_index(ht, j, &key, &val);
sorted_keys = scheme_extract_sorted_keys((Scheme_Object *)ht);
count = ht->count;
for (j = 0; j < count; j++) {
key = sorted_keys[j];
val = scheme_hash_tree_get(ht, key);
l = val;
if (SCHEME_PAIRP(l)) {
add_conditional_as_reachable(SCHEME_BINDING_SCOPES(l), mt);
val = SCHEME_BINDING_VAL(l);
if (SCHEME_MPAIRP(val)) {
/* It's a free-id mapping: */
@ -5323,6 +5496,7 @@ void scheme_iterate_reachable_scopes(Scheme_Marshal_Tables *mt)
} else {
STX_ASSERT(SCHEME_MPAIRP(l));
for (; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) {
add_conditional_as_reachable(SCHEME_BINDING_SCOPES(SCHEME_CAR(l)), mt);
val = SCHEME_BINDING_VAL(SCHEME_CAR(l));
if (SCHEME_MPAIRP(val)) {
/* It's a free-id mapping: */
@ -5331,6 +5505,13 @@ void scheme_iterate_reachable_scopes(Scheme_Marshal_Tables *mt)
}
}
}
while (pesl) {
STX_ASSERT(SCHEME_RPAIRP(pesl));
val = SCHEME_CAR(pesl);
STX_ASSERT(SCHEME_PAIRP(val));
add_conditional_as_reachable((Scheme_Scope_Set *)SCHEME_CAR(val), mt);
pesl = SCHEME_CDR(pesl);
}
}
}
@ -5347,6 +5528,16 @@ void scheme_iterate_reachable_scopes(Scheme_Marshal_Tables *mt)
}
}
}
/* Adjust mapping so that each scope maps to its relative position: */
{
int i;
sorted_keys = scheme_extract_sorted_keys((Scheme_Object *)mt->reachable_scopes);
for (j = mt->reachable_scopes->count, i = 0; j--; i++) {
STX_ASSERT(SCHEME_SCOPEP(sorted_keys[j]));
scheme_hash_set(mt->reachable_scopes, sorted_keys[j], scheme_make_integer(i));
}
}
}
static Scheme_Object *intern_one(Scheme_Object *v, Scheme_Hash_Table *ht)
@ -5424,16 +5615,74 @@ START_XFORM_SKIP;
END_XFORM_SKIP;
#endif
typedef int (*compar_t)(const void *, const void *);
static int compare_scopes(const void *a, const void *b)
static int compare_scopes_from_multi(Scheme_Scope *a, Scheme_Scope *b)
{
if (*(void **)a == *(void **)b)
return 0;
else if ((*(Scheme_Scope **)a)->id > (*(Scheme_Scope **)b)->id)
Scheme_Scope_With_Owner *ao, *bo;
ao = (Scheme_Scope_With_Owner *)a;
bo = (Scheme_Scope_With_Owner *)b;
if (SAME_OBJ(ao->owner_multi_scope, bo->owner_multi_scope)) {
if (SCHEME_FALSEP(ao->phase))
return 1;
else if (SCHEME_FALSEP(bo->phase))
return 1;
else if (scheme_bin_lt(ao->phase, bo->phase))
return 1;
else
return -1;
} else {
Scheme_Object *na, *nb;
na = scheme_hash_get((Scheme_Hash_Table *)ao->owner_multi_scope, scheme_void);
nb = scheme_hash_get((Scheme_Hash_Table *)bo->owner_multi_scope, scheme_void);
STX_ASSERT(MULTI_SCOPE_META_HASHEDP(na));
STX_ASSERT(MULTI_SCOPE_META_HASHEDP(nb));
na = SCHEME_CDR(na);
nb = SCHEME_CDR(nb);
STX_ASSERT(SCHEME_REALP(na));
STX_ASSERT(SCHEME_REALP(nb));
if (scheme_bin_lt(na, nb))
return 1;
else if (scheme_bin_lt(nb, na))
return -1;
else
return 0;
}
}
static int compare_scopes(const void *_a, const void *_b)
{
Scheme_Scope *a = *(Scheme_Scope **)_a;
Scheme_Scope *b = *(Scheme_Scope **)_b;
STX_ASSERT(SCHEME_SCOPEP(a));
STX_ASSERT(SCHEME_SCOPEP(b));
/* Scopes for multi-scopes that were generated late are
ordered before everything else: */
if (!(a->id >> SCHEME_STX_SCOPE_KIND_SHIFT)) {
STX_ASSERT(SCHEME_SCOPE_HAS_OWNER(a));
if (b->id >> SCHEME_STX_SCOPE_KIND_SHIFT)
return 1;
STX_ASSERT(SCHEME_SCOPE_HAS_OWNER(b));
return compare_scopes_from_multi(a, b);
} else if (!(b->id >> SCHEME_STX_SCOPE_KIND_SHIFT)) {
STX_ASSERT(SCHEME_SCOPE_HAS_OWNER(b));
return -1;
}
if (a->id > b->id)
return -1;
else if (a->id < b->id)
return 1;
else
return 0;
}
static void sort_scope_array(Scheme_Object **a, intptr_t count)
{
my_qsort(a, count, sizeof(Scheme_Object *), compare_scopes);
}
static Scheme_Object *scopes_to_sorted_list(Scheme_Scope_Set *scopes)
@ -5451,7 +5700,7 @@ static Scheme_Object *scopes_to_sorted_list(Scheme_Scope_Set *scopes)
i = scope_set_next(scopes, i);
}
my_qsort(a, j, sizeof(Scheme_Object *), compare_scopes);
sort_scope_array(a, j);
r = scheme_null;
for (i = j; i--; ) {
@ -5463,10 +5712,13 @@ static Scheme_Object *scopes_to_sorted_list(Scheme_Scope_Set *scopes)
static int compare_syms(const void *_a, const void *_b)
{
Scheme_Object *a = (Scheme_Object *)_a;
Scheme_Object *b = (Scheme_Object *)_b;
Scheme_Object *a = *(Scheme_Object **)_a;
Scheme_Object *b = *(Scheme_Object **)_b;
intptr_t l = SCHEME_SYM_LEN(a), i;
STX_ASSERT(SCHEME_SYMBOLP(a));
STX_ASSERT(SCHEME_SYMBOLP(b));
if (SCHEME_SYM_LEN(b) < l)
l = SCHEME_SYM_LEN(b);
@ -5483,6 +5735,38 @@ static void sort_vector_symbols(Scheme_Object *vec)
my_qsort(SCHEME_VEC_ELS(vec), SCHEME_VEC_SIZE(vec), sizeof(Scheme_Object *), compare_syms);
}
static void sort_symbol_array(Scheme_Object **a, intptr_t count)
{
my_qsort(a, count, sizeof(Scheme_Object *), compare_syms);
}
static int compare_nums(const void *_a, const void *_b)
/* also allow #fs */
{
Scheme_Object *a = *(Scheme_Object **)_a;
Scheme_Object *b = *(Scheme_Object **)_b;
if (SCHEME_FALSEP(a))
return -1;
else if (SCHEME_FALSEP(b))
return 1;
STX_ASSERT(SCHEME_REALP(a));
STX_ASSERT(SCHEME_REALP(b));
if (scheme_bin_lt(a, b))
return -1;
else if (scheme_bin_lt(b, a))
return 1;
else
return 0;
}
static void sort_number_array(Scheme_Object **a, intptr_t count)
{
my_qsort(a, count, sizeof(Scheme_Object *), compare_nums);
}
static Scheme_Object *drop_export_registries(Scheme_Object *shifts)
{
Scheme_Object *l, *a, *vec, *p, *first = scheme_null, *last = NULL;
@ -5528,11 +5812,30 @@ static void init_identity_map(Scheme_Marshal_Tables *mt)
mt->identity_map = id_map;
}
static int compare_phased_scopes(const void *_a, const void *_b)
{
Scheme_Object *a = *(Scheme_Object **)_a;
Scheme_Object *b = *(Scheme_Object **)_b;
if (SCHEME_FALSEP(a))
return -1;
else if (SCHEME_FALSEP(b))
return 1;
else {
STX_ASSERT(SCHEME_REALP(a));
STX_ASSERT(SCHEME_REALP(b));
if (scheme_bin_lt(a, b))
return -1;
else
return 1;
}
}
static Scheme_Object *multi_scope_to_vector(Scheme_Object *multi_scope, Scheme_Marshal_Tables *mt)
{
Scheme_Object *vec;
Scheme_Hash_Table *scopes = (Scheme_Hash_Table *)multi_scope;
intptr_t i, j;
intptr_t i, j, count;
if (!mt->identity_map)
init_identity_map(mt);
@ -5541,19 +5844,37 @@ static Scheme_Object *multi_scope_to_vector(Scheme_Object *multi_scope, Scheme_M
if (vec)
return vec;
vec = scheme_make_vector((2 * scopes->count) - 1, scheme_void);
/* only keep reachable scopes: */
count = 0;
for (i = scopes->size; i--; ) {
if (scopes->vals[i]) {
if (!MULTI_SCOPE_METAP(scopes->keys[i])) {
if (scheme_hash_get(mt->reachable_scopes, scopes->vals[i]))
count++;
}
}
}
vec = scheme_make_vector((2 * count) + 1, scheme_void);
j = 0;
for (i = scopes->size; i--; ) {
if (scopes->vals[i]) {
if (!SCHEME_VOIDP(scopes->keys[i])) {
if (!MULTI_SCOPE_METAP(scopes->keys[i])) {
if (scheme_hash_get(mt->reachable_scopes, scopes->vals[i])) {
SCHEME_VEC_ELS(vec)[j++] = scopes->keys[i]; /* a phase */
SCHEME_VEC_ELS(vec)[j++] = scopes->vals[i]; /* a scope */
}
} else {
SCHEME_VEC_ELS(vec)[SCHEME_VEC_SIZE(vec)-1] = scopes->vals[i]; /* debug name */
/* debug name */
SCHEME_VEC_ELS(vec)[2 * count] = (MULTI_SCOPE_META_HASHEDP(scopes->vals[i])
? SCHEME_CAR(scopes->vals[i])
: scopes->vals[i]);
}
}
}
my_qsort(SCHEME_VEC_ELS(vec), count, 2 * sizeof(Scheme_Object *), compare_phased_scopes);
vec = scheme_make_marshal_shared(vec);
scheme_hash_set(mt->identity_map, multi_scope, vec);
@ -5622,12 +5943,6 @@ static Scheme_Object *wraps_to_datum(Scheme_Stx *stx, Scheme_Marshal_Tables *mt)
}
ht = mt->intern_map;
if (!ht) {
/* We need to compare a modidx using `eq?`, because shifting
is based on `eq`ness. */
ht = scheme_make_hash_table_equal_modix_eq();
mt->intern_map = ht;
}
shifts = intern_tails(drop_export_registries(stx->shifts), ht);
simples = intern_tails(scopes_to_sorted_list(stx->scopes->simple_scopes), ht);
@ -5670,7 +5985,7 @@ static Scheme_Object *marshal_bindings(Scheme_Object *l, Scheme_Marshal_Tables *
scopes = (Scheme_Object *)SCHEME_BINDING_SCOPES(SCHEME_CAR(l));
}
if (!any_unreachable_scope((Scheme_Scope_Set *)scopes, mt)) {
if (!any_unreachable_scope((Scheme_Scope_Set *)scopes, mt, 0)) {
if (SCHEME_PAIRP(l))
v = SCHEME_BINDING_VAL(l);
else
@ -5703,7 +6018,7 @@ static Scheme_Object *marshal_bindings(Scheme_Object *l, Scheme_Marshal_Tables *
Scheme_Object *scheme_scope_marshal_content(Scheme_Object *m, Scheme_Marshal_Tables *mt)
{
Scheme_Hash_Tree *ht;
Scheme_Object *v, *l, *r, *l2, *tab, *scopes, *key, *val;
Scheme_Object *v, *l, *r, *l2, *tab, *scopes, *val, **sorted_keys;
intptr_t i, j;
if (!mt->identity_map)
@ -5749,16 +6064,17 @@ Scheme_Object *scheme_scope_marshal_content(Scheme_Object *m, Scheme_Marshal_Tab
SCHEME_VEC_ELS(tab)[j++] = r;
}
} else {
i = -1;
while ((i = scheme_hash_tree_next(ht, i)) != -1) {
scheme_hash_tree_index(ht, i, &key, &val);
intptr_t count = ht->count;
sorted_keys = scheme_extract_sorted_keys((Scheme_Object *)ht);
for (i = 0; i < count; i++) {
val = scheme_hash_tree_get(ht, sorted_keys[i]);
r = marshal_bindings(val, mt);
if (SCHEME_NULLP(r)) {
/* no reachable bindings */
} else {
STX_ASSERT(j < (2 * count));
SCHEME_VEC_ELS(tab)[j++] = key;
SCHEME_VEC_ELS(tab)[j++] = sorted_keys[i];
SCHEME_VEC_ELS(tab)[j++] = r;
}
}
@ -5775,7 +6091,10 @@ Scheme_Object *scheme_scope_marshal_content(Scheme_Object *m, Scheme_Marshal_Tab
for (l = l2; l; l = SCHEME_CDR(l)) {
STX_ASSERT(SCHEME_RPAIRP(l));
v = SCHEME_CDR(SCHEME_CAR(l));
if (PES_BINDINGP(v)) {
if (any_unreachable_scope((Scheme_Scope_Set *)SCHEME_CAR(SCHEME_CAR(l)), mt, 0)) {
/* drop unreachable bindings */
v = NULL;
} else if (PES_BINDINGP(v)) {
l2 = scheme_make_vector(4, NULL);
SCHEME_VEC_ELS(l2)[0] = SCHEME_VEC_ELS(v)[0];
SCHEME_VEC_ELS(l2)[1] = SCHEME_VEC_ELS(v)[2];
@ -6157,7 +6476,15 @@ static Scheme_Hash_Table *vector_to_multi_scope(Scheme_Object *mht, Scheme_Unmar
len = SCHEME_VEC_SIZE(mht);
if (!(len & 1)) return_NULL;
STX_ASSERT(ut->bytecode_hash);
multi_scope = (Scheme_Hash_Table *)new_multi_scope(SCHEME_VEC_ELS(mht)[len-1]);
scheme_hash_set(multi_scope,
scheme_void,
/* record bytecode hash for making fresh scopes for other phases: */
scheme_make_mutable_pair(scheme_hash_get(multi_scope, scheme_void),
scheme_make_integer_value_from_long_long(ut->bytecode_hash
>> SCHEME_STX_SCOPE_KIND_SHIFT)));
len -= 1;
/* A multi-scope can refer back to itself via free-id=? info: */
@ -6201,6 +6528,7 @@ Scheme_Object *unmarshal_multi_scopes(Scheme_Object *multi_scopes,
multi_scope = vector_to_multi_scope(SCHEME_CAR(SCHEME_CAR(l)), ut);
if (!multi_scope) return_NULL;
SCHEME_CAR(SCHEME_CAR(l)) = (Scheme_Object *)multi_scope;
if (!SCHEME_PHASE_SHIFTP(SCHEME_CDR(SCHEME_CAR(l)))) return_NULL;
} else {
/* rest of list must be converted already, too */
break;
@ -6351,7 +6679,7 @@ Scheme_Object *scope_unmarshal_content(Scheme_Object *box, Scheme_Unmarshal_Tabl
Scheme_Object *l = NULL, *l2, *r, *b, *m, *c, *free_id;
Scheme_Hash_Tree *ht;
Scheme_Scope_Set *scopes;
intptr_t i, len;
intptr_t i, len, relative_id;
if (SAME_OBJ(box, root_scope))
return root_scope;
@ -6363,6 +6691,11 @@ Scheme_Object *scope_unmarshal_content(Scheme_Object *box, Scheme_Unmarshal_Tabl
if (!SCHEME_BOXP(box)) return_NULL;
c = SCHEME_BOX_VAL(box);
if (!SCHEME_PAIRP(c)) return_NULL;
relative_id = SCHEME_INT_VAL(SCHEME_CAR(c));
c = SCHEME_CDR(c);
if (SCHEME_INTP(c)) {
m = scheme_new_scope(SCHEME_INT_VAL(c));
c = NULL;
@ -6375,6 +6708,19 @@ Scheme_Object *scope_unmarshal_content(Scheme_Object *box, Scheme_Unmarshal_Tabl
/* Since we've created the scope before unmarshaling its content,
cycles among scopes are ok. */
/* Reset the scope's id to a hash from the bytecode plus a relative
offset. The only use of a scope's id is for debugging and
ordering, and using the bytecode's hash as part of the number is
intended to make ordering deterministic even across modules,
independent of the order that modules are loaded or delay-loaded.
Hashes are not gauarnteed to be distinct or far enough apart, but
they're likely to be. */
STX_ASSERT(ut->bytecode_hash);
((Scheme_Scope *)m)->id = ((SCHEME_STX_SCOPE_KIND_MASK & ((Scheme_Scope*)m)->id)
| ((umzlonglong)((relative_id << SCHEME_STX_SCOPE_KIND_SHIFT)
+ ut->bytecode_hash)
& (~(umzlonglong)SCHEME_STX_SCOPE_KIND_MASK)));
if (!c) return m;
while (SCHEME_PAIRP(c)) {