toward deterministic bytecode generation

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.

pkgs/base/info.rkt

@@ -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]))

pkgs/racket-doc/scribblings/raco/make.scrbl

@@ -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"]}
 
 @; ----------------------------------------------------------------------
 

pkgs/racket-doc/scribblings/reference/hashes.scrbl

@@ -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]
+See @racket[hash-map] for information about @racket[try-order?] and
-within @racket[proc]. @see-also-concurrency-caveat[]}
+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?])

pkgs/racket-doc/scribblings/reference/namespaces.scrbl

@@ -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.
 

pkgs/racket-doc/scribblings/reference/read.scrbl

@@ -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

pkgs/racket-doc/scribblings/reference/reader.scrbl

@@ -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

pkgs/racket-test-core/tests/racket/basic.rktl

@@ -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-map 2 3)
-(arity-test hash-for-each 2 2)
+(arity-test hash-for-each 2 3)
 (arity-test hash? 1 1)
 (arity-test hash-eq? 1 1)
 (arity-test hash-weak? 1 1)

pkgs/racket-test/tests/racket/deterministic-zo.rkt

@@ -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))

racket/collects/compiler/cm.rkt

@@ -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

racket/collects/racket/contract/private/arrow-higher-order.rkt

@@ -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

racket/collects/racket/contract/private/arrow.rkt

@@ -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

racket/collects/racket/contract/private/helpers.rkt

@@ -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))))

racket/collects/racket/match/compiler.rkt

@@ -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)))))
+    (h-set! ht k (cons r (h-ref ht k (lambda ()
-  ht)
+                                       (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)]))]

racket/collects/racket/match/patterns.rkt

@@ -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))
+                  (unless (module-identifier-mapping-get m id (lambda () #f))
-                (module-identifier-mapping-map m (lambda (k v) k)))]))
+                    (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

racket/collects/racket/private/define-et-al.rkt

@@ -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

racket/collects/racket/private/more-scheme.rkt

@@ -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)

racket/collects/racket/private/pre-base.rkt

@@ -148,6 +148,9 @@
                         (cdr l)))
              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)
@@ -207,4 +210,5 @@
              define-struct/derived
              struct-field-index
              struct-copy
-             double-flonum?))
+             double-flonum?
+             call/cc call/ec))

racket/collects/racket/private/qq-and-or.rkt

@@ -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)

racket/collects/racket/private/sc.rkt

@@ -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)

racket/collects/setup/main.rkt

@@ -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.

racket/collects/syntax/parse/experimental/dset.rkt

@@ -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)))

racket/collects/syntax/parse/experimental/template.rkt

@@ -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]
+ ;; dset->env : (dsetof env-entry) -> hash[env-entry => nat]
- (define (set->env drivers init-env)
+ (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)

racket/collects/syntax/parse/private/rep-attrs.rkt

@@ -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))))

racket/src/racket/gc2/check-sdep.rkt

@@ -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

racket/src/racket/gc2/xform.rkt

@@ -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)

racket/src/racket/src/bool.c

@@ -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;
-          Scheme_Modidx *midx1, *midx2;
 #   include "mzeqchk.inc"
-          midx1 = (Scheme_Modidx *)obj1;
+        midx1 = (Scheme_Modidx *)obj1;
-          midx2 = (Scheme_Modidx *)obj2;
+        midx2 = (Scheme_Modidx *)obj2;
-          if (is_equal(midx1->path, midx2->path, eql)) {
+        if (eql->eq_for_modidx
-            obj1 = midx1->base;
+            && (SCHEME_FALSEP(midx1->path)
-            obj2 = midx2->base;
+                || SCHEME_FALSEP(midx2->path)))
-            goto top;
-          } else
-            return 0;
-        } else
           return 0;
+        else if (is_equal(midx1->path, midx2->path, eql)) {
+          obj1 = midx1->base;
+          obj2 = midx2->base;
+          goto top;
+        }
       }
     case scheme_scope_table_type:
       {

racket/src/racket/src/compenv.c

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

racket/src/racket/src/env.c

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

racket/src/racket/src/fun.c

@@ -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,

racket/src/racket/src/list.c

@@ -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[])

racket/src/racket/src/marshal.c

@@ -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,7 +799,10 @@ static Scheme_Object *write_compiled_closure(Scheme_Object *obj)
     ds = code;
     break;
   default:
-    ds = NULL;
+    if (SCHEME_NUMBERP(code))
+      ds = code;
+    else
+      ds = NULL;
     break;
   }
   
