add XFORM_NONGCING_NONALIASING annotation

An `XFORM_NONGCING_NONALIASING` function doesn't trigger a GC, and
when it is given an argument that is an address of a local variable,
it fills in that address and doesn't leak it. This annotation allows
the xform transformation (to support precise GC) avoid some work for
some hash-iteration functions.

pkgs/base/info.rkt

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

racket/collects/compiler/private/xform.rkt

@@ -741,6 +741,7 @@
           (printf "#define GC_CAN_IGNORE /**/\n")
           (printf "#define XFORM_CAN_IGNORE /**/\n")
           (printf "#define __xform_nongcing__ /**/\n")
+          (printf "#define __xform_nongcing_nonaliasing__ /**/\n")
           ;; Another annotation to protect against GC conversion:
           (printf "#define HIDE_FROM_XFORM(x) x\n")
           (printf "#define XFORM_HIDE_EXPR(x) x\n")
@@ -960,6 +961,12 @@
 		    (hash-set! non-gcing-functions name #t))
 		  non-gcing-builtin-functions)
 
+        ;; Non-aliasing function may take address of variables as arguments to fill
+        ;; them in, but they don't expose those addresses, so taking a variable's
+        ;; address for an argument doesn't make it live for the rest of the enclosing
+        ;; function.
+        (define non-aliasing-functions (make-hasheq))
+
         (define non-returning-functions
           ;; The following functions never return, so the wrappers
           ;; don't need to push any variables:
@@ -1122,8 +1129,9 @@
                 (set! struct-defs (list-ref l 6))
                 
                 (set! non-gcing-functions (hash-copy (list-ref l 7)))
+                (set! non-aliasing-functions (hash-copy (list-ref l 8)))
 
-                (set! gc-var-stack-mode (list-ref l 8))))))
+                (set! gc-var-stack-mode (list-ref l 9))))))
         
         ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
         ;; Pretty-printing output
