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

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

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 /**/

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;

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

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;