@@ -850,9 +852,9 @@ static Scheme_Object *write_compiled_closure(Scheme_Object *obj)
       if (!ds) {
         if (mt->pass)
           scheme_signal_error("broken closure-data table\n");
-    
+
         code = scheme_protect_quote(data->code);
-    
+
         ds = scheme_alloc_small_object();
         ds->type = scheme_delay_syntax_type;
         SCHEME_PTR_VAL(ds) = code;
@@ -1122,7 +1124,7 @@ static Scheme_Object *make_delayed_syntax(Scheme_Object *stx)
 {
   Scheme_Object *ds;
   Scheme_Marshal_Tables *mt;
-  
+
   mt = scheme_current_thread->current_mt;
   if (mt->pass < 0)
     return stx;
@@ -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)
@@ -1280,11 +1283,14 @@ 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)) {
+    for (i = 0; i < c; i++) {
-      scheme_hash_tree_index(t, i, &k, &val);
+      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,16 +1300,15 @@ static Scheme_Object *ht_to_vector(Scheme_Object *ht)
     }
   } else {
     Scheme_Hash_Table *t = (Scheme_Hash_Table *)ht;
-    for (i = t->size; i--; ) {
+    for (i = 0; i < c; i++) {
-      if (t->vals[i]) {
+      k = sorted_keys[i];
-        val = t->vals[i];
+      val = scheme_hash_get(t, k);
-        if (SCHEME_HASHTRP(val) || SCHEME_HASHTP(val))
+      if (SCHEME_HASHTRP(val) || SCHEME_HASHTP(val))
-          val = ht_to_vector(val);
+        val = ht_to_vector(val);
-        else if (!SAME_OBJ(val, scheme_true))
+      else if (!SAME_OBJ(val, scheme_true))
-          val = make_delayed_syntax(val);
+        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;
+      SCHEME_VEC_ELS(vec)[j++] = val;
-      }
     }
   }
 
@@ -1316,17 +1321,18 @@ 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++) {
+    sorted_keys = scheme_extract_sorted_keys((Scheme_Object *)m->other_requires);
-      if (m->other_requires->vals[i]) {
+    cnt = m->other_requires->count;
-        cnt++;
+    for (i = 0; i < cnt; i++) {
-        l = scheme_make_pair(m->other_requires->keys[i],
+      l = scheme_make_pair(sorted_keys[i],
-                             scheme_make_pair(m->other_requires->vals[i],
+                           scheme_make_pair(scheme_hash_get(m->other_requires,
-                                              l));
+                                                            sorted_keys[i]),
-      }
+                                            l));
     }
   }
   l = cons(scheme_make_integer(cnt), 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];
+      phase = sorted_keys[k];
-      pt = (Scheme_Module_Phase_Exports *)m->me->other_phases->vals[k];
+      pt = (Scheme_Module_Phase_Exports *)scheme_hash_get(m->me->other_phases, phase);
     }
     
     if (pt) {

racket/src/racket/src/module.c

@@ -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,

racket/src/racket/src/mzmark_print.inc

@@ -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);

racket/src/racket/src/mzmark_type.inc

@@ -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);
 

racket/src/racket/src/mzmarksrc.c

@@ -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);

racket/src/racket/src/number.c

@@ -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);

racket/src/racket/src/print.c

@@ -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;
+      Scheme_Object **keys, **vals, *val, *key, *orig, **sorted_keys;
-      intptr_t i, size;
+      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 || vals[i] || sorted_keys) {
-          if (!vals) {
+          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);
@@ -3352,7 +3412,7 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
 
       /* "D" means "directory": */
       print_this_string(pp, "D", 0, 1);
-      print_number(pp, count);      
+      print_number(pp, count);
       
       /* Write the module directory as a binary search tree. */
       (void)write_module_tree(pp, a, subtrees, 0, count, init_offset);
@@ -3400,21 +3460,28 @@ 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;
 
         mt = MALLOC_ONE_RT(Scheme_Marshal_Tables);
         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;

racket/src/racket/src/read.c

@@ -1,4 +1,4 @@
-/*
+ /*
   Racket
   Copyright (c) 2004-2014 PLT Design Inc.
   Copyright (c) 1995-2001 Matthew Flatt
@@ -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;
 }
@@ -5238,8 +5242,11 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
           RANGE_POS_CHECK(l, < port->symtab_size);
           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,38 +6568,59 @@ 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))
+  if (get_info && SAME_OBJ(proc, no_val)) {
-    return scheme_false;
+    v = scheme_false;
-
-  a[0] = proc;
-  if (scheme_check_proc_arity(NULL, stxsrc ? 6 : 5, 0, 1, a)) {
-    /* provide modpath_stx to reader */
-  } else if (!get_info && scheme_check_proc_arity(NULL, stxsrc ? 2 : 1, 0, 1, a)) {
-    /* don't provide modpath_stx to reader */
-    modpath_stx = NULL;
   } else {
-    scheme_wrong_contract("#reader",
+    a[0] = proc;
-                          (stxsrc ? "(or/c (any/c any/c . -> . any) (procedure-arity-includes/c 6))"
+    if (scheme_check_proc_arity(NULL, stxsrc ? 6 : 5, 0, 1, a)) {
-                           : (get_info
+      /* provide modpath_stx to reader */
-                              ? "(procedure-arity-includes/c 5)"
+    } else if (!get_info && scheme_check_proc_arity(NULL, stxsrc ? 2 : 1, 0, 1, a)) {
-                              : "(or/c (any/c . -> . any) (procedure-arity-includes/c 5))")),
+      /* don't provide modpath_stx to reader */
-                          -1, -1, a);
+      modpath_stx = NULL;
-    return NULL;
+    } else {
+      scheme_wrong_contract("#reader",
+                            (stxsrc ? "(or/c (any/c any/c . -> . any) (procedure-arity-includes/c 6))"
+                             : (get_info
+                                ? "(procedure-arity-includes/c 5)"
+                                : "(or/c (any/c . -> . any) (procedure-arity-includes/c 5))")),
+                            -1, -1, a);
+      return NULL;
+    }
+    
+    v = readtable_call(0, 0, proc, params,
+                       port, stxsrc, line, col, pos,
+                       get_info, ht, modpath_stx);
+    
+    if (!get_info && scheme_special_comment_value(v))
+      v = NULL;
   }
 
