From 3b25e22dd6069d23c755445cc82e86c1ccf8a276 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 28 Feb 2016 17:09:45 -0700 Subject: [PATCH] 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 | 2 +- racket/collects/compiler/private/xform.rkt | 39 +++++++++++++++++++--- racket/src/racket/include/scheme.h | 10 ++++++ racket/src/racket/src/list.c | 16 ++------- racket/src/racket/src/makex.rkt | 1 + racket/src/racket/src/schemef.h | 6 ++-- racket/src/racket/src/schpriv.h | 5 ++- racket/src/racket/src/schvers.h | 4 +-- 8 files changed, 56 insertions(+), 27 deletions(-) diff --git a/pkgs/base/info.rkt b/pkgs/base/info.rkt index 3dc16b89f4..6e22394938 100644 --- a/pkgs/base/info.rkt +++ b/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])) diff --git a/racket/collects/compiler/private/xform.rkt b/racket/collects/compiler/private/xform.rkt index 5117b82983..0e2a33f229 100644 --- a/racket/collects/compiler/private/xform.rkt +++ b/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") @@ -959,7 +960,13 @@ (for-each (lambda (name) (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 () diff --git a/racket/src/racket/include/scheme.h b/racket/src/racket/include/scheme.h index 271dc216bd..2a48a069b7 100644 --- a/racket/src/racket/include/scheme.h +++ b/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 diff --git a/racket/src/racket/src/list.c b/racket/src/racket/src/list.c index 13e3d650ad..20277e61f0 100644 --- a/racket/src/racket/src/list.c +++ b/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; diff --git a/racket/src/racket/src/makex.rkt b/racket/src/racket/src/makex.rkt index a30ba49806..e79b225d01 100644 --- a/racket/src/racket/src/makex.rkt +++ b/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 "")] diff --git a/racket/src/racket/src/schemef.h b/racket/src/racket/src/schemef.h index 57b3a44880..1143f34808 100644 --- a/racket/src/racket/src/schemef.h +++ b/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); diff --git a/racket/src/racket/src/schpriv.h b/racket/src/racket/src/schpriv.h index 38ffd157c5..4a4bef0332 100644 --- a/racket/src/racket/src/schpriv.h +++ b/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, - Scheme_Hash_Tree **_subtree, int *_i); +XFORM_NONGCING_NONALIASING void scheme_unsafe_hash_tree_subtree(Scheme_Object *obj, Scheme_Object *args, + 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); diff --git a/racket/src/racket/src/schvers.h b/racket/src/racket/src/schvers.h index 61762f55d9..b0eff7892b 100644 --- a/racket/src/racket/src/schvers.h +++ b/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)