cs: drop unused correlation early

The improvements reported in 74012f8c57 were actually due to a broken
experiment that dropped source locations on application forms, instead
of preserving them in marshaled code. Adjust the expansion pipeline
to do that earlier and intentionally.

The xify pas doesn't help all that much after all, but it's still more
comfortable to be independent of local-variable names.

racket/src/cs/expander.sls

@@ -4,7 +4,8 @@
           load-on-demand-enabled
           call-in-main-thread
           version
-          exit)
+          exit
+          compile-keep-source-locations!)
   (import (except (chezpart)
                   syntax->datum
                   datum->syntax)

racket/src/cs/linklet.sls

@@ -43,6 +43,7 @@
           compiled-position->primitive
           primitive-in-category?
 
+          omit-debugging?             ; not exported to racket
           platform-independent-zo-mode? ; not exported to racket
           linklet-performance-init!   ; not exported to racket
           linklet-performance-report! ; not exported to racket
@@ -276,7 +277,7 @@
                (wrapped-code-content-set! wc f)
                f)]
             [else
-             (let* ([f (compile* (wrapped-code-content wc))])
+             (let ([f (compile* f)])
                (when jit-demand-on?
                  (show "JIT demand" (strip-nested-annotations (wrapped-code-content wc))))
                (wrapped-code-content-set! wc f)

racket/src/cs/main.sps

@@ -25,16 +25,20 @@
                module->language-info
                module-path-index-join
                version
-               exit)
+               exit
+               compile-keep-source-locations!)
          (regexp)
          (io)
          (thread)
          (only (linklet)
+               omit-debugging?
                platform-independent-zo-mode?
                linklet-performance-init!
                linklet-performance-report!))
 
  (linklet-performance-init!)
+ (unless omit-debugging?
+   (compile-keep-source-locations! #t))
 
  (define the-command-line-arguments
    (or (and (top-level-bound? 'bytes-command-line-arguments)

racket/src/expander/compile/correlate.rkt

@@ -12,7 +12,11 @@
 (provide correlate*
          correlate~
          correlate/app
-         ->correlated)
+         ->correlated
+
+         compile-keep-source-locations!)
+
+(define keep-source-locations? #f)
 
 (define (correlate* stx s-exp)
   (if (syntax-srcloc stx)
@@ -26,9 +30,13 @@
   s-exp)
 
 (define (correlate/app stx s-exp)
-  (if (eq? (system-type 'vm) 'chez-scheme)
+  (if keep-source-locations?
       (correlate* stx s-exp)
       (correlate~ stx s-exp)))
 
 (define (->correlated s)
   (datum->correlated s #f))
+
+
+(define (compile-keep-source-locations! on?)
+  (set! keep-source-locations? on?))

racket/src/expander/main.rkt

@@ -18,6 +18,8 @@
          "namespace/core.rkt"
          "namespace/primitive-module.rkt"
          "expand/missing-module.rkt"
+         (only-in "compile/correlate.rkt"
+                  compile-keep-source-locations!)
          "boot/kernel.rkt"
          "boot/read-primitive.rkt"
          "boot/main-primitive.rkt"
@@ -104,7 +106,9 @@
          declare-primitive-module! ; to support "extensions"
 
          embedded-load ; for -k
-         
+
+         compile-keep-source-locations! ; to enable if the back end wants them
+
          ;; This functions are provided for basic testing
          ;; (such as "demo.rkt")
          syntax? syntax-e

racket/src/schemify/xify.rkt

@@ -65,11 +65,7 @@
        (define u-id (unwrap (car ids)))
        (define x (or (hash-ref env u-id #f)
                      (string->symbol (string-append "x" (number->string (hash-count env))))))
-       (define-values (rest-xs rest-env) (xify-ids (cdr ids)
+       (define-values (rest-xs rest-env) (xify-ids (cdr ids) (hash-set env u-id x)))
-                                                   (if (and (eq? x u-id)
-                                                            (not (hash-ref env u-id #f)))
-                                                       env
-                                                       (hash-set env u-id x))))
        (values (cons x rest-xs) rest-env)]
       [(null? ids) (values '() env)]
       [else