-  v = readtable_call(0, 0, proc, params,
+  if (pop_frame)
-		     port, stxsrc, line, col, pos,
+    scheme_pop_continuation_frame(&cframe);
-		     get_info, ht, modpath_stx);
 
-  if (!get_info && scheme_special_comment_value(v))
+  return v;
-    return NULL;
-  else
-    return v;
 }
 
 /* "#reader" has been read */

racket/src/racket/src/schminc.h

@@ -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

racket/src/racket/src/schpriv.h

@@ -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);

racket/src/racket/src/schvers.h

@@ -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)

racket/src/racket/src/startup.inc

@@ -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)"

racket/src/racket/src/startup.rktl

@@ -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)

racket/src/racket/src/syntax.c

@@ -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,18 +4662,21 @@ 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);
   } else {
     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 (!MULTI_SCOPE_METAP(ht->keys[j])) {
-        if (!scheme_eq_hash_get(mt->reachable_scopes, scope)) {
+        if (!scheme_eq_hash_get(mt->reachable_scopes, scope)
-          scheme_hash_set(mt->reachable_scopes, scope, scheme_true);
+            && !scheme_eq_hash_get(mt->conditionally_reachable_scopes, scope)) {
-          scope = scheme_make_pair(scope, mt->reachable_scope_stack);
+          /* This scope is reachable via its multi-scope, but it only
-          mt->reachable_scope_stack = scope;
+             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,16 +5317,27 @@ 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)) {
-      return 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,13 +5378,85 @@ 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)) {
     scope = (Scheme_Scope *)SCHEME_CAR(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;
+        sorted_keys = scheme_extract_sorted_keys((Scheme_Object *)ht);
-        while ((j = scheme_hash_tree_next(ht, j)) != -1) {
+        count = ht->count;
-          scheme_hash_tree_index(ht, j, &key, &val);
+        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_from_multi(Scheme_Scope *a, Scheme_Scope *b)
-
-static int compare_scopes(const void *a, const void *b)
 {
-  if (*(void **)a == *(void **)b)
+  Scheme_Scope_With_Owner *ao, *bo;
-    return 0;
+  
-  else if ((*(Scheme_Scope **)a)->id > (*(Scheme_Scope **)b)->id)
+  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;
-  else
+  }
+  
+  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)
@@ -5450,8 +5699,8 @@ static Scheme_Object *scopes_to_sorted_list(Scheme_Scope_Set *scopes)
     a[j++] = key;
     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 *a = *(Scheme_Object **)_a;
-  Scheme_Object *b = (Scheme_Object *)_b;
+  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])) {
-        SCHEME_VEC_ELS(vec)[j++] = scopes->keys[i]; /* a phase */
+        if (scheme_hash_get(mt->reachable_scopes, scopes->vals[i])) {
-        SCHEME_VEC_ELS(vec)[j++] = scopes->vals[i]; /* a scope */
+          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;
+      intptr_t count = ht->count;
-      while ((i = scheme_hash_tree_next(ht, i)) != -1) {
+      sorted_keys = scheme_extract_sorted_keys((Scheme_Object *)ht);
-        scheme_hash_tree_index(ht, i, &key, &val);
+      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];
@@ -6156,8 +6475,16 @@ 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)) {