cs: fix procedure names

Use a `(let ([<name> ....]) <name>)` wrapper to communicate
an 'inferred-name property from correlated objects to
Chez Scheme. This stategy relies on a Chez Scheme patch to
make the wrapper work consistently.

racket/src/cs/convert.rkt

@@ -197,6 +197,47 @@
 
 ;; ----------------------------------------
 
+;; Startup code as an S-expression uses the pattern
+;;   (lambda <formals> (begin '<id> <expr>))
+;; or
+;;   (case-lambda [<formals> (begin '<id> <expr>)] <clause> ...)
+;; to record a name for a function. Detect that pattern and
+;; create a `#%name` form. We rely on the fact
+;; that the names `lambda`, `case-lambda`, and `quote` are
+;; never shadowed, so we don't have to parse expression forms
+;; in general.
+(define (rename-functions e)
+  (cond
+    [(not (pair? e)) e]
+    [else
+     (define (begin-name e)
+       (and (pair? e)
+            (eq? (car e) 'begin)
+            (pair? (cdr e))
+            (pair? (cddr e))
+            (pair? (cadr e))
+            (eq? 'quote (caadr e))
+            (cadadr e)))
+     (case (car e)
+       [(quote) e]
+       [(lambda)
+        (define new-e (map rename-functions e))
+        (define name (begin-name (caddr e)))
+        (if name
+            `(#%name ,name ,new-e)
+            new-e)]
+       [(case-lambda)
+        (define new-e (map rename-functions e))
+        (define name (and (pair? (cdr e))
+                          (begin-name (cadadr e))))
+        (if name
+            `(#%name ,name ,new-e)
+            new-e)]
+       [else (cons (rename-functions (car e))
+                   (rename-functions (cdr e)))])]))
+
+;; ----------------------------------------
+
 (make-parent-directory* out-file)
 
 (with-handlers ([void (lambda (exn)
@@ -251,4 +292,4 @@
              [`(begin ,vs ...)
               (for-each loop vs)]
              [else
-              (pretty-write v)])))))))
+              (pretty-write (rename-functions v))])))))))

racket/src/cs/expander.sls

@@ -153,6 +153,9 @@
                [(_ rator rand ...)
                 (with-syntax ([n-args (length #'(rand ...))])
                   #'((extract-procedure rator n-args) rand ...))])))
+    (eval '(define-syntax (|#%name| stx)
+             (syntax-case stx ()
+               [(_ name val) #`(let ([name val]) name)])))
     (eval `(define raise-binding-result-arity-error ',raise-binding-result-arity-error)))
 
   ;; For interpretation of the outer shell of a linklet:

racket/src/cs/linklet.sls

@@ -1154,8 +1154,13 @@
                       (values (cons a d)
                               (cons stripped-a stripped-d))))]
      [(correlated? v) (let-values ([(e stripped-e) (correlated->annotation* (correlated-e v))])
-                        (values (transfer-srcloc v e stripped-e)
-                                stripped-e))]
+                        (let ([name (correlated-property v 'inferred-name)])
+                          (define (add-name e)
+                            (if name
+                                `(|#%name| ,name ,e)
+                                e))
+                          (values (add-name (transfer-srcloc v e stripped-e))
+                                  (add-name stripped-e))))]
      ;; correlated will be nested only in pairs with current expander
      [else (values v v)]))
 

racket/src/cs/rumble.sls

@@ -149,6 +149,7 @@
           primitive-closure?
           primitive-result-arity
           make-jit-procedure ; not exported to racket
+          |#%name|           ; not exported to racket
 
           equal?
           equal?/recur

racket/src/cs/rumble/correlated.ss

@@ -26,7 +26,11 @@
          src)
   (if (correlated? datum)
       datum
-      (make-correlated datum (extract-srcloc src) empty-hasheq)))
+      (make-correlated datum
+                       (extract-srcloc src)
+                       (if (correlated? src)
+                           (correlated-props src)
+                           empty-hasheq))))
 
 (define (correlated->datum e)
   (cond

racket/src/cs/rumble/procedure.ss

@@ -657,6 +657,13 @@
 
 ;; ----------------------------------------
 
+;; Used to encode an 'inferred-name property as a Scheme expression
+(define-syntax (|#%name| stx)
+  (syntax-case stx ()
+    [(_ name val) #`(let ([name val]) name)]))
+
+;; ----------------------------------------
+
 (define (set-primitive-applicables!)
   (struct-property-set! prop:procedure
                         (record-type-descriptor parameter)