diff --git a/racket/src/cs/convert.rkt b/racket/src/cs/convert.rkt index e543843957..335b8022c0 100644 --- a/racket/src/cs/convert.rkt +++ b/racket/src/cs/convert.rkt @@ -197,6 +197,47 @@ ;; ---------------------------------------- +;; Startup code as an S-expression uses the pattern +;; (lambda (begin ' )) +;; or +;; (case-lambda [ (begin ' )] ...) +;; 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))]))))))) diff --git a/racket/src/cs/expander.sls b/racket/src/cs/expander.sls index f38079df98..76b58e97fc 100644 --- a/racket/src/cs/expander.sls +++ b/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: diff --git a/racket/src/cs/linklet.sls b/racket/src/cs/linklet.sls index 8efb00a489..93bf4b2d64 100644 --- a/racket/src/cs/linklet.sls +++ b/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)])) diff --git a/racket/src/cs/rumble.sls b/racket/src/cs/rumble.sls index 04bccc8384..b3a2b98d07 100644 --- a/racket/src/cs/rumble.sls +++ b/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 diff --git a/racket/src/cs/rumble/correlated.ss b/racket/src/cs/rumble/correlated.ss index 543b5237fc..7f8c9f2406 100644 --- a/racket/src/cs/rumble/correlated.ss +++ b/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 diff --git a/racket/src/cs/rumble/procedure.ss b/racket/src/cs/rumble/procedure.ss index 9964a4bdf7..3f32883770 100644 --- a/racket/src/cs/rumble/procedure.ss +++ b/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)