350.3

svn: r3571

collects/compiler/private/xform.ss

@@ -2562,18 +2562,25 @@
                                   [(null? body)
                                    ;; Starting live-vars record for this block:
                                    ;;  Create new tag
-                                   ;;  Locally-defined arrays and records are always live.
+                                   ;;  Locally-defined arrays, records, and & variables, are always live.
                                    ;;  Start with -1 maxlive in case we want to check whether anything
                                    ;;   was pushed in the block.
                                    (values null (make-live-var-info (gentag)
                                                                     -1
                                                                     0
                                                                     (append
+								     (let loop ([vars extra-vars])
+								       (cond
+									[(null? vars) null]
+									[(memq (caar vars) &-vars)
+									 (cons (car vars) (loop (cdr vars)))]
+									[else (loop (cdr vars))]))
                                                                      (let loop ([vars local-vars])
                                                                        (cond
                                                                          [(null? vars) null]
                                                                          [(or (array-type? (cdar vars))
-                                                                              (struc-type? (cdar vars)))
+                                                                              (struc-type? (cdar vars))
+									      (memq (caar vars) &-vars))
                                                                           (cons (car vars) (loop (cdr vars)))]
                                                                          [else (loop (cdr vars))]))
                                                                      (live-var-info-vars live-vars))

collects/mzlib/cm.ss

@@ -210,7 +210,7 @@
   (define (compile-root mode path up-to-date)
     (let ([path (simplify-path (expand-path path))])
       (let ((stamp (and up-to-date
-			(hash-table-get up-to-date path (lambda () #f)))))
+			(hash-table-get up-to-date path #f))))
 	(cond
           (stamp stamp)
           (else

collects/mzlib/private/class-internal.ss

@@ -802,7 +802,7 @@
 			     (lambda (what l)
 			       (let ([ht (make-hash-table)])
 				 (for-each (lambda (id)
-					     (when (hash-table-get ht (syntax-e id) (lambda () #f))
+					     (when (hash-table-get ht (syntax-e id) #f)
 					       (bad (format "duplicate declared external ~a name" what) id))
 					     (hash-table-put! ht (syntax-e id) #t))
 					   l)))])
@@ -820,20 +820,20 @@
 			    [stx-ht (make-hash-table)])
 			(for-each
 			 (lambda (defined-name)
-			   (let ([l (hash-table-get ht (syntax-e defined-name) (lambda () null))])
+			   (let ([l (hash-table-get ht (syntax-e defined-name) null)])
 			     (hash-table-put! ht (syntax-e defined-name) (cons defined-name l))))
 			 defined-method-names)
 			(for-each
 			 (lambda (defined-name)
-			   (let ([l (hash-table-get stx-ht (syntax-e defined-name) (lambda () null))])
+			   (let ([l (hash-table-get stx-ht (syntax-e defined-name) null)])
 			     (hash-table-put! stx-ht (syntax-e defined-name) (cons defined-name l))))
 			 defined-syntax-names)
 			(for-each
 			 (lambda (pubovr-name)
-			   (let ([l (hash-table-get ht (syntax-e pubovr-name) (lambda () null))])
+			   (let ([l (hash-table-get ht (syntax-e pubovr-name) null)])
 			     (unless (ormap (lambda (i) (bound-identifier=? i pubovr-name)) l)
 			       ;; Either undefined or defined as syntax:
-			       (let ([stx-l (hash-table-get stx-ht (syntax-e pubovr-name) (lambda () null))])
+			       (let ([stx-l (hash-table-get stx-ht (syntax-e pubovr-name) null)])
 				 (if (ormap (lambda (i) (bound-identifier=? i pubovr-name)) stx-l)
 				     (bad 
 				      "method declared but defined as syntax"
@@ -850,7 +850,7 @@
 				      (hash-table-put! ht (syntax-e (cdr pub)) #t))
 				    (append publics public-finals overrides override-finals augrides))
 			  (for-each (lambda (inn)
-				      (when (hash-table-get ht (syntax-e (cdr inn)) (lambda () #f))
+				      (when (hash-table-get ht (syntax-e (cdr inn)) #f)
 					(bad
 					 "inner method is locally declared as public, override, public-final, override-final, or augride"
 					 (cdr inn))))
@@ -1702,7 +1702,7 @@
 	(unless no-new-methods?
 	  (let loop ([ids public-names][p (class-method-width super)])
 	    (unless (null? ids)
-	      (when (hash-table-get method-ht (car ids) (lambda () #f))
+	      (when (hash-table-get method-ht (car ids) #f)
 		(obj-error 'class* "superclass already contains method: ~a~a" 
 			   (car ids)
 			   (for-class name)))
@@ -1711,7 +1711,7 @@
 	(unless no-new-fields?
 	  (let loop ([ids public-field-names][p (class-field-width super)])
 	    (unless (null? ids)
-	      (when (hash-table-get field-ht (car ids) (lambda () #f))
+	      (when (hash-table-get field-ht (car ids) #f)
 		(obj-error 'class* "superclass already contains field: ~a~a" 
 			   (car ids)
 			   (for-class name)))
@@ -1720,7 +1720,7 @@
 
 	;; Check that superclass has expected fields
 	(for-each (lambda (id)
-		    (unless (hash-table-get field-ht id (lambda () #f))
+		    (unless (hash-table-get field-ht id #f)
 		      (obj-error 'class* "superclass does not provide field: ~a~a" 
 				 id
 				 (for-class name))))
@@ -1761,7 +1761,7 @@
 	     (lambda (intf)
 	       (for-each
 		(lambda (var)
-		  (unless (hash-table-get method-ht var (lambda () #f))
+		  (unless (hash-table-get method-ht var #f)
 		    (obj-error 'class* 
 			       "interface-required method missing: ~a~a~a" 
 			       var
@@ -2159,7 +2159,7 @@
        (lambda (super)
 	 (for-each
 	  (lambda (var)
-	    (when (hash-table-get ht var (lambda () #f))
+	    (when (hash-table-get ht var #f)
 	      (obj-error 'interface "variable already in superinterface: ~a~a~a" 
 			 var
 			 (for-intf name)
@@ -2557,7 +2557,7 @@
                        (identifier? (syntax abs-object))
                        (syntax
                         (let* ([c (object-ref abs-object)]
-                               [pos (hash-table-get (class-method-ht c) name (lambda () #f))])
+                               [pos (hash-table-get (class-method-ht c) name #f)])
                           (cond
                             [pos (values (vector-ref (class-methods c) pos) abs-object)]
                             [(wrapper-object? abs-object) wrapper-case]
@@ -2699,7 +2699,7 @@
              [index (hash-table-get 
                      field-ht
                      id
-                     (lambda () #f))])
+		     #f)])
         (cond
           [index
            ((class-field-ref (car index)) obj (cdr index))]
@@ -2729,7 +2729,7 @@
     (let loop ([obj obj])
       (let* ([cls (object-ref obj)]
              [field-ht (class-field-ht cls)])
-        (or (and (hash-table-get field-ht id (lambda () #f))
+        (or (and (hash-table-get field-ht id #f)
                  #t) ;; ensure that only #t and #f leak out, not bindings in ht
             (and (wrapper-object? obj)
                  (loop (wrapper-object-wrapped obj)))))))
@@ -2850,7 +2850,7 @@
       (raise-type-error 'object-method-arity-includes? "non-negative exact integer" cnt))
     (let loop ([o o])
       (let* ([c (object-ref o)]
-	     [pos (hash-table-get (class-method-ht c) name (lambda () #f))])
+	     [pos (hash-table-get (class-method-ht c) name #f)])
 	(cond
 	 [pos (procedure-arity-includes? (vector-ref (class-methods c) pos) 
 					 (add1 cnt))]
@@ -2867,7 +2867,7 @@
     (unless (interface? i)
       (raise-type-error 'interface-extension? "interface" 1 v i))
     (and (interface? i)
-	 (hash-table-get (interface-all-implemented v) i (lambda () #f))))
+	 (hash-table-get (interface-all-implemented v) i #f)))
   
   (define (method-in-interface? s i)
     (unless (symbol? s)

collects/mzlib/private/sigmatch.ss

@@ -10,14 +10,14 @@
 	  (lambda (s)
 	    (cond
 	     [(symbol? s)
-	      (if (hash-table-get table s (lambda () #f))
+	      (if (hash-table-get table s #f)
 		  #f
 		  (begin
 		    (hash-table-put! table s s)
 		    #t))]
 	     [(and (pair? s) (symbol? (car s)))
 	      (let ([name (car s)])
-		(if (hash-table-get table name (lambda () #f))
+		(if (hash-table-get table name #f)
 		  #f
 		  (let ([t (make-hash-table)])
 		    (hash-table-put! table name t)
@@ -33,6 +33,8 @@
 	  (loop (format "~a:~a" s (car path))
 		(cdr path)))))
 
+  (define no-val (gensym))
+
   (define (check-sig-match table sig path exact? who src-context dest-context wrapped? unwrap)
     (and (wrapped? sig)
 	 (vector? (unwrap sig))
@@ -40,8 +42,8 @@
 	  (lambda (s)
 	    (cond
 	     [(symbol? s)
-	      (let ([v (hash-table-get table s
+	      (let ([v (hash-table-get table s no-val)])
-				       (lambda ()
+		(when (eq? v no-val)
 		  (raise
 		   (make-exn:fail:unit
 		    (string->immutable-string
@@ -51,7 +53,7 @@
 		      src-context
 		      (sig-path-name s path)
 		      dest-context))
-					   (current-continuation-marks)))))])
+		    (current-continuation-marks))))
 		(and v
 		     (begin
 		       (unless (symbol? v)
@@ -70,8 +72,8 @@
 		       (hash-table-put! table s #f)
 		       #t)))]
 	     [(and (pair? s) (symbol? (car s)))
-	      (let ([v (hash-table-get table (car s)
+	      (let ([v (hash-table-get table (car s) no-val)])
-				       (lambda ()
+		(when (eq? v no-val)
 		  (raise
 		   (make-exn:fail:unit
 		    (string->immutable-string
@@ -81,7 +83,7 @@
 		      src-context
 		      (sig-path-name (car s) path)
 		      dest-context))
-					   (current-continuation-marks)))))])
+		    (current-continuation-marks))))
 		(and v
 		     (begin
 		       (unless (hash-table? v)

collects/mzlib/unit.ss

@@ -105,7 +105,7 @@
 		      ;; Check that all exports are distinct (as symbols)
 		      (let ([ht (make-hash-table)])
 			(for-each (lambda (name)
-				    (when (hash-table-get ht (syntax-e name) (lambda () #f))
+				    (when (hash-table-get ht (syntax-e name) #f)
 				      (raise-syntax-error
 				       #f
 				       "duplicate export"
@@ -218,17 +218,17 @@
 			      (for-each
 			       (lambda (kind+name)
 				 (let ([name (cdr kind+name)])
-				   (let ([l (hash-table-get ht (syntax-e name) (lambda () null))])
+				   (let ([l (hash-table-get ht (syntax-e name) null)])
 				     (hash-table-put! (if (eq? (car kind+name) 'val) ht stx-ht)
 						      (syntax-e name) 
 						      (cons name l)))))
 			       all-defined-names/kinds)
 			      (for-each 
 			       (lambda (n)
-				 (let ([v (hash-table-get ht (syntax-e n) (lambda () null))])
+				 (let ([v (hash-table-get ht (syntax-e n) null)])
 				   (unless (ormap (lambda (i) (bound-identifier=? i n)) v)
 				     ;; Either not defined, or defined as syntax:
-				     (let ([stx-v (hash-table-get stx-ht (syntax-e n) (lambda () null))])
+				     (let ([stx-v (hash-table-get stx-ht (syntax-e n) null)])
 				       (if (ormap (lambda (i) (bound-identifier=? i n)) stx-v)
 					   (raise-syntax-error
 					    #f
@@ -246,14 +246,14 @@
 			    (let ([ht (make-hash-table)])
 			      (for-each
 			       (lambda (name)
-				 (let ([l (hash-table-get ht (syntax-e name) (lambda () null))])
+				 (let ([l (hash-table-get ht (syntax-e name) null)])
 				   (hash-table-put! ht (syntax-e name) (cons name l))))
 			       exported-names)
 			      (let ([internal-names
 				     (let loop ([l all-defined-val-names])
 				       (cond
 					[(null? l) null]
-					[(let ([v (hash-table-get ht (syntax-e (car l)) (lambda () null))])
+					[(let ([v (hash-table-get ht (syntax-e (car l)) null)])
 					   (ormap (lambda (i) (bound-identifier=? i (car l))) v))
 					 (loop (cdr l))]
 					[else (cons (car l) (loop (cdr l)))]))])

collects/mzlib/unitsig.ss

@@ -57,9 +57,7 @@
 				      (map
 				       (lambda (name)
 					 (list (let ([name (do-rename name (parsed-unit-renames a-unit))])
-						 (hash-table-get vars
+						 (hash-table-get vars name name))
-								 name
-								 (lambda () name)))
 					       name))
 				       (signature-vars sig)))
 				    expr)]

collects/sgl/make-gl-info.ss

@@ -4,6 +4,7 @@
            (prefix dynext: (lib "link.ss" "dynext"))
            (lib "file.ss")
 	   (lib "dirs.ss" "setup")
+	   (lib "launcher.ss" "launcher")
            (lib "string.ss" "srfi" "13"))
   
   (provide make-gl-info)
@@ -113,14 +114,15 @@ end-string
       (dynext:link-extension #f (list file.o) file.so)
       (delete/continue file.o)))
 
-  (define (build-helper compile-directory home)
+  (define (build-helper compile-directory home 3m?)
     (let ((file (build-path compile-directory "make-gl-info-helper"))
           (c (build-path compile-directory "make-gl-info-helper.c"))
           (so (build-path compile-directory
                           "native"
                           (system-library-subpath #f) 
+			  (if 3m? "3m" 'same)
                           "make-gl-info-helper.so")))
-      (make-directory* (build-path compile-directory "native" (system-library-subpath #f)))
+      (make-directory* (build-path compile-directory "native" (system-library-subpath #f) (if 3m? "3m" 'same)))
       (with-output-to-file c
         (lambda () (display c-file))
         'replace)
@@ -166,7 +168,10 @@ end-string
                   (define gl-clampf-size 4)
                   (define gl-clampd-size 8)))
              (else
-              (build-helper compile-directory home)
+              (build-helper compile-directory home #f)
+	      (when (memq '3m (available-mzscheme-variants))
+		(parameterize ([dynext:link-variant '3m])
+		  (build-helper compile-directory home #t)))
               `(module gl-info mzscheme
                  (provide (all-defined))
                  ,@(map 

collects/syntax/primitives.ss

@@ -18,7 +18,8 @@
 	     port-read-handler error-value->string-handler
 	     call/ec call/cc hash-table-get
 	     hash-table-map hash-table-for-each make-input-port make-output-port
-	     current-module-name-resolver))
+	     current-module-name-resolver
+	     call-with-semaphore call-with-semaphore/enable-break))
 
    ;; The following primitives can compute return values by an
    ;;  internal chained tail call (relevant to mzc)
@@ -27,6 +28,8 @@
 	error
 	call-with-current-continuation
 	call-with-escape-continuation
+	call-with-semaphore
+	call-with-semaphore/enable-break
 	hash-table-get
 	write-image-to-file
 	syntax-local-value))

collects/syntax/private/boundmap.ss

@@ -38,7 +38,7 @@
                                 (cdr i)))
                          (hash-table-get (identifier-mapping-ht bi)
                                          (identifier->symbol id) 
-                                         (lambda () null)))
+                                         null))
                   (fail))))
           
           (define identifier-mapping-put!
@@ -46,7 +46,7 @@
               (let ([l (hash-table-get
                         (identifier-mapping-ht bi)
                         (identifier->symbol id) 
-                        (lambda () null))])
+                        null)])
                 (hash-table-put!
                  (identifier-mapping-ht bi)
                  (identifier->symbol id) 

doc/release-notes/mzscheme/HISTORY

@@ -1,3 +1,8 @@
+Version 350.3
+Changed hash-table-get to accept a non-prcedure third argument as
+ a default value (instead of requiring a thunk)
+Improved 3m performance
+
 Version 350.2
 Changed the module name resolver protocol so that the resolver is
  required to accept 1, 3, and 4 arguments; the new 4-argument mode
@@ -6,6 +11,7 @@ Changed namespace-attach-module and namespace-unprotect-module
  to accept quoted module paths, instead of only symbolic names
 Fixed avoidable overflow and undeflow in magnitude and / for
  inexact complex numbers
+Fixed bug in continuation sharing
 
 Version 350.1
 Added define-member-name, member-name-key, and generate-member-key

src/Makefile.in

@@ -34,10 +34,11 @@ mred-stub: @MAKE_MRED@
 
 mred3m-stub: @MAKE_MRED3M@
 
+SETUP_ARGS = -mvqX "$(DESTDIR)$(collectsdir)" -M setup
 
 install:
 	$(MAKE) plain-install
-	$(MAKE) setup-plt
+	"$(DESTDIR)$(bindir)/mzscheme3m" $(SETUP_ARGS)
 	$(MAKE) fix-paths
 
 plain-install:
@@ -52,9 +53,6 @@ install-normal:
 
 mredinstall-stub: @MAKE_MREDINSTALL@
 
-setup-plt:
-	"$(DESTDIR)$(bindir)/mzscheme" -mvqX "$(DESTDIR)$(collectsdir)" -M setup
-
 plain-install-3m:
 	$(MAKE) install-normal
 	$(MAKE) mzinstall3m
@@ -62,7 +60,7 @@ plain-install-3m:
 
 install-3m:
 	$(MAKE) plain-install-3m
-	$(MAKE) setup-plt
+	"$(DESTDIR)$(bindir)/mzscheme3m" $(SETUP_ARGS)
 	$(MAKE) fix-paths
 
 mredinstall3m-stub: @MAKE_MREDINSTALL3M@

src/mzscheme/gc2/Makefile.in

@@ -289,6 +289,7 @@ main.@LTO@: $(XSRCDIR)/main.c
 
 gc2.@LTO@: $(srcdir)/gc2.c $(srcdir)/newgc.c $(srcdir)/compact.c $(srcdir)/newgc.c $(srcdir)/gc2.h \
        $(srcdir)/vm_osx.c $(srcdir)/vm_mmap.c $(srcdir)/vm_osk.c $(srcdir)/alloc_cache.c $(srcdir)/my_qsort.c \
+       $(srcdir)/page_range.c $(srcdir)/protect_range.c $(srcdir)/../utils/splay.c \
        $(srcdir)/weak.c $(srcdir)/fnls.c $(srcdir)/../include/scheme.h $(srcdir)/../src/schpriv.h
 	$(CC) $(CFLAGS) -c $(srcdir)/gc2.c -o gc2.@LTO@
 

src/mzscheme/gc2/alloc_cache.c

@@ -6,7 +6,7 @@
    Requires (defined earlier):
       system_free_pages --- called with len already rounded up to page size
       page_size --- in bytes
-      my_qsort --- possibyl from my_qsort.c
+      my_qsort --- possibly from my_qsort.c
       LOGICALLY_ALLOCATING_PAGES(len)
       ACTUALLY_ALLOCATING_PAGES(len)
       LOGICALLY_FREEING_PAGES(len)
@@ -16,7 +16,7 @@
 typedef struct {
   void *start;
   long len;
-  int age;
+  short age, zeroed;
 } Free_Block;
 
 #define BLOCKFREE_UNMAP_AGE 1
@@ -43,6 +43,8 @@ static void collapse_adjacent_pages(void)
       blockfree[j].len += blockfree[i].len;
       blockfree[i].start = NULL;
       blockfree[i].len = 0;
+      if (!blockfree[i].zeroed)
+	blockfree[j].zeroed = 0;
     } else
       j = i;
   }
@@ -60,6 +62,7 @@ inline static void *find_cached_pages(size_t len, size_t alignment)
       if (!alignment || !((unsigned long)r & (alignment - 1))) {
 	blockfree[i].start = NULL;
 	blockfree[i].len = 0;
+	if (!blockfree[i].zeroed)
 	  memset(r, 0, len);
 	LOGICALLY_ALLOCATING_PAGES(len);
 	return r;
@@ -75,6 +78,7 @@ inline static void *find_cached_pages(size_t len, size_t alignment)
       if (!alignment || !((unsigned long)r & (alignment - 1))) {
 	blockfree[i].start += len;
 	blockfree[i].len -= len;
+	if (!blockfree[i].zeroed)
 	  memset(r, 0, len);
 	LOGICALLY_ALLOCATING_PAGES(len);
 	return r;
@@ -84,6 +88,7 @@ inline static void *find_cached_pages(size_t len, size_t alignment)
       r = blockfree[i].start + (blockfree[i].len - len);
       if (!((unsigned long)r & (alignment - 1))) {
 	blockfree[i].len -= len;
+	if (!blockfree[i].zeroed)
 	  memset(r, 0, len);
 	LOGICALLY_ALLOCATING_PAGES(len);
 	return r;
@@ -98,7 +103,7 @@ inline static void *find_cached_pages(size_t len, size_t alignment)
   return NULL;
 }
 
-static void free_pages(void *p, size_t len)
+static void free_actual_pages(void *p, size_t len, int zeroed)
 {
   int i;
 
@@ -106,19 +111,21 @@ static void free_pages(void *p, size_t len)
   if (len & (page_size - 1))
     len += page_size - (len & (page_size - 1));
 
-  LOGICALLY_FREEING_PAGES(len);
-
   /* Try to free pages in larger blocks, since the OS may be slow. */
 
   for (i = 0; i < BLOCKFREE_CACHE_SIZE; i++)
     if(blockfree[i].start && (blockfree[i].len < (1024 * 1024))) {
       if (p == blockfree[i].start + blockfree[i].len) {
 	blockfree[i].len += len;
+	if (!zeroed)
+	  blockfree[i].zeroed = 0;
 	return;
       }
       if (p + len == blockfree[i].start) {
 	blockfree[i].start = p;
 	blockfree[i].len += len;
+	if (!zeroed)
+	  blockfree[i].zeroed = 0;
 	return;
       }
     }
@@ -128,6 +135,7 @@ static void free_pages(void *p, size_t len)
       blockfree[i].start = p;
       blockfree[i].len = len;
       blockfree[i].age = 0;
+      blockfree[i].zeroed = zeroed;
       return;
     }
   }
@@ -140,6 +148,12 @@ static void free_pages(void *p, size_t len)
   ACTUALLY_FREEING_PAGES(len);
 }
 
+static void free_pages(void *p, size_t len)
+{
+  LOGICALLY_FREEING_PAGES(len);
+  free_actual_pages(p, len, 0);
+}
+
 static void flush_freed_pages(void)
 {
   int i;

src/mzscheme/gc2/compact.c

@@ -3932,6 +3932,11 @@ void *GC_malloc_one_tagged(size_t size_in_bytes)
   return m;
 }
 
+void *GC_malloc_one_small_tagged(size_t size_in_bytes)
+{
+  return GC_malloc_one_tagged(size_in_bytes);
+}
+
 #ifndef gcINLINE
 # define gcINLINE inline
 #endif
@@ -4096,7 +4101,7 @@ void GC_free(void *p)
   }
 }
 
-long GC_malloc_atomic_stays_put_threshold() 
+long GC_malloc_stays_put_threshold() 
 { 
   return BIGBLOCK_MIN_SIZE;
 }

src/mzscheme/gc2/fnls.c

@@ -32,7 +32,13 @@ static int num_fnls;
 #define Tree Fnl
 #define Splay_Item(t) ((unsigned long)t->p)
 #define Set_Splay_Item(t, v) (t)->p = (void *)v
-#include "../sgc/splay.c"
+#define splay fnl_splay
+#define splay_insert fnl_splay_insert
+#define splay_delete fnl_splay_delete
+#include "../utils/splay.c"
+#undef splay
+#undef splay_insert
+#undef splay_delete
 
 void GC_set_finalizer(void *p, int tagged, int level, void (*f)(void *p, void *data), 
 		      void *data, void (**oldf)(void *p, void *data), 
@@ -47,7 +53,7 @@ void GC_set_finalizer(void *p, int tagged, int level, void (*f)(void *p, void *d
     return;
   }
 
-  splayed_finalizers = splay((unsigned long)p, splayed_finalizers);
+  splayed_finalizers = fnl_splay((unsigned long)p, splayed_finalizers);
   fnl = splayed_finalizers;
   if (fnl && (fnl->p == p)) {
     if (oldf) *oldf = fnl->f;
@@ -64,7 +70,7 @@ void GC_set_finalizer(void *p, int tagged, int level, void (*f)(void *p, void *d
       if (fnl->next)
 	fnl->next->prev = fnl->prev;
       --num_fnls;
-      splayed_finalizers = splay_delete((unsigned long)p, splayed_finalizers);
+      splayed_finalizers = fnl_splay_delete((unsigned long)p, splayed_finalizers);
     }
     return;
   }
@@ -125,7 +131,7 @@ void GC_set_finalizer(void *p, int tagged, int level, void (*f)(void *p, void *d
 #endif
 
   finalizers = fnl;
-  splayed_finalizers = splay_insert((unsigned long)p, fnl, splayed_finalizers);
+  splayed_finalizers = fnl_splay_insert((unsigned long)p, fnl, splayed_finalizers);
 
   num_fnls++;
 }
@@ -140,7 +146,7 @@ static void reset_finalizer_tree()
 
   for (fnl = finalizers; fnl; fnl = fnl->next) {
     fnl->prev = prev;
-    splayed_finalizers = splay_insert((unsigned long)fnl->p, fnl, splayed_finalizers);
+    splayed_finalizers = fnl_splay_insert((unsigned long)fnl->p, fnl, splayed_finalizers);
     prev = fnl;
   }
 }

src/mzscheme/gc2/gc2.h

@@ -126,6 +126,11 @@ GC2_EXTERN void *GC_malloc_one_tagged(size_t);
    Alloc a tagged item, initially zeroed.  MzScheme sets the tag
    before a collection. */
 
+GC2_EXTERN void *GC_malloc_one_small_tagged(size_t);
+/* 
+   Like GC_malloc_one_tagged, but the size must be less than 1kb,
+   it must not be zero, and it must be a multiple of the word size. */
+
 GC2_EXTERN void *GC_malloc_one_xtagged(size_t);
 /* 
    Alloc an item, initially zeroed. Rather than having a specific tag,
@@ -191,10 +196,11 @@ GC2_EXTERN void GC_free_immobile_box(void **b);
    Allocate (or free) a non-GCed box containing a pointer to a GCed
    value.  The pointer is stored as the first longword of the box. */
 
-GC2_EXTERN long GC_malloc_atomic_stays_put_threshold();
+GC2_EXTERN long GC_malloc_stays_put_threshold();
 /*
-   Returns a minimum size for which atomic allocations generate
+   Returns a minimum size for which allocations generate
-   objects that never move. */
+   objects that never move, and where pointers are allowed
+   into the object's interior. */
 
 /***************************************************************************/
 /* Memory tracing                                                          */

src/mzscheme/gc2/newgc.c

@@ -164,6 +164,8 @@ inline static void free_used_pages(size_t len)
 #define LOGICALLY_FREEING_PAGES(len) free_used_pages(len)
 #define ACTUALLY_FREEING_PAGES(len) /* empty */
 
+#include "page_range.c"
+
 #if _WIN32
 # include "vm_win.c"
 # define MALLOCATOR_DEFINED
@@ -185,6 +187,8 @@ void designate_modified(void *p);
 # include "vm_mmap.c"
 #endif
 
+#include "protect_range.c"
+
 #define malloc_dirty_pages(size,align) malloc_pages(size,align)
 
 /*****************************************************************************/
@@ -476,7 +480,29 @@ void *GC_malloc_atomic_uncollectable(size_t s) { return malloc(s); }
 void *GC_malloc_allow_interior(size_t s) {return allocate_big(s, PAGE_ARRAY);}
 void GC_free(void *p) {}
 
-long GC_malloc_atomic_stays_put_threshold() { return gcWORDS_TO_BYTES(MAX_OBJECT_SIZEW); }
+void *GC_malloc_one_small_tagged(size_t sizeb)
+{
+  unsigned long newsize;
+
+  sizeb += WORD_SIZE;
+  newsize = gen0_alloc_page->size + sizeb;
+
+  if(newsize > GEN0_PAGE_SIZE) {
+    return GC_malloc_one_tagged(sizeb - WORD_SIZE);
+  } else {
+    void *retval = PTR(NUM(gen0_alloc_page) + gen0_alloc_page->size);
+    struct objhead *info = (struct objhead *)retval;
+
+    /* info->type = type; */ /* We know that the type field is already 0 */
+    info->size = (sizeb >> gcLOG_WORD_SIZE);
+    gen0_alloc_page->size = newsize;
+    gen0_current_size += sizeb;
+    
+    return PTR(NUM(retval) + WORD_SIZE);
+  }
+}
+
+long GC_malloc_stays_put_threshold() { return gcWORDS_TO_BYTES(MAX_OBJECT_SIZEW); }
 
 /* this function resizes generation 0 to the closest it can get (erring high)
    to the size we've computed as ideal */
@@ -563,7 +589,6 @@ inline static void reset_nursery(void)
 /*   } */
   
   resize_gen0(new_gen0_size);
-  flush_freed_pages();
 }
 
 /* This procedure fundamentally returns true if a pointer is marked, and
@@ -1805,6 +1830,8 @@ void GC_init_type_tags(int count, int weakbox, int ephemeron, int weakarray)
 			   fixup_weak_array, 0, 0);
     initialize_signal_handler();
     GC_add_roots(&park, (char *)&park + sizeof(park) + 1);
+
+    initialize_protect_page_ranges(malloc_dirty_pages(APAGE_SIZE, APAGE_SIZE), APAGE_SIZE);
   }
 }
 
@@ -2268,9 +2295,14 @@ static void prepare_pages_for_collection(void)
   if(gc_full) {
     /* we need to make sure that previous_size for every page is reset, so
        we don't accidentally screw up the mark routine */
+    if (generations_available) {
+      for(i = 0; i < PAGE_TYPES; i++)
+	for(work = pages[i]; work; work = work->next)
+	  add_protect_page_range(work, work->big_page ? work->size : APAGE_SIZE, APAGE_SIZE, 1);
+      flush_protect_page_ranges(1);
+    }
     for(i = 0; i < PAGE_TYPES; i++)
       for(work = pages[i]; work; work = work->next) {
-	protect_pages(work, work->big_page ? work->size : APAGE_SIZE, 1);
 	work->live_size = 0;
 	work->previous_size = HEADER_SIZEB;
       }
@@ -2279,9 +2311,11 @@ static void prepare_pages_for_collection(void)
        pages in pages[] from the page map */
     for(i = 0; i < PAGE_TYPES; i++)
       for(work = pages[i]; work; work = work->next) {
-	protect_pages(work, work->big_page ? work->size : APAGE_SIZE, 1);
+	if (generations_available)
+	  add_protect_page_range(work, work->big_page ? work->size : APAGE_SIZE, APAGE_SIZE, 1);
 	pagemap_remove(work);
       }
+    flush_protect_page_ranges(1);
   }
 
   /* we do this here because, well, why not? */
@@ -2330,7 +2364,6 @@ static void mark_backpointers(void)
 	  }
 	  work->previous_size = HEADER_SIZEB;
 	} else {
-	  protect_pages(work, work->big_page ? work->size : APAGE_SIZE, 1);
 	  GCDEBUG((DEBUGOUTF,"Setting previous_size on %p to %i\n", work,
 		   work->size));
 	  work->previous_size = work->size;
@@ -2632,7 +2665,9 @@ static void protect_old_pages(void)
     if(i != PAGE_ATOMIC)
       for(page = pages[i]; page; page = page->next)
 	if(page->page_type != PAGE_ATOMIC) 
-	  protect_pages(page, page->size, 0);
+	  add_protect_page_range(page, page->size, APAGE_SIZE, 0);
+
+  flush_protect_page_ranges(0);
 }
 
 static void gc_overmem_abort()
@@ -2724,6 +2759,7 @@ static void garbage_collect(int force_full)
   do_btc_accounting();
   if (generations_available)
     protect_old_pages();
+  if (gc_full)
     flush_freed_pages();
   reset_finalizer_tree();
 

src/mzscheme/gc2/page_range.c

@@ -0,0 +1,145 @@
+
+/* 
+   Provides:
+    initialize_page_ranges
+    flush_page_ranges
+    add_page_range
+*/
+
+typedef struct Range {
+  unsigned long start, len;
+  struct Range *left, *right, *prev, *next;
+} Range;
+
+#define Tree Range
+#define Splay_Item(t) (t)->start
+#define Set_Splay_Item(t, v) (t)->start = (v)
+#define splay range_splay
+#define splay_insert range_splay_insert
+#define OMIT_SPLAY_DELETE
+#include "../utils/splay.c"
+#undef splay
+#undef splay_insert
+#undef OMIT_SPLAY_DELETE
+#undef Tree
+#undef Splay_Item
+#undef Set_Splay_Item
+
+typedef struct Page_Range {
+  Range *range_root, *range_start;
+  void *range_alloc_block;
+  unsigned long range_alloc_size;
+  unsigned long range_alloc_used;
+} Page_Range;
+
+static void initialize_page_ranges(Page_Range *pr, void *block, unsigned long size)
+{
+  pr->range_root = NULL;
+  pr->range_start = NULL;
+  pr->range_alloc_block = block;
+  pr->range_alloc_size = size;
+  pr->range_alloc_used = 0;
+}
+
+static void compact_page_ranges(Page_Range *pr)
+{
+  Range *work, *next;
+  unsigned long start, len;
+
+  for (work = pr->range_start; work; work = next) {
+    next = work->next;
+
+    start = work->start;
+    len = work->len;
+
+    /* Collapse adjacent nodes: */
+    while (next && (next->start == start + len)) {
+      len += next->len;
+      next = next->next;
+    }
+
+    work->start = start;
+    work->len = len;
+    work->next = next;
+  }
+}
+
+static void reset_page_ranges(Page_Range *pr)
+{
+  pr->range_alloc_used = 0;
+  pr->range_root = NULL;
+  pr->range_start = NULL;
+}
+
+static int try_extend(Range *r, unsigned long start, unsigned long len)
+{
+  if (!r)
+    return 0;
+
+  if (r->start == start + len) {
+    r->start = start;
+    r->len += len;
+    return 1;
+  }
+  if (r->start + r->len == start) {
+    r->len += len;
+    return 1;
+  }
+
+  return 0;
+ }
+
+static int add_page_range(Page_Range *pr, void *_start, unsigned long len, unsigned long alignment)
+{
+  unsigned long start = (unsigned long)_start;
+  Range *r, *range_root = pr->range_root;
+
+  len += (alignment - 1);
+  len -= (len & (alignment - 1));
+
+  range_root = range_splay(start, range_root);
+
+  if (range_root) {
+    if (try_extend(range_root, start, len)
+	|| try_extend(range_root->prev, start, len)
+	|| try_extend(range_root->next, start, len)) {
+      pr->range_root = range_root;
+      return 1;
+    }
+  }
+
+  r = (Range *)((char *)pr->range_alloc_block + pr->range_alloc_used);
+  pr->range_alloc_used += sizeof(Range);
+  if (pr->range_alloc_used > pr->range_alloc_size) {
+    return 0;
+  } else {
+    r->len = len;
+    if (range_root) {
+      if (start < range_root->start) {
+	r->next = range_root;
+	r->prev = range_root->prev;
+	if (r->prev)
+	  r->prev->next = r;
+	else
+	  pr->range_start = r;
+	range_root->prev = r;
+      } else {
+	r->prev = range_root;
+	r->next = range_root->next;
+	if (r->next)
+	  r->next->prev = r;
+	range_root->next = r;
+      }
+      range_root = range_splay_insert(start, r, range_root);
+    } else {
+      r->prev = r->next = NULL;
+      r->left = r->right = NULL;
+      range_root = r;
+      r->start = start;
+      pr->range_start = r;
+    }
+    pr->range_root = range_root;
+    return 1;
+  }
+}
+

src/mzscheme/gc2/protect_range.c

@@ -0,0 +1,34 @@
+/*
+  Provides:
+  Requires:
+   [page_range.c exports]
+   [page allocator]
+*/
+
+static Page_Range protect_range;
+
+static void initialize_protect_page_ranges(void *block, unsigned long size)
+{
+  initialize_page_ranges(&protect_range, block, size);
+}
+
+static void flush_protect_page_ranges(int writeable)
+{
+  Range *work;
+
+  compact_page_ranges(&protect_range);
+
+  for (work = protect_range.range_start; work; work = work->next) {
+    protect_pages((void *)work->start, work->len, writeable);
+  }
+
+  reset_page_ranges(&protect_range);
+}
+
+static void add_protect_page_range(void *_start, unsigned long len, unsigned long alignment, int writeable)
+{
+  if (!add_page_range(&protect_range, _start, len, alignment)) {
+    flush_protect_page_ranges(writeable);
+    add_page_range(&protect_range, _start, len, alignment);
+  }
+}

src/mzscheme/gc2/vm_mmap.c

@@ -95,9 +95,17 @@ static void *malloc_pages(size_t len, size_t alignment)
     if (pre_extra)
       if (munmap(r, pre_extra))
 	GCPRINT(GCOUTF, "Unmap warning: %lx, %ld, %d\n", (long)r, pre_extra, errno);
-    if (pre_extra < extra)
+    if (pre_extra < extra) {
+      if (!pre_extra) {
+	/* Instead of actually unmapping, put it in the cache, and there's
+	   a good chance we can use it next time: */
+	ACTUALLY_ALLOCATING_PAGES(extra);
+	free_actual_pages(real_r + len, extra, 1);
+      } else {
 	if (munmap(real_r + len, extra - pre_extra))
 	  GCPRINT(GCOUTF, "Unmap warning: %lx, %ld, %d\n", (long)r, pre_extra, errno);
+      }
+    }
     r = real_r;
   }
 

src/mzscheme/gc2/vm_osx.c

@@ -55,8 +55,9 @@ void designate_modified(void *p);
 # define CHECK_USED_AGAINST_MAX(x) /* empty */
 #endif
 
-/* Forward declaration: */
+/* Forward declarations: */
 inline static void *find_cached_pages(size_t len, size_t alignment);
+static void free_actual_pages(void *p, size_t len, int zeroed);
 
 /* the structure of an exception msg and its reply */
 typedef struct rep_msg {
@@ -130,6 +131,12 @@ static void *malloc_pages(size_t len, size_t alignment)
       }
     }
     if(pre_extra < extra) {
+      if (!pre_extra) {
+	/* Instead of actually unmapping, put it in the cache, and there's
+	   a good chance we can use it next time: */
+	ACTUALLY_ALLOCATING_PAGES(extra);
+	free_actual_pages(real_r + len, extra, 1);
+      } else {
 	retval = vm_deallocate(task_self, (vm_address_t)real_r + len, 
 			       extra - pre_extra);
 	if(retval != KERN_SUCCESS) {
@@ -137,6 +144,7 @@ static void *malloc_pages(size_t len, size_t alignment)
 		  mach_error_string(retval));
 	}
       }
+    }
     r = real_r;
   }
 

src/mzscheme/include/scheme.h

@@ -1413,9 +1413,9 @@ MZ_EXTERN void scheme_jit_setjmp_prepare(mz_jit_jmp_buf b);
 
 /* Allocation */
 #define scheme_alloc_object() \
-   ((Scheme_Object *) scheme_malloc_tagged(sizeof(Scheme_Simple_Object)))
+   ((Scheme_Object *) scheme_malloc_small_tagged(sizeof(Scheme_Simple_Object)))
 #define scheme_alloc_small_object() \
-   ((Scheme_Object *) scheme_malloc_tagged(sizeof(Scheme_Small_Object)))
+   ((Scheme_Object *) scheme_malloc_small_tagged(sizeof(Scheme_Small_Object)))
 #define scheme_alloc_stubborn_object() \
    ((Scheme_Object *) scheme_malloc_stubborn_tagged(sizeof(Scheme_Simple_Object)))
 #define scheme_alloc_stubborn_small_object() \
@@ -1459,6 +1459,7 @@ void *scheme_malloc(size_t size);
 #  include "../gc2/gc2.h"
 # endif
 # define scheme_malloc_tagged GC_malloc_one_tagged
+# define scheme_malloc_small_tagged(s) GC_malloc_one_small_tagged(gcWORDS_TO_BYTES(gcBYTES_TO_WORDS(s)))
 # define scheme_malloc_array_tagged GC_malloc_array_tagged
 # define scheme_malloc_atomic_tagged GC_malloc_atomic_tagged
 # define scheme_malloc_stubborn_tagged GC_malloc_one_tagged
@@ -1479,6 +1480,7 @@ extern void *scheme_malloc_uncollectable_tagged(size_t);
 extern void *scheme_malloc_envunbox(size_t);
 # else
 #  define scheme_malloc_tagged scheme_malloc
+#  define scheme_malloc_small_tagged scheme_malloc
 #  define scheme_malloc_array_tagged scheme_malloc
 #  define scheme_malloc_atomic_tagged scheme_malloc_atomic
 #  define scheme_malloc_stubborn_tagged scheme_malloc_stubborn

src/mzscheme/sgc/sgc.c

@@ -572,7 +572,7 @@ typedef struct {
 static SectorPage **sector_pagetables;
 
 #if !RELEASE_UNUSED_SECTORS
-# include "splay.c"
+# include "../utils/splay.c"
 
 typedef struct SectorFreepage {
   long size; 

src/mzscheme/src/bignum.c

@@ -164,7 +164,7 @@ Scheme_Object *scheme_make_bignum(long v)
   Small_Bignum *r;
   r = MALLOC_ONE_TAGGED(Small_Bignum);
 #if MZ_PRECISE_GC
-  SCHEME_SET_BIGINLINE(&r->o, 1);
+  SCHEME_SET_BIGINLINE(&r->o);
 #endif
   return scheme_make_small_bignum(v, r);
 }
@@ -174,7 +174,7 @@ Scheme_Object *scheme_make_bignum_from_unsigned(unsigned long v)
   Small_Bignum *r;
   r = MALLOC_ONE_TAGGED(Small_Bignum);
 #if MZ_PRECISE_GC
-  SCHEME_SET_BIGINLINE(&r->o, 1);
+  SCHEME_SET_BIGINLINE(&r->o);
 #endif
   r->o.iso.so.type = scheme_bignum_type;
   SCHEME_SET_BIGPOS(&r->o, 1);
@@ -252,7 +252,7 @@ Scheme_Object *scheme_make_bignum_from_unsigned_long_long(umzlonglong v)
     Small_Bignum *r;
     r = MALLOC_ONE_TAGGED(Small_Bignum);
 #if MZ_PRECISE_GC
-    SCHEME_SET_BIGINLINE(&r->o, 1);
+    SCHEME_SET_BIGINLINE(&r->o);
 #endif
     r->o.iso.so.type = scheme_bignum_type;
     SCHEME_SET_BIGPOS(&r->o, 1);
@@ -441,7 +441,7 @@ static Scheme_Object *make_single_bigdig_result(int pos, bigdig d)
     sm = MALLOC_ONE_TAGGED(Small_Bignum);
     sm->o.iso.so.type = scheme_bignum_type;
 #if MZ_PRECISE_GC
-    SCHEME_SET_BIGINLINE(sm, 1);
+    SCHEME_SET_BIGINLINE(sm);
 #endif
     SCHEME_SET_BIGPOS(sm, pos);
     SCHEME_BIGLEN(sm) = 1;
@@ -562,7 +562,7 @@ Scheme_Object *scheme_bignum_negate(const Scheme_Object *n)
     /* Can't share bigdig array when n is a Small_Bignum */
     o = (Scheme_Object *)scheme_malloc_tagged(sizeof(Small_Bignum));
 #if MZ_PRECISE_GC
-    SCHEME_SET_BIGINLINE(o, 1);
+    SCHEME_SET_BIGINLINE(o);
 #endif
     ((Small_Bignum *)o)->v[0] = SCHEME_BIGDIG(n)[0];
     SCHEME_BIGDIG(o) = ((Small_Bignum *) mzALIAS o)->v;

src/mzscheme/src/fun.c

@@ -2590,7 +2590,7 @@ apply(int argc, Scheme_Object *argv[])
   }
   num_rands += (argc - 2);
 
-  if (1 || num_rands > p->tail_buffer_size) {
+  if (num_rands > p->tail_buffer_size) {
     rand_vec = MALLOC_N(Scheme_Object *, num_rands);
     /* num_rands might be very big, so don't install it as the tail buffer */
   } else

src/mzscheme/src/hash.c

@@ -28,16 +28,37 @@
 #include <ctype.h>
 #include <math.h>
 
+int scheme_hash_request_count;
+int scheme_hash_iteration_count;
+
 #ifdef MZ_PRECISE_GC
-# define PTR_TO_LONG(p) scheme_hash_key(p)
+static short keygen;
-#else
+XFORM_NONGCING static 
-# ifdef DOS_MEMORY
+#ifndef NO_INLINE_KEYWORD
-#  include <dos.h>
+MSC_IZE(inline)
-#  define PTR_TO_LONG(p) ((FP_SEG(p) << 4) + FP_OFF(p))
+#endif
+long PTR_TO_LONG(Scheme_Object *o)
+{
+  short v;
+
+  if (SCHEME_INTP(o))
+    return (long)o;
+
+  v = o->keyex;
+
+  if (!(v & 0xFFFC)) {
+    if (!keygen)
+      keygen += 4;
+    v |= keygen;
+    o->keyex = v;
+    keygen += 4;
+  }
+
+  return (o->type << 16) | v;
+}
 #else
 # define PTR_TO_LONG(p) ((long)(p))
 #endif
-#endif
 
 #define FILL_FACTOR 1.4
 
@@ -51,7 +72,7 @@ long scheme_hash_primes[] =
 
 typedef int (*Hash_Compare_Proc)(void*, void*);
 
-typedef long hash_v_t;
+typedef unsigned long hash_v_t;
 
 /*========================================================================*/
 /*                         hashing functions                              */
@@ -140,27 +161,23 @@ static Scheme_Object *do_hash(Scheme_Hash_Table *table, Scheme_Object *key, int
  rehash_key:
 
   if (table->make_hash_indices) {
-    table->make_hash_indices((void *)key, &h, &h2);
+    table->make_hash_indices((void *)key, (long *)&h, (long *)&h2);
     h = h % size;
     h2 = h2 % size;
   } else {
-    long lkey;
+    unsigned long lkey;
-    lkey = PTR_TO_LONG((Scheme_Object *)key);
+    lkey = (unsigned long)PTR_TO_LONG((Scheme_Object *)key);
     h = (lkey >> 2) % size;
     h2 = (lkey >> 3) % size;
   }
 
-  if (h < 0) h = -h;
+  if (!h2)
-  if (h2 < 0) {
-    h2 = -h2;
-    if (h2 & 0x1)
-      h2++; /* note: table size is never even, so no % needed */
-  } else if (!h2)
     h2 = 2;
 
   keys = table->keys;
   
   if (table->compare) {
+    scheme_hash_request_count++;
     while ((tkey = keys[h])) {
       if (SAME_PTR(tkey, GONE)) {
 	if (set > 1) {
@@ -178,9 +195,11 @@ static Scheme_Object *do_hash(Scheme_Hash_Table *table, Scheme_Object *key, int
 	} else
 	  return table->vals[h];
       }
+      scheme_hash_iteration_count++;
       h = (h + h2) % size;
     }
   } else {
+    scheme_hash_request_count++;
     while ((tkey = keys[h])) {
       if (SAME_PTR(tkey, key)) {
 	if (set) {
@@ -198,6 +217,7 @@ static Scheme_Object *do_hash(Scheme_Hash_Table *table, Scheme_Object *key, int
 	  set = 1;
 	}
       } 
+      scheme_hash_iteration_count++;
       h = (h + h2) % size;
     }
   }
@@ -421,25 +441,23 @@ get_bucket (Scheme_Bucket_Table *table, const char *key, int add, Scheme_Bucket
  rehash_key:
 
   if (table->make_hash_indices) {
-    table->make_hash_indices((void *)key, &h, &h2);
+    table->make_hash_indices((void *)key, (long *)&h, (long *)&h2);
     h = h % table->size;
     h2 = h2 % table->size;
   } else {
-    long lkey;
+    unsigned long lkey;
-    lkey = PTR_TO_LONG((Scheme_Object *)key);
+    lkey = (unsigned long)PTR_TO_LONG((Scheme_Object *)key);
     h = (lkey >> 2) % table->size;
     h2 = (lkey >> 3) % table->size;
   }
 
-  if (h < 0) h = -h;
-  if (h2 < 0) h2 = -h2;
-  
   if (!h2)
     h2 = 2;
   else if (h2 & 0x1)
     h2++;
 
   if (table->weak) {
+    scheme_hash_request_count++;
     while ((bucket = table->buckets[h])) {
       if (bucket->key) {
 	void *hk = (void *)HT_EXTRACT_WEAK(bucket->key);
@@ -456,14 +474,17 @@ get_bucket (Scheme_Bucket_Table *table, const char *key, int add, Scheme_Bucket
 	  return bucket;
       } else if (add)
 	break;
+      scheme_hash_iteration_count++;
       h = (h + h2) % table->size;
     }
   } else {
+    scheme_hash_request_count++;
     while ((bucket = table->buckets[h])) {
       if (SAME_PTR(bucket->key, key))
 	return bucket;
       else if (compare && !compare((void *)bucket->key, (void *)key))
 	return bucket;
+      scheme_hash_iteration_count++;
       h = (h + h2) % table->size;
     }
   }
@@ -697,195 +718,14 @@ int scheme_bucket_table_equal(Scheme_Bucket_Table *t1, Scheme_Bucket_Table *t2)
 
 START_XFORM_SKIP;
 
-typedef long (*Hash_Key_Proc)(Scheme_Object *o);
-Hash_Key_Proc hash_key_procs[_scheme_last_normal_type_];
-static short keygen;
-
-static long hash_addr(Scheme_Object *o)
-{
-  return (long)o;
-}
-
-static long hash_general(Scheme_Object *o)
-{
-  if (!(((short *) mzALIAS o)[1] & 0xFFFC)) {
-    if (!keygen)
-      keygen += 4;
-    ((short *) mzALIAS o)[1] |= keygen;
-    keygen += 4;
-  }
-
-  /* Relies on int = two shorts: */
-  return *(int *) mzALIAS o;
-}
-
-static long hash_symbol(Scheme_Object *o)
-{
-  if (!(((short *) mzALIAS o)[1] & 0xFFFC)) {
-    Scheme_Symbol *s = (Scheme_Symbol *) mzALIAS o;
-    if (!(MZ_OPT_HASH_KEY(&s->iso) & 0x1)) {
-      /* Interned. Make key depend only on the content. */
-      int i, h = 0;
-      for (i = s->len; i--; ) {
-	h += (h << 5) + h + s->s[i];
-      }
-      h += (h << 2);
-      if (!(((short)h) & 0xFFFC))
-	h = 0x10;
-      MZ_OPT_HASH_KEY(&s->iso) |= (((short)h) & 0xFFFC);
-    } else
-      return hash_general(o);
-  }
-
-  /* Relies on int = two shorts: */
-  return *(int *) mzALIAS o;
-}
-
-static long hash_prim(Scheme_Object *o)
-{
-  return (long)((Scheme_Primitive_Proc *)o)->prim_val;
-}
-
-static long hash_case(Scheme_Object *o)
-{
-  Scheme_Case_Lambda *cl = (Scheme_Case_Lambda *)o;
-
-  if (cl->count)
-    return scheme_hash_key(cl->array[0]);
-  else
-    return scheme_case_closure_type << 2;
-}
-
-static long hash_bignum(Scheme_Object *o)
-{
-  int i = SCHEME_BIGLEN(o);
-  bigdig *d = SCHEME_BIGDIG(o);
-  bigdig k = 0;
-  
-  while (i--) {
-    k += d[i];
-  }
-  
-  return (long)k;
-}
-
 void scheme_init_hash_key_procs(void)
 {
-#define PROC(t,f) hash_key_procs[t] = f
+  /* No initialization needed anymore. */
-  PROC(scheme_prim_type, hash_prim);
-  PROC(scheme_closed_prim_type, hash_prim);
-  PROC(scheme_closure_type, hash_general);
-  PROC(scheme_native_closure_type, hash_general);
-  PROC(scheme_case_closure_type, hash_case);
-  PROC(scheme_cont_type, hash_general);
-  PROC(scheme_escaping_cont_type, hash_general);
-  PROC(scheme_char_type, hash_addr);
-  PROC(scheme_bignum_type, hash_bignum);
-  PROC(scheme_rational_type, hash_general);
-  PROC(scheme_float_type, hash_general);
-  PROC(scheme_double_type, hash_general);
-  PROC(scheme_complex_izi_type, hash_general);
-  PROC(scheme_complex_type, hash_general);
-  PROC(scheme_char_string_type, hash_general);
-  PROC(scheme_byte_string_type, hash_general);
-  PROC(scheme_path_type, hash_general);
-  PROC(scheme_symbol_type, hash_symbol);
-  PROC(scheme_keyword_type, hash_symbol);
-  PROC(scheme_null_type, hash_addr);
-  PROC(scheme_pair_type, hash_general);
-  PROC(scheme_wrap_chunk_type, hash_general);
-  PROC(scheme_vector_type, hash_general);
-  PROC(scheme_input_port_type, hash_general);
-  PROC(scheme_output_port_type, hash_general);
-  PROC(scheme_eof_type, hash_addr);
-  PROC(scheme_true_type, hash_addr);
-  PROC(scheme_false_type, hash_addr);
-  PROC(scheme_void_type, hash_addr);
-  PROC(scheme_undefined_type, hash_addr);
-  PROC(scheme_syntax_compiler_type, hash_general);
-  PROC(scheme_macro_type, hash_general);
-  PROC(scheme_box_type, hash_general);
-  PROC(scheme_thread_type, hash_general);
-  PROC(scheme_thread_set_type, hash_general);
-  PROC(scheme_thread_suspend_type, hash_general);
-  PROC(scheme_thread_resume_type, hash_general);
-  PROC(scheme_thread_dead_type, hash_general);
-  PROC(scheme_structure_type, hash_general);
-  PROC(scheme_proc_struct_type, hash_general);
-  PROC(scheme_cont_mark_set_type, hash_general);
-  PROC(scheme_sema_type, hash_general);
-  PROC(scheme_channel_type, hash_general);
-  PROC(scheme_channel_put_type, hash_general);
-  PROC(scheme_hash_table_type, hash_general);
-  PROC(scheme_module_registry_type, hash_general);
-  PROC(scheme_bucket_table_type, hash_general);
-  PROC(scheme_weak_box_type, hash_general);
-  PROC(scheme_ephemeron_type, hash_general);
-  PROC(scheme_struct_type_type, hash_general);
-  PROC(scheme_set_macro_type, hash_general);
-  PROC(scheme_id_macro_type, hash_general);
-  PROC(scheme_listener_type, hash_general);
-  PROC(scheme_namespace_type, hash_general);
-  PROC(scheme_config_type, hash_general);
-  PROC(scheme_thread_cell_type, hash_general);
-  PROC(scheme_thread_cell_values_type, hash_general);
-  PROC(scheme_global_ref_type, hash_general);
-  PROC(scheme_will_executor_type, hash_general);
-  PROC(scheme_stx_type, hash_general);
-  PROC(scheme_module_index_type, hash_general);
-  PROC(scheme_custodian_type, hash_general);
-  PROC(scheme_random_state_type, hash_general);
-  PROC(scheme_regexp_type, hash_general);
-  PROC(scheme_compilation_top_type, hash_general);
-  PROC(scheme_placeholder_type, hash_general);
-  PROC(scheme_inspector_type, hash_general);
-  PROC(scheme_struct_property_type, hash_general);
-  PROC(scheme_rename_table_type, hash_general);
-  PROC(scheme_module_index_type, hash_general);
-  PROC(scheme_variable_type, hash_general);
-  PROC(scheme_module_variable_type, hash_general);
-  PROC(scheme_security_guard_type, hash_general);
-  PROC(scheme_evt_set_type, hash_general);
-  PROC(scheme_udp_type, hash_general);
-  PROC(scheme_udp_evt_type, hash_general);
-  PROC(scheme_wrap_evt_type, hash_general);
-  PROC(scheme_handle_evt_type, hash_general);
-  PROC(scheme_nack_evt_type, hash_general);
-  PROC(scheme_nack_guard_evt_type, hash_general);
-  PROC(scheme_poll_evt_type, hash_general);
-  PROC(scheme_always_evt_type, hash_general);
-  PROC(scheme_never_evt_type, hash_general);
-  PROC(scheme_progress_evt_type, hash_general);
-  PROC(scheme_write_evt_type, hash_general);
-  PROC(scheme_semaphore_repost_type, hash_general);
-  PROC(scheme_string_converter_type, hash_general);
-  PROC(scheme_alarm_type, hash_general);
-  PROC(scheme_special_comment_type, hash_general);
-  PROC(scheme_readtable_type, hash_general);
-#undef PROC
 }
 
 long scheme_hash_key(Scheme_Object *o)
 {
-  Scheme_Type t;
+  return PTR_TO_LONG(o);
-
-  if (SCHEME_INTP(o))
-    return (long)o;
-
-  t = SCHEME_TYPE(o);
-
-  if (t >= _scheme_last_normal_type_) {
-    return hash_general(o);
-  } else {
-#if 0
-    if (!hash_key_procs[t]) {
-      printf("Can't hash %d\n", t);
-      abort();
-    }
-#endif
-    
-    return hash_key_procs[t](o);
-  }
 }
 
 END_XFORM_SKIP;

src/mzscheme/src/jit.c

@@ -344,7 +344,7 @@ static void *generate_one(mz_jit_state *old_jitter,
       } else {
 #ifdef MZ_PRECISE_GC
 	long minsz;
-	minsz = GC_malloc_atomic_stays_put_threshold();
+	minsz = GC_malloc_stays_put_threshold();
 	if (size < minsz)
 	  size = minsz;
 	buffer = (char *)scheme_malloc_atomic(size);

src/mzscheme/src/list.c

@@ -1563,7 +1563,7 @@ static Scheme_Object *hash_table_put(int argc, Scheme_Object *argv[])
 
 static Scheme_Object *hash_table_get(int argc, Scheme_Object *argv[])
 {
-  void *v;
+  Scheme_Object *v;
 
   if (!(SCHEME_HASHTP(argv[0]) || SCHEME_BUCKTP(argv[0])))
     scheme_wrong_type("hash-table-get", "hash-table", 0, argc, argv);
@@ -1571,7 +1571,7 @@ static Scheme_Object *hash_table_get(int argc, Scheme_Object *argv[])
   if (SCHEME_BUCKTP(argv[0])){
     Scheme_Bucket_Table *t = (Scheme_Bucket_Table *)argv[0];
     if (t->mutex) scheme_wait_sema(t->mutex, 0);
-    v = scheme_lookup_in_table(t, (char *)argv[1]);
+    v = (Scheme_Object *)scheme_lookup_in_table(t, (char *)argv[1]);
     if (t->mutex) scheme_post_sema(t->mutex);
   } else {
     Scheme_Hash_Table *t = (Scheme_Hash_Table *)argv[0];
@@ -1581,10 +1581,14 @@ static Scheme_Object *hash_table_get(int argc, Scheme_Object *argv[])
   }
 
   if (v)
-    return (Scheme_Object *)v;
+    return v;
-  else if (argc == 3)
+  else if (argc == 3) {
-    return _scheme_tail_apply(argv[2], 0, NULL);
+    v = argv[2];
-  else {
+    if (SCHEME_PROCP(v))
+      return _scheme_tail_apply(v, 0, NULL);
+    else
+      return v;
+  } else {
     scheme_raise_exn(MZEXN_FAIL_CONTRACT,
 		     "hash-table-get: no value found for key: %V",
 		     argv[1]);

src/mzscheme/src/module.c

@@ -175,7 +175,7 @@ static Scheme_Object *parse_requires(Scheme_Object *form,
 				     Scheme_Object *rn, Scheme_Object *post_ex_rn,
 				     Check_Func ck, void *data,
 				     int start, int expstart, Scheme_Object *redef_modname,
-				     int unpack_kern, int copy_vars,
+				     int unpack_kern, int copy_vars, int can_save_marshal,
 				     int *all_simple);
 static void start_module(Scheme_Module *m, Scheme_Env *env, int restart, Scheme_Object *syntax_idx, int delay_exptime, int with_tt, Scheme_Object *cycle_list);
 static void expstart_module(Scheme_Module *m, Scheme_Env *env, int restart, Scheme_Object *syntax_idx, int delay_exptime, int with_tt, Scheme_Object *cycle_list);
@@ -969,7 +969,7 @@ static Scheme_Object *do_namespace_require(int argc, Scheme_Object *argv[], int
   rn = scheme_make_module_rename(for_exp, mzMOD_RENAME_TOPLEVEL, NULL);
 
   (void)parse_requires(form, scheme_false, env, rn, rn,
-		       NULL, NULL, !etonly, etonly, NULL, 1, copy, NULL);
+		       NULL, NULL, !etonly, etonly, NULL, 1, copy, 0, NULL);
 
   brn = env->rename;
   if (!brn) {
@@ -4142,7 +4142,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
 	  /* Add requires to renaming: */
 	  imods = parse_requires(e, self_modidx, env->genv, 
 				 rn, post_ex_rn, check_require_name, tables, 0, 1,
-				 redef_modname, 0, 0,
+				 redef_modname, 0, 0, 1,
 				 &all_simple_renames);
 	
 	  /* Add required modules to requires list: */
@@ -4160,7 +4160,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
 	  /* Add requires to renaming: */
 	  imods = parse_requires(e, self_modidx, env->genv->exp_env,
 				 et_rn, post_ex_et_rn, check_require_name, et_tables, 1, 0,
-				 redef_modname, 0, 0,
+				 redef_modname, 0, 0, 1,
 				 &et_all_simple_renames);
 
 	  /* Add required modules to et_requires list: */
@@ -4182,7 +4182,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
 	  /* Add requires to renaming: */
 	  imods = parse_requires(e, self_modidx, env->genv->template_env,
 				 tt_rn, post_ex_tt_rn, check_require_name, tt_tables, 0, 0,
-				 redef_modname, 0, 0,
+				 redef_modname, 0, 0, 1,
 				 &tt_all_simple_renames);
 
 	  /* Add required modules to tt_requires list: */
@@ -5171,6 +5171,7 @@ void add_single_require(Scheme_Module_Exports *me, /* from module */
 			Scheme_Object *ename, /* NULL or symbol for a single import */
 			Scheme_Object *mark_src, /* default mark_src; if onlys, each is also mark_src */
 			int unpack_kern, int copy_vars, int for_unmarshal,
+			int can_save_marshal,
 			int *all_simple,
 			Check_Func ck, /* NULL or called for each addition */
 			void *data, Scheme_Object *form, Scheme_Object *cki /* ck args */
@@ -5179,7 +5180,7 @@ void add_single_require(Scheme_Module_Exports *me, /* from module */
   int j, var_count;
   Scheme_Object *orig_idx = idx;
   Scheme_Object **exs, **exsns, **exss;
-  int is_kern, has_context, save_marshal_info = 0, can_save_marshal = 1;
+  int is_kern, has_context, save_marshal_info = 0;
   Scheme_Object *nominal_modidx, *one_exn, *prnt_iname, *name;
   
   if (mark_src) {
@@ -5405,7 +5406,7 @@ void scheme_do_module_rename_unmarshal(Scheme_Object *rn, Scheme_Object *info,
 		     rn, NULL,
 		     exns, NULL, prefix, NULL, NULL,
 		     NULL,
-		     0, 0, 1,
+		     0, 0, 1, 0,
 		     NULL,
 		     NULL,
 		     NULL, NULL, NULL);
@@ -5417,7 +5418,7 @@ Scheme_Object *parse_requires(Scheme_Object *form,
 			      Scheme_Object *rn, Scheme_Object *post_ex_rn,
 			      Check_Func ck, void *data,
 			      int start, int expstart, Scheme_Object *redef_modname,
-			      int unpack_kern, int copy_vars,
+			      int unpack_kern, int copy_vars, int can_save_marshal,
 			      int *all_simple) 
 {
   Scheme_Object *ll = form;
@@ -5641,7 +5642,7 @@ Scheme_Object *parse_requires(Scheme_Object *form,
     add_single_require(m->me, idx, env, rn, post_ex_rn,
 		       exns, onlys, prefix, iname, ename,
 		       mark_src, 
-		       unpack_kern, copy_vars && start, 0,
+		       unpack_kern, copy_vars && start, 0, can_save_marshal,
 		       all_simple,
 		       ck, data, form, i);
 
@@ -5720,7 +5721,7 @@ top_level_require_execute(Scheme_Object *data)
 
   (void)parse_requires(form, modidx, env, rn, rn,
 		       check_dup_require, ht, (for_phase > -1), (for_phase == 0), NULL,
-		       !env->module, 0, NULL);
+		       !env->module, 0, 0, NULL);
 
   brn = env->rename;
   if (!brn) {
@@ -5796,7 +5797,7 @@ static Scheme_Object *do_require(Scheme_Object *form, Scheme_Comp_Env *env,
 
   (void)parse_requires(form, modidx, genv, rn, rn,
 		       check_dup_require, ht, 0, 0, 
-		       NULL, 0, 0, NULL);
+		       NULL, 0, 0, 0, NULL);
 
   if (rec[drec].comp) {
     /* Dummy lets us access a top-level environment: */

src/mzscheme/src/read.c

@@ -262,6 +262,9 @@ typedef struct {
 #define STACK_END(r) (local_list_stack_pos = r.pos, local_list_stack = r.stack)
 
 #ifdef MZ_PRECISE_GC
+/* Although list stacks should work with precise GC as implemented
+   below, there's much less to be gained with a generational GC, so 
+   we keep it simple. */
 # define USE_LISTSTACK(x) 0
 #else
 # define USE_LISTSTACK(x) x
@@ -528,16 +531,35 @@ void scheme_init_read(Scheme_Env *env)
 			     env);
 }
 
+static Scheme_Simple_Object *malloc_list_stack()
+{
+#ifdef MZ_PRECISE_GC
+  long sz = sizeof(Scheme_Simple_Object) * NUM_CELLS_PER_STACK;
+  Scheme_Simple_Object *r;
+
+  if (sz < GC_malloc_stays_put_threshold()) {
+    sz = GC_malloc_stays_put_threshold();
+    while (sz % sizeof(Scheme_Simple_Object)) {
+      sz++;
+    }
+  }
+
+  r = (Scheme_Simple_Object *)GC_malloc_array_tagged(sz);
+
+  /* Must set the tag on the first element: */
+  r[0].iso.so.type = scheme_pair_type;
+  return r;
+#else
+  return MALLOC_N_RT(Scheme_Simple_Object, NUM_CELLS_PER_STACK);
+#endif
+}
+
 void scheme_alloc_list_stack(Scheme_Thread *p)
 {
   Scheme_Simple_Object *sa;
   p->list_stack_pos = 0;
-  sa = MALLOC_N_RT(Scheme_Simple_Object, NUM_CELLS_PER_STACK);
+  sa = malloc_list_stack();
   p->list_stack = sa;
-#ifdef MZ_PRECISE_GC
-  /* Must set the tag on the first element: */
-  p->list_stack[0].iso.so.type = scheme_pair_type;
-#endif
 }
 
 void scheme_clean_list_stack(Scheme_Thread *p)
@@ -545,6 +567,12 @@ void scheme_clean_list_stack(Scheme_Thread *p)
   if (p->list_stack) {
     memset(p->list_stack + p->list_stack_pos, 0,
 	   (NUM_CELLS_PER_STACK - p->list_stack_pos) * sizeof(Scheme_Simple_Object));
+#ifdef MZ_PRECISE_GC
+    if (!p->list_stack_pos) {
+      /* Must set the tag on the first element: */
+      p->list_stack[0].iso.so.type = scheme_pair_type;
+    }
+#endif
   }
 }
 
@@ -2176,7 +2204,7 @@ read_list(Scheme_Object *port,
       if (local_list_stack_pos >= NUM_CELLS_PER_STACK) {
 	/* Overflow */
 	Scheme_Simple_Object *sa;
-	sa = MALLOC_N_RT(Scheme_Simple_Object, NUM_CELLS_PER_STACK);
+	sa = malloc_list_stack();
 	local_list_stack = sa;
 	local_list_stack_pos = 0;
       }
@@ -3700,20 +3728,25 @@ void scheme_ill_formed(struct CPort *port
 		  );
 }
 
-static long read_compact_number(CPort *port)
+/* Since read_compact_number is called often, we want it to be
+   a cheap call in 3m, so avoid anything that allocated --- even
+   error reporting, since we can make up a valid number. */
+#define NUM_ZO_CHECK(x) if (!(x)) return 0;
+
+XFORM_NONGCING static long read_compact_number(CPort *port)
 {
   /* >>> See also read_compact_number_from_port(), below. <<< */
 
   long flag, v, a, b, c, d;
 
-  ZO_CHECK(port->pos < port->size);
+  NUM_ZO_CHECK(port->pos < port->size);
 
   flag = CP_GETC(port);
 
   if (flag < 252)
     return flag;
   else if (flag == 252) {
-    ZO_CHECK(port->pos + 1 < port->size);
+    NUM_ZO_CHECK(port->pos + 1 < port->size);
 
     a = CP_GETC(port);
     b = CP_GETC(port);
@@ -3722,12 +3755,12 @@ static long read_compact_number(CPort *port)
       + (b << 8);
     return v;
   } else if (flag == 254) {
-    ZO_CHECK(port->pos < port->size);
+    NUM_ZO_CHECK(port->pos < port->size);
 
     return -CP_GETC(port);
   }
 
-  ZO_CHECK(port->pos + 3 < port->size);
+  NUM_ZO_CHECK(port->pos + 3 < port->size);
 
   a = CP_GETC(port);
   b = CP_GETC(port);
@@ -4354,7 +4387,7 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
 	if (local_list_stack_pos >= NUM_CELLS_PER_STACK) {
 	  /* Overflow */
 	  Scheme_Simple_Object *sa;
-	  sa = MALLOC_N_RT(Scheme_Simple_Object, NUM_CELLS_PER_STACK);
+	  sa = malloc_list_stack();
 	  local_list_stack = sa;
 	  local_list_stack_pos = 0;
 	}
@@ -4393,7 +4426,7 @@ static Scheme_Object *read_compact_list(int c, int proper, int use_stack, CPort
     if (local_list_stack_pos >= NUM_CELLS_PER_STACK) {
       /* Overflow */
       Scheme_Simple_Object *sa;
-      sa = MALLOC_N_RT(Scheme_Simple_Object, NUM_CELLS_PER_STACK);
+      sa = malloc_list_stack();
       local_list_stack = sa;
       local_list_stack_pos = 0;
     }
@@ -4414,7 +4447,7 @@ static Scheme_Object *read_compact_list(int c, int proper, int use_stack, CPort
       if (local_list_stack_pos >= NUM_CELLS_PER_STACK) {
 	/* Overflow */
 	Scheme_Simple_Object *sa;
-	sa = MALLOC_N_RT(Scheme_Simple_Object, NUM_CELLS_PER_STACK);
+	sa = malloc_list_stack();
 	local_list_stack = sa;
 	local_list_stack_pos = 0;
       }
@@ -4494,7 +4527,7 @@ static Scheme_Object *read_marshalled(int type, CPort *port)
 
 static long read_compact_number_from_port(Scheme_Object *port)
 {
-  /* >>> See also read_compact_number_port(), above. <<< */
+  /* >>> See also read_compact_number(), above. <<< */
 
   long flag, v, a, b, c, d;
 

src/mzscheme/src/schemef.h

@@ -915,7 +915,7 @@ MZ_EXTERN Scheme_Object *scheme_make_location(Scheme_Object *src,
 MZ_EXTERN int scheme_is_location(Scheme_Object *o);
 
 MZ_EXTERN Scheme_Object *scheme_make_inspector(Scheme_Object *superior);
-MZ_EXTERN int scheme_is_subinspector(Scheme_Object *i, Scheme_Object *sup);
+XFORM_NONGCING MZ_EXTERN int scheme_is_subinspector(Scheme_Object *i, Scheme_Object *sup);
 
 /*========================================================================*/
 /*                              utilities                                 */
@@ -926,7 +926,7 @@ MZ_EXTERN int scheme_eqv(Scheme_Object *obj1, Scheme_Object *obj2);
 MZ_EXTERN int scheme_equal(Scheme_Object *obj1, Scheme_Object *obj2);
 
 #ifdef MZ_PRECISE_GC
-MZ_EXTERN long scheme_hash_key(Scheme_Object *o);
+XFORM_NONGCING MZ_EXTERN long scheme_hash_key(Scheme_Object *o);
 #endif
 MZ_EXTERN long scheme_equal_hash_key(Scheme_Object *o);
 MZ_EXTERN long scheme_equal_hash_key2(Scheme_Object *o);

src/mzscheme/src/schpriv.h

@@ -29,7 +29,7 @@
 
 #define _MALLOC_N(x, n, malloc) ((x*)malloc(sizeof(x)*(n)))
 #define MALLOC_ONE(x) _MALLOC_N(x, 1, scheme_malloc)
-#define MALLOC_ONE_TAGGED(x) _MALLOC_N(x, 1, scheme_malloc_tagged)
+#define MALLOC_ONE_TAGGED(x) _MALLOC_N(x, 1, scheme_malloc_small_tagged)
 #define MALLOC_N_TAGGED(x, n) _MALLOC_N(x, n, scheme_malloc_array_tagged)
 #ifdef MZTAG_REQUIRED
 # define scheme_malloc_rt(x) scheme_malloc_tagged(x)
@@ -1107,7 +1107,7 @@ typedef struct {
 # define SCHEME_BIGPOS(b) (MZ_OPT_HASH_KEY(&((Scheme_Bignum *)b)->iso) & 0x1)
 # define SCHEME_SET_BIGPOS(b, v) MZ_OPT_HASH_KEY(&((Scheme_Bignum *)b)->iso) = ((v) | SCHEME_BIGINLINE(b))
 # define SCHEME_BIGINLINE(b) (MZ_OPT_HASH_KEY(&((Scheme_Bignum *)b)->iso) & 0x2)
-# define SCHEME_SET_BIGINLINE(b, v) MZ_OPT_HASH_KEY(&((Scheme_Bignum *)b)->iso) = (((v) << 1) | SCHEME_BIGPOS(b))
+# define SCHEME_SET_BIGINLINE(b) MZ_OPT_HASH_KEY(&((Scheme_Bignum *)b)->iso) |= (0x2 | SCHEME_BIGPOS(b))
 #else
 # define SCHEME_BIGPOS(b) MZ_OPT_HASH_KEY(&((Scheme_Bignum *)b)->iso)
 # define SCHEME_SET_BIGPOS(b, v) SCHEME_BIGPOS(b) = v

src/mzscheme/src/schvers.h

@@ -9,6 +9,6 @@
 
 
 #define MZSCHEME_VERSION_MAJOR 350
-#define MZSCHEME_VERSION_MINOR 2
+#define MZSCHEME_VERSION_MINOR 3
 
-#define MZSCHEME_VERSION "350.2" _MZ_SPECIAL_TAG
+#define MZSCHEME_VERSION "350.3" _MZ_SPECIAL_TAG

src/mzscheme/src/setjmpup.c

@@ -329,7 +329,7 @@ void scheme_copy_stack(Scheme_Jumpup_Buf *b, void *base, void *start GC_VAR_STAC
 
 static void uncopy_stack(int ok, Scheme_Jumpup_Buf *b, long *prev)
 {
-  Scheme_Jumpup_Buf *c;
+  GC_CAN_IGNORE Scheme_Jumpup_Buf *c;
   long top_delta = 0, bottom_delta = 0, size;
   void *cfrom, *cto;
 

src/mzscheme/src/startup.inc

@@ -468,7 +468,8 @@
 "(if(null? l) null(cons-immutable(car l)(list->immutable-list(cdr l))))))"
 "(define-values(get-stx-info)"
 "(lambda(orig-stx super-id defined-names gen-expr?)"
-"(let((qs(if gen-expr?(lambda(x)(and x `((syntax-local-certifier)(quote-syntax ,x)))) values))"
+"(let((cert-id(and gen-expr?(gensym))))"
+"(let((qs(if gen-expr?(lambda(x)(and x `(,cert-id(quote-syntax ,x)))) values))"
 "(every-other(lambda(l)"
 "(let loop((l l)(r null))"
 "(cond"
@@ -502,7 +503,11 @@
 "(map qs(struct-info-mutator-ids super-info)))"
 "(values null null)))"
 "((fields)(cdddr defined-names))"
-"((wrap)(if gen-expr?(lambda(x)(cons 'list-immutable x)) values)))"
+"((wrap)(if gen-expr?(lambda(x)(cons 'list-immutable x)) values))"
+"((total-wrap)(if gen-expr?"
+"(lambda(x) `(let((,cert-id(syntax-local-certifier))) ,x))"
+" values)))"
+"(total-wrap"
 "(wrap"
 "(list-immutable(qs(car defined-names))"
 "(qs(cadr defined-names))"
@@ -519,8 +524,8 @@
 " initial-sets)))"
 "(if super-id"
 "(qs super-id)"
-" #t))))"
+" #t)))))"
-" #f)))))"
+" #f))))))"
 "(provide get-stx-info))"
 );
   EVAL_ONE_STR(
@@ -957,7 +962,7 @@
 "(let loop((r r))"
 "(cond"
 "((syntax? r)"
-"(let((l(hash-table-get ht(syntax-e r)(lambda() null))))"
+"(let((l(hash-table-get ht(syntax-e r) null)))"
 "(when(ormap(lambda(i)(bound-identifier=? i r)) l)"
 "(raise-syntax-error "
 "(syntax-e who)"
@@ -1176,7 +1181,7 @@
 "(if proto-r"
 " #f"
 "(lambda(r)"
-"(let((l(hash-table-get ht(syntax-e r)(lambda() null))))"
+"(let((l(hash-table-get ht(syntax-e r) null)))"
 "(unless(and(pair? l)"
 "(ormap(lambda(i)(bound-identifier=? i r)) l))"
 "(hash-table-put! ht(syntax-e r)(cons r l)))))))))"
@@ -1785,7 +1790,7 @@
 "(unless(identifier? defined-name)"
 "(raise-type-error 'check-duplicate-identifier"
 " \"list of identifiers\" names))"
-"(let((l(hash-table-get ht(syntax-e defined-name)(lambda() null))))"
+"(let((l(hash-table-get ht(syntax-e defined-name) null)))"
 "(when(ormap(lambda(i)(bound-identifier=? i defined-name)) l)"
 "(escape defined-name))"
 "(hash-table-put! ht(syntax-e defined-name)(cons defined-name l))))"
@@ -2871,15 +2876,14 @@
 "((s) "
 "(when planet-resolver"
 "(planet-resolver s))"
-"(let((ht(hash-table-get"
+"(let((ht(or(hash-table-get -module-hash-table-table"
-" -module-hash-table-table"
 "(namespace-module-registry(current-namespace))"
-"(lambda()"
+" #f)"
 "(let((ht(make-hash-table)))"
 "(hash-table-put! -module-hash-table-table"
 "(namespace-module-registry(current-namespace))"
 " ht)"
-" ht)))))"
+" ht))))"
 "(hash-table-put! ht s 'attach)))"
 "((s relto stx)(standard-module-name-resolver s relto stx #t))"
 "((s relto stx load?)"
@@ -2909,7 +2913,7 @@
 "(cond"
 "((string? s)"
 "(let*((dir(get-dir)))"
-"(or(hash-table-get -path-cache(cons s dir)(lambda() #f))"
+"(or(hash-table-get -path-cache(cons s dir) #f)"
 "(let((s(string->bytes/utf-8 s)))"
 "(if(regexp-match-positions -re:ok-relpath s)"
 "(let loop((path dir)(s s))"
@@ -2935,10 +2939,9 @@
 "(not(list? s)))"
 " #f)"
 "((eq?(car s) 'lib)"
-"(hash-table-get"
+"(or(hash-table-get -path-cache"
-" -path-cache"
 "(cons s(current-library-collection-paths))"
-"(lambda()"
+" #f)"
 "(let((cols(let((len(length s)))"
 "(if(= len 2)"
 " (list \"mzlib\")"
@@ -2951,7 +2954,7 @@
 "(string?(cadr s))"
 "(relative-path?(cadr s))"
 "(let((p(-find-col 'standard-module-name-resolver(car cols)(cdr cols))))"
-"(build-path p(cadr s))))))))"
+"(build-path p(cadr s)))))))"
 "((eq?(car s) 'file)"
 "(and(=(length s) 2)"
 "(let((p(cadr s)))"
@@ -2999,17 +3002,16 @@
 "(vector-ref s-parsed 6)"
 "(let((m(regexp-match -re:suffix(path->bytes name))))"
 "(if m(car m) #t))))"
-"(ht(hash-table-get"
+"(ht(or(hash-table-get -module-hash-table-table"
-" -module-hash-table-table"
 "(namespace-module-registry(current-namespace))"
-"(lambda()"
+" #f)"
 "(let((ht(make-hash-table)))"
 "(hash-table-put! -module-hash-table-table"
 "(namespace-module-registry(current-namespace))"
 " ht)"
-" ht)))))"
+" ht))))"
 "(when load?"
-"(let((got(hash-table-get ht modname(lambda() #f))))"
+"(let((got(hash-table-get ht modname #f)))"
 "(when got"
 "(unless(or(symbol? got)(equal? suffix got))"
 "(error"

src/mzscheme/src/startup.ss

@@ -575,7 +575,8 @@
       ;; if `defined-names' is #f.
       ;; If `expr?' is #t, then generate an expression to build the info,
       ;; otherwise build the info directly.
-      (let ([qs (if gen-expr? (lambda (x) (and x `((syntax-local-certifier) (quote-syntax ,x)))) values)]
+      (let ([cert-id (and gen-expr? (gensym))])
+	(let ([qs (if gen-expr? (lambda (x) (and x `(,cert-id (quote-syntax ,x)))) values)]
 	      [every-other (lambda (l)
 			     (let loop ([l l][r null])
 			       (cond
@@ -610,7 +611,11 @@
 					 (map qs (struct-info-mutator-ids super-info)))
 				 (values null null))]
 			    [(fields) (cdddr defined-names)]
-			  [(wrap) (if gen-expr? (lambda (x) (cons 'list-immutable x)) values)])
+			    [(wrap) (if gen-expr? (lambda (x) (cons 'list-immutable x)) values)]
+			    [(total-wrap) (if gen-expr?
+					      (lambda (x) `(let ([,cert-id (syntax-local-certifier)]) ,x))
+					      values)])
+		 (total-wrap
 		  (wrap
 		   (list-immutable (qs (car defined-names))
 				   (qs (cadr defined-names))
@@ -627,8 +632,8 @@
 					     initial-sets)))
 				   (if super-id
 				       (qs super-id)
-				    #t))))
+				       #t)))))
-	     #f)))))
+	       #f))))))
 
   (provide get-stx-info))
 
@@ -1144,7 +1149,7 @@
 	    (let loop ([r r])
 	      (cond
 	       [(syntax? r)
-		(let ([l (hash-table-get ht (syntax-e r) (lambda () null))])
+		(let ([l (hash-table-get ht (syntax-e r) null)])
 		  (when (ormap (lambda (i) (bound-identifier=? i r)) l)
 		    (raise-syntax-error 
 		     (syntax-e who)
@@ -1399,7 +1404,7 @@
 			(if proto-r
 			    #f
 			    (lambda (r)
-			      (let ([l (hash-table-get ht (syntax-e r) (lambda () null))])
+			      (let ([l (hash-table-get ht (syntax-e r) null)])
 				(unless (and (pair? l)
 					     (ormap (lambda (i) (bound-identifier=? i r)) l))
 				  (hash-table-put! ht (syntax-e r) (cons r l)))))))])
@@ -2110,7 +2115,7 @@
 	   (unless (identifier? defined-name)
 	     (raise-type-error 'check-duplicate-identifier
 			       "list of identifiers" names))
-	   (let ([l (hash-table-get ht (syntax-e defined-name) (lambda () null))])
+	   (let ([l (hash-table-get ht (syntax-e defined-name) null)])
 	     (when (ormap (lambda (i) (bound-identifier=? i defined-name)) l)
 	       (escape defined-name))
 	     (hash-table-put! ht (syntax-e defined-name) (cons defined-name l))))
@@ -3309,15 +3314,14 @@
 	(when planet-resolver
 	  ;; Let planet resolver register, too:
 	  (planet-resolver s))
-	(let ([ht (hash-table-get
+	(let ([ht (or (hash-table-get -module-hash-table-table
-		   -module-hash-table-table
 				      (namespace-module-registry (current-namespace))
-		   (lambda ()
+				      #f)
 		      (let ([ht (make-hash-table)])
 			(hash-table-put! -module-hash-table-table
 					 (namespace-module-registry (current-namespace))
 					 ht)
-		       ht)))])
+			ht))])
 	  (hash-table-put! ht s 'attach))]
        [(s relto stx) (standard-module-name-resolver s relto stx #t)]
        [(s relto stx load?)
@@ -3350,7 +3354,7 @@
 		   (cond
 		    [(string? s)
 		     (let* ([dir (get-dir)])
-		       (or (hash-table-get -path-cache (cons s dir) (lambda () #f))
+		       (or (hash-table-get -path-cache (cons s dir) #f)
 			   (let ([s (string->bytes/utf-8 s)])
 			     (if (regexp-match-positions -re:ok-relpath s)
 				 ;; Parse Unix-style relative path string
@@ -3377,10 +3381,9 @@
 			 (not (list? s)))
 		     #f]
 		    [(eq? (car s) 'lib)
-		     (hash-table-get
+		     (or (hash-table-get -path-cache
-		      -path-cache
 					 (cons s (current-library-collection-paths))
-		      (lambda ()
+					 #f)
 			 (let ([cols (let ([len (length s)])
 				       (if (= len 2)
 					   (list "mzlib")
@@ -3393,7 +3396,7 @@
 				(string? (cadr s))
 				(relative-path? (cadr s))
 				(let ([p (-find-col 'standard-module-name-resolver (car cols) (cdr cols))])
-				 (build-path p (cadr s)))))))]
+				  (build-path p (cadr s))))))]
 		    [(eq? (car s) 'file)
 		     (and (= (length s) 2)
 			  (let ([p (cadr s)])
@@ -3442,18 +3445,17 @@
 				      (vector-ref s-parsed 6)
 				      (let ([m (regexp-match -re:suffix (path->bytes name))])
 					(if m (car m) #t)))]
-			  [ht (hash-table-get
+			  [ht (or (hash-table-get -module-hash-table-table
-			       -module-hash-table-table
 						  (namespace-module-registry (current-namespace))
-			       (lambda ()
+						  #f)
 				  (let ([ht (make-hash-table)])
 				    (hash-table-put! -module-hash-table-table
 						     (namespace-module-registry (current-namespace))
 						     ht)
-				   ht)))])
+				    ht))])
 		      ;; Loaded already?
 		      (when load?
-			(let ([got (hash-table-get ht modname (lambda () #f))])
+			(let ([got (hash-table-get ht modname #f)])
 			  (when got
 			    ;; Check the suffix, which gets lost when creating a key:
 			    (unless (or (symbol? got) (equal? suffix got))

src/mzscheme/src/stxobj.c

@@ -2457,7 +2457,7 @@ Scheme_Object *scheme_stx_activate_certs(Scheme_Object *o)
 /*                           stx comparison                               */
 /*========================================================================*/
 
-static int same_marks(WRAP_POS *_awl, WRAP_POS *_bwl, int ignore_barrier, 
+XFORM_NONGCING static int same_marks(WRAP_POS *_awl, WRAP_POS *_bwl, int ignore_barrier, 
 				     Scheme_Object *barrier_env, Scheme_Object *ignore_rib)
 /* Compares the marks in two wraps lists. A result of 2 means that the
    result depended on a mark barrier or barrier env. Use #f for barrier_env

src/mzscheme/src/thread.c

@@ -131,6 +131,8 @@ extern void scheme_gmp_tls_snapshot(long *s, long *save);
 extern void scheme_gmp_tls_restore_snapshot(long *s, long *save, int do_free);
 
 extern int scheme_num_read_syntax_objects;
+extern int scheme_hash_request_count;
+extern int scheme_hash_iteration_count;
 
 /*========================================================================*/
 /*                    local variables and prototypes                      */
@@ -6781,6 +6783,10 @@ static Scheme_Object *current_stats(int argc, Scheme_Object *argv[])
     
     switch (SCHEME_VEC_SIZE(v)) {
     default:
+    case 10:
+      SCHEME_VEC_ELS(v)[9] = scheme_make_integer(scheme_hash_iteration_count);
+    case 9:
+      SCHEME_VEC_ELS(v)[8] = scheme_make_integer(scheme_hash_request_count);
     case 8:
       SCHEME_VEC_ELS(v)[7] = scheme_make_integer(scheme_num_read_syntax_objects);
     case 7:

src/mzscheme/utils/splay.c

@@ -1,3 +1,14 @@
+/* 
+   Provides OR requires:
+    Tree (with left and right Tree fields)
+    Splay_Item
+    Set_Splay_Item
+   Provides, can can be renamed via macros (to support
+                    multiplue uses of the file):
+    splay
+    splay_insert
+    splay_delete
+*/
 /*
                 An implementation of top-down splaying
                     D. Sleator <sleator@cs.cmu.edu>
@@ -121,6 +132,8 @@ static Tree * splay_insert(unsigned long i, Tree * new, Tree * t) {
     }
 }
 
+#ifndef OMIT_SPLAY_DELETE
+
 static Tree * splay_delete(unsigned long i, Tree * t) {
 /* Deletes i from the tree if it's there.               */
 /* Return a pointer to the resulting tree.              */
@@ -138,3 +151,5 @@ static Tree * splay_delete(unsigned long i, Tree * t) {
     }
     return t;                         /* It wasn't there */
 }
+
+#endif

src/wxmac/include/base/common.h

@@ -11,6 +11,13 @@
 #ifndef wxb_commonh
 #define wxb_commonh
 
+/* We don't want all those "deprecated" messages: */
+#ifndef WX_KEEP_DEPRECATED_WARNINGS
+# include <AvailabilityMacros.h>
+# undef DEPRECATED_ATTRIBUTE
+# define DEPRECATED_ATTRIBUTE /**/
+#endif
+
 #ifdef OS_X
 # include <Carbon/Carbon.h>
 #else

src/wxmac/src/mac/wx_print.cc

@@ -8,14 +8,14 @@
  * Copyright:   (c) 1995, AIAI, University of Edinburgh
  */
 
+#include "common.h"
+
 #ifdef OS_X
 # include <ApplicationServices/ApplicationServices.h>
 #else
 # include <ApplicationServices.h>
 #endif
 
-#include "common.h"
-
 #if USE_PRINTING_ARCHITECTURE
 #if USE_COMMON_DIALOGS