From 3617e1f81ec465f77fa4b00b3c0a9eb016575441 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 2 Mar 2016 09:44:31 -0700 Subject: [PATCH] xform: add `XFORM_ASSERT_NO_CONVERSION` A `XFORM_ASSERT_NO_CONVERSION` declaration makes xform check that an procedure that is intended to avoid instrumentation actually does avoid it. --- racket/collects/compiler/private/xform.rkt | 20 ++++++++++++++++---- racket/src/racket/include/scheme.h | 2 ++ racket/src/racket/src/list.c | 4 ++++ racket/src/racket/src/portfun.c | 2 ++ racket/src/racket/src/symbol.c | 1 + 5 files changed, 25 insertions(+), 4 deletions(-) diff --git a/racket/collects/compiler/private/xform.rkt b/racket/collects/compiler/private/xform.rkt index 0e2a33f229..cd0b8b0921 100644 --- a/racket/collects/compiler/private/xform.rkt +++ b/racket/collects/compiler/private/xform.rkt @@ -756,6 +756,7 @@ (printf "#define XFORM_START_SUSPEND /**/\n") (printf "#define XFORM_END_SUSPEND /**/\n") (printf "#define XFORM_SKIP_PROC /**/\n") + (printf "#define XFORM_ASSERT_NO_CONVERSION /**/\n") ;; For avoiding warnings: (printf "#define XFORM_OK_PLUS +\n") (printf "#define XFORM_OK_MINUS -\n") @@ -1796,7 +1797,7 @@ (define (class-decl? e) (memq (tok-n (car e)) '(class))) - ; ;Recognize a function (as opposed to a prototype): + ;; Recognize a function (as opposed to a prototype): (define (function? e) (let ([l (length e)]) (and (> l 2) @@ -1809,6 +1810,7 @@ (let ([v (list-ref e (sub1 ll))]) (or (parens? v) (eq? (tok-n v) 'XFORM_SKIP_PROC) + (eq? (tok-n v) 'XFORM_ASSERT_NO_CONVERSION) ;; `const' can appear between the arg parens ;; and the function body; this happens in the ;; OS X headers @@ -2419,6 +2421,9 @@ (if (eq? semi (tok-n v)) (values (list-ref e (sub1 len)) (sub1 len)) (values v len)))] + [(assert-no-conversion?) + (eq? (tok-n (list-ref e (sub1 len))) + 'XFORM_ASSERT_NO_CONVERSION)] [(body-e) (seq->list (seq-in body-v))] [(class-name function-name func-pos) (let loop ([e e][p 0]) @@ -2433,7 +2438,9 @@ [(args-e) (seq->list (seq-in (list-ref e (if (and func-pos (eq? class-name function-name)) (add1 func-pos) - (sub1 len)))))] + (if assert-no-conversion? + (- len 2) + (sub1 len))))))] [(arg-vars all-arg-vars) (let-values ([(arg-pragmas arg-decls) (body->lines (append args-e @@ -2583,8 +2590,13 @@ (cons (make-note 'note #f #f "/* No conversion */") orig-body-e)) - (list->seq body-e)))))))) - + (begin + (when assert-no-conversion? + (log-error "[CONVERSION] ~a in ~a: Function ~a declared XFORM_ASSERT_NO_CONVERSION, but requires conversion." + (tok-line (car e)) (tok-file (car e)) + name)) + (list->seq body-e))))))))) + (define (convert-class-vars body-e arg-vars c++-class new-vars-box) (when c++-class (let-values ([(pragmas el) (body->lines body-e #f)]) diff --git a/racket/src/racket/include/scheme.h b/racket/src/racket/include/scheme.h index 2a48a069b7..b7688edcb9 100644 --- a/racket/src/racket/include/scheme.h +++ b/racket/src/racket/include/scheme.h @@ -237,6 +237,7 @@ typedef struct FSSpec mzFSSpec; #ifdef MZ_PRECISE_GC # ifndef MZ_XFORM # define XFORM_SKIP_PROC /* empty */ +# define XFORM_ASSERT_NO_CONVERSION /* empty */ # define XFORM_CAN_IGNORE /**/ # endif #else @@ -246,6 +247,7 @@ typedef struct FSSpec mzFSSpec; # define XFORM_START_SUSPEND /**/ # define XFORM_END_SUSPEND /**/ # define XFORM_SKIP_PROC /**/ +# define XFORM_ASSERT_NO_CONVERSION /**/ # define XFORM_START_TRUST_ARITH /**/ # define XFORM_END_TRUST_ARITH /**/ # define XFORM_CAN_IGNORE /**/ diff --git a/racket/src/racket/src/list.c b/racket/src/racket/src/list.c index 20277e61f0..f9c282ee2e 100644 --- a/racket/src/racket/src/list.c +++ b/racket/src/racket/src/list.c @@ -4030,6 +4030,7 @@ Scheme_Object *unsafe_hash_table_iterate_next(int argc, Scheme_Object *argv[]) } Scheme_Object *unsafe_hash_table_iterate_key(int argc, Scheme_Object *argv[]) + XFORM_ASSERT_NO_CONVERSION { GC_CAN_IGNORE const char *name = "unsafe-mutable-hash-iterate-key"; Scheme_Object *obj = argv[0], *key; @@ -4069,6 +4070,7 @@ static Scheme_Object *unsafe_hash_table_iterate_value_slow(int argc, Scheme_Obje } Scheme_Object *unsafe_hash_table_iterate_value(int argc, Scheme_Object *argv[]) + XFORM_ASSERT_NO_CONVERSION { Scheme_Object *obj = argv[0], *key, *val; mzlonglong pos = SCHEME_INT_VAL(argv[1]); @@ -4142,6 +4144,7 @@ Scheme_Object *unsafe_hash_tree_iterate_next(int argc, Scheme_Object *argv[]) } Scheme_Object *unsafe_hash_tree_iterate_key(int argc, Scheme_Object *argv[]) + XFORM_ASSERT_NO_CONVERSION { Scheme_Object *obj = argv[0], *args = argv[1], *key; Scheme_Hash_Tree *subtree; @@ -4174,6 +4177,7 @@ static Scheme_Object *unsafe_hash_tree_iterate_value_slow(int argc, Scheme_Objec } Scheme_Object *unsafe_hash_tree_iterate_value(int argc, Scheme_Object *argv[]) + XFORM_ASSERT_NO_CONVERSION { Scheme_Object *obj = argv[0], *args = argv[1]; Scheme_Hash_Tree *subtree; diff --git a/racket/src/racket/src/portfun.c b/racket/src/racket/src/portfun.c index b8cf3bf747..94500aabfa 100644 --- a/racket/src/racket/src/portfun.c +++ b/racket/src/racket/src/portfun.c @@ -432,6 +432,7 @@ static MZ_INLINE Scheme_Input_Port *input_port_record_slow(Scheme_Object *port) } Scheme_Input_Port *scheme_input_port_record(Scheme_Object *port) + XFORM_ASSERT_NO_CONVERSION { /* Avoid MZ_PRECISE_GC instrumentation in the common case: */ if (SCHEME_INPORTP(port)) @@ -464,6 +465,7 @@ static MZ_INLINE Scheme_Output_Port *output_port_record_slow(Scheme_Object *port } Scheme_Output_Port *scheme_output_port_record(Scheme_Object *port) + XFORM_ASSERT_NO_CONVERSION { /* Avoid MZ_PRECISE_GC instrumentation in the common case: */ if (SCHEME_OUTPORTP(port)) diff --git a/racket/src/racket/src/symbol.c b/racket/src/racket/src/symbol.c index 7ffe29af3d..177f4a02ad 100644 --- a/racket/src/racket/src/symbol.c +++ b/racket/src/racket/src/symbol.c @@ -102,6 +102,7 @@ static Scheme_Object *rehash_symbol_bucket(Scheme_Hash_Table *table, static Scheme_Object *symbol_bucket(Scheme_Hash_Table *table, GC_CAN_IGNORE const char *key, uintptr_t length, Scheme_Object *naya) + XFORM_ASSERT_NO_CONVERSION { hash_v_t h, h2; uintptr_t mask;