@@ -1560,6 +1568,9 @@
              (let ([name (register-proto-information e)])
                (when (eq? (tok-n (car e)) '__xform_nongcing__)
 		 (hash-set! non-gcing-functions name #t))
+               (when (eq? (tok-n (car e)) '__xform_nongcing_nonaliasing__)
+		 (hash-set! non-gcing-functions name #t)
+		 (hash-set! non-aliasing-functions name #t))
 	       (when show-info?
                  (printf "/* PROTO ~a */\n" name))
                (if (or precompiling-header?
@@ -1594,6 +1605,9 @@
              (let ([name (register-proto-information e)])
                (when (eq? (tok-n (car e)) '__xform_nongcing__)
                  (hash-set! non-gcing-functions name #t))
+               (when (eq? (tok-n (car e)) '__xform_nongcing_nonaliasing__)
+                 (hash-set! non-gcing-functions name #t)
+                 (hash-set! non-aliasing-functions name #t))
                (if (skip-function? e)
                    e
                    (begin
@@ -1866,7 +1880,8 @@
                              (if (pair? t)
                                  (if (or (memq (tok-n (car t)) '(extern static virtual __stdcall __cdecl 
                                                                         inline _inline __inline __inline__
-                                                                        __xform_nongcing__))
+                                                                        __xform_nongcing__
+                                                                        __xform_nongcing_nonaliasing__))
                                          (equal? "C" (tok-n (car t))))
                                      (loop (cdr t))
                                      (cons (car t) (loop (cdr t))))
@@ -2541,7 +2556,7 @@
                                             e
                                             (lambda (name class-name type args static?)
                                               type)))])
-		 (if (hash-ref non-gcing-functions name (lambda () #f))
+		 (if (hash-ref non-gcing-functions name #f)
 		     (when saw-gcing-call
 		       (log-error "[GCING] ~a in ~a: Function ~a declared __xform_nongcing__, but includes a function call at ~s."
 				  (tok-line saw-gcing-call) (tok-file saw-gcing-call)
@@ -3903,6 +3918,21 @@
                null]
               [(pragma? (car e))
                (loop (cdr e))]
+              [(and (pair? (cdr e))
+                    (parens? (cadr e))
+                    (hash-ref non-aliasing-functions (tok-n (car e)) #f))
+               ;; A call to a non-aliasing function: drop immediate '&'s on args:
+               (define (drop-&s now? e)
+                 (cond
+                  [(null? e) null]
+                  [(and now? (eq? '& (tok-n (car e))))
+                   (drop-&s #f (cdr e))]
+                  [(eq? '|,| (tok-n (car e)))
+                   (cons (car e) (drop-&s #t (cdr e)))]
+                  [else
+                   (cons (car e) (drop-&s #f (cdr e)))]))
+               (append (loop (drop-&s #t (seq->list (seq-in (cadr e)))))
+                       (loop (cddr e)))]
               [(eq? '& (tok-n (car e)))
                (if (null? (cdr e))
                    null
@@ -4121,6 +4151,7 @@
                     (marshall non-pointer-types)
                     (marshall struct-defs)
 		    non-gcing-functions
+		    non-aliasing-functions
                     (list 'quote gc-var-stack-mode))])
               (with-output-to-file (change-suffix file-out #".zo")
                 (lambda ()

racket/src/racket/include/scheme.h

@@ -177,9 +177,19 @@ typedef long FILE;
 #endif
 
 #ifdef MZ_XFORM
+/* A non-GCing function will never trigger a garbage collection.
+   The xform tool checks this declaration, and it uses this hint
+   to avoid registering variables unnecessarily. */
 # define XFORM_NONGCING __xform_nongcing__
+/* A non-GCing, non-aliasing function is non-GCing, and it may take
+   arguments that are addresses of local variables, but it doesn't
+   leak those addresses; it only filles them in. The xform tool only
+   checks the non-GCing part of this declaration, but uses both
+   facets of the hint. */
+# define XFORM_NONGCING_NONALIASING __xform_nongcing_nonaliasing__
 #else
 # define XFORM_NONGCING /* empty */
+# define XFORM_NONGCING_NONALIASING /* empty */
 #endif
 
 #ifdef MZ_XFORM

racket/src/racket/src/list.c

@@ -4029,7 +4029,7 @@ Scheme_Object *unsafe_hash_table_iterate_next(int argc, Scheme_Object *argv[])
   return NULL;
 }
 
-static Scheme_Object *unsafe_hash_table_iterate_key_slow(int argc, Scheme_Object *argv[])
+Scheme_Object *unsafe_hash_table_iterate_key(int argc, Scheme_Object *argv[])
 {
   GC_CAN_IGNORE const char *name = "unsafe-mutable-hash-iterate-key";
   Scheme_Object *obj = argv[0], *key;
@@ -4047,18 +4047,6 @@ static Scheme_Object *unsafe_hash_table_iterate_key_slow(int argc, Scheme_Object
   return NULL;  
 }
 
-Scheme_Object *unsafe_hash_table_iterate_key(int argc, Scheme_Object *argv[])
-{
-  Scheme_Object *obj = argv[0], *key;
-  mzlonglong pos = SCHEME_INT_VAL(argv[1]);
-
-  if (!SCHEME_NP_CHAPERONEP(obj)
-      && scheme_hash_table_index((Scheme_Hash_Table *)obj, pos, &key, NULL))
-    return key;
-  else
-    return unsafe_hash_table_iterate_key_slow(argc, argv);
-}
-
 static Scheme_Object *unsafe_hash_table_iterate_value_slow(int argc, Scheme_Object *argv[])
 {
   GC_CAN_IGNORE const char *name = "unsafe-mutable-hash-iterate-value";
@@ -4162,7 +4150,7 @@ Scheme_Object *unsafe_hash_tree_iterate_key(int argc, Scheme_Object *argv[])
   scheme_unsafe_hash_tree_subtree(obj, args, &subtree, &i);
   key = subtree->els[i];
   
-  if (!SCHEME_NP_CHAPERONEP(obj))
+  if (SCHEME_NP_CHAPERONEP(obj))
     return chaperone_hash_key("unsafe-immutable-hash-iterate-key", obj, key);
   else
     return key;

racket/src/racket/src/makex.rkt

@@ -60,6 +60,7 @@
              [else
               (let* ([l (regexp-replace #rx"^extern " l "")]
                      [l (regexp-replace #rx"^XFORM_NONGCING " l "")]
+                     [l (regexp-replace #rx"^XFORM_NONGCING_NONALIASING " l "")]
                      [l (regexp-replace #rx"^MZ_EXTERN " l "")]
                      [l (regexp-replace #rx"^THREAD_LOCAL " l "")]
                      [l2 (regexp-replace #rx"^volatile " l "")]

racket/src/racket/src/schemef.h

@@ -498,7 +498,7 @@ MZ_EXTERN Scheme_Bucket *scheme_bucket_from_table(Scheme_Bucket_Table *table, co
 MZ_EXTERN int scheme_bucket_table_equal(Scheme_Bucket_Table *t1, Scheme_Bucket_Table *t2);
 MZ_EXTERN Scheme_Bucket_Table *scheme_clone_bucket_table(Scheme_Bucket_Table *bt);
 MZ_EXTERN void scheme_clear_bucket_table(Scheme_Bucket_Table *bt);
-XFORM_NONGCING MZ_EXTERN int scheme_bucket_table_index(Scheme_Bucket_Table *hash, mzlonglong pos, Scheme_Object **_key, Scheme_Object **_val);
+XFORM_NONGCING_NONALIASING MZ_EXTERN int scheme_bucket_table_index(Scheme_Bucket_Table *hash, mzlonglong pos, Scheme_Object **_key, Scheme_Object **_val);
 XFORM_NONGCING Scheme_Object *scheme_bucket_table_next(Scheme_Bucket_Table *hash, mzlonglong start);
 
 MZ_EXTERN Scheme_Hash_Table *scheme_make_hash_table(int type);
@@ -514,7 +514,7 @@ MZ_EXTERN int scheme_is_hash_table_equal(Scheme_Object *o);
 MZ_EXTERN int scheme_is_hash_table_eqv(Scheme_Object *o);
 MZ_EXTERN Scheme_Hash_Table *scheme_clone_hash_table(Scheme_Hash_Table *ht);
 MZ_EXTERN void scheme_clear_hash_table(Scheme_Hash_Table *ht);
-XFORM_NONGCING MZ_EXTERN int scheme_hash_table_index(Scheme_Hash_Table *hash, mzlonglong pos, Scheme_Object **_key, Scheme_Object **_val);
+XFORM_NONGCING_NONALIASING MZ_EXTERN int scheme_hash_table_index(Scheme_Hash_Table *hash, mzlonglong pos, Scheme_Object **_key, Scheme_Object **_val);
 XFORM_NONGCING MZ_EXTERN Scheme_Object *scheme_hash_table_next(Scheme_Hash_Table *hash, mzlonglong start);
 
 MZ_EXTERN Scheme_Hash_Tree *scheme_make_hash_tree(int kind);
@@ -523,7 +523,7 @@ MZ_EXTERN Scheme_Hash_Tree *scheme_hash_tree_set(Scheme_Hash_Tree *tree, Scheme_
 MZ_EXTERN Scheme_Object *scheme_hash_tree_get(Scheme_Hash_Tree *tree, Scheme_Object *key);
 XFORM_NONGCING MZ_EXTERN Scheme_Object *scheme_eq_hash_tree_get(Scheme_Hash_Tree *tree, Scheme_Object *key);
 XFORM_NONGCING MZ_EXTERN mzlonglong scheme_hash_tree_next(Scheme_Hash_Tree *tree, mzlonglong pos);
-XFORM_NONGCING MZ_EXTERN int scheme_hash_tree_index(Scheme_Hash_Tree *tree, mzlonglong pos, Scheme_Object **_key, Scheme_Object **_val);
+XFORM_NONGCING_NONALIASING MZ_EXTERN int scheme_hash_tree_index(Scheme_Hash_Tree *tree, mzlonglong pos, Scheme_Object **_key, Scheme_Object **_val);
 MZ_EXTERN int scheme_hash_tree_equal(Scheme_Hash_Tree *t1, Scheme_Hash_Tree *t2);
 MZ_EXTERN int scheme_is_hash_tree_equal(Scheme_Object *o);
 MZ_EXTERN int scheme_is_hash_tree_eqv(Scheme_Object *o);

racket/src/racket/src/schpriv.h

@@ -949,12 +949,11 @@ Scheme_Hash_Tree *scheme_hash_tree_set_w_key_wraps(Scheme_Hash_Tree *tree, Schem
                                                    Scheme_Object *key_wraps);
 
 Scheme_Object *scheme_unsafe_hash_tree_start(Scheme_Hash_Tree *ht);
-XFORM_NONGCING void scheme_unsafe_hash_tree_subtree(Scheme_Object *obj, Scheme_Object *args,
+XFORM_NONGCING_NONALIASING void scheme_unsafe_hash_tree_subtree(Scheme_Object *obj, Scheme_Object *args,
-                                                    Scheme_Hash_Tree **_subtree, int *_i);
+                                                                Scheme_Hash_Tree **_subtree, int *_i);
 XFORM_NONGCING Scheme_Object *scheme_unsafe_hash_tree_access(Scheme_Hash_Tree *subtree, int i);
 Scheme_Object *scheme_unsafe_hash_tree_next(Scheme_Hash_Tree *ht, Scheme_Object *args);
 Scheme_Object *scheme_hash_tree_next_pos(Scheme_Hash_Tree *tree, mzlonglong pos);
-XFORM_NONGCING int scheme_hash_tree_index(Scheme_Hash_Tree *tree, mzlonglong pos, Scheme_Object **_key, Scheme_Object **_val);
 int scheme_hash_tree_equal(Scheme_Hash_Tree *t1, Scheme_Hash_Tree *t2);
 int scheme_is_hash_tree_equal(Scheme_Object *o);
 int scheme_is_hash_tree_eqv(Scheme_Object *o);

racket/src/racket/src/schvers.h

@@ -13,12 +13,12 @@
    consistently.)
 */
 
-#define MZSCHEME_VERSION "6.4.0.10"
+#define MZSCHEME_VERSION "6.4.0.11"
 
 #define MZSCHEME_VERSION_X 6
 #define MZSCHEME_VERSION_Y 4
 #define MZSCHEME_VERSION_Z 0
-#define MZSCHEME_VERSION_W 10
+#define MZSCHEME_VERSION_W 11
 
 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
 #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)