diff --git a/racket/src/ChezScheme/mats/cp0.ms b/racket/src/ChezScheme/mats/cp0.ms index fd962e1607..03ceac906c 100644 --- a/racket/src/ChezScheme/mats/cp0.ms +++ b/racket/src/ChezScheme/mats/cp0.ms @@ -3341,3 +3341,28 @@ (expand/optimize '(#3%$app/value x y)) '($app/value x y))) ) + +(mat cross-library-inlining + (begin + ;; Make sure inlining doesn't use the wrong `helper` + (library (cross-library-inlining-test) + (export a b am bm) + (import (rnrs)) + (define-syntax def + (syntax-rules () + [(_ id idm) + (begin + (define (helper x) (if (zero? x) 'id (helper (- x 1)))) + (define (id x) (helper x)) + ;; causes `helper` to be preserved: + (define-syntax idm (syntax-rules () [(_) helper])))])) + (def a am) + (def b bm)) + #t) + (eq? 'a (let () + (import (cross-library-inlining-test)) + (a 10))) + (eq? 'b (let () + (import (cross-library-inlining-test)) + (b 10))) + ) diff --git a/racket/src/ChezScheme/s/compile.ss b/racket/src/ChezScheme/s/compile.ss index cc74227048..26ffbbace3 100644 --- a/racket/src/ChezScheme/s/compile.ss +++ b/racket/src/ChezScheme/s/compile.ss @@ -1250,7 +1250,7 @@ (lambda (node thunk) (build-primcall '$install-library/rt-code `(quote ,(library-node-uid node)) thunk))) - (define-pass patch : Lsrc (ir env) -> Lsrc () + (define-pass patch : Lsrc (ir env exts-table) -> Lsrc () (definitions (define with-initialized-ids (lambda (old-id* proc) @@ -1299,7 +1299,17 @@ [(letrec* ([,x* ,e*] ...) ,body) (with-initialized-ids x* (lambda (x*) - `(letrec* ([,x* ,(map Expr e*)] ...) ,(Expr body))))]) + `(letrec* ([,x* ,(map Expr e*)] ...) ,(Expr body))))] + [(cte-optimization-loc ,box ,e ,exts) + (define new-exts (or (hashtable-ref exts-table exts #f) + (let ([new-exts (map (lambda (p) + (let ([x (car p)]) + (cons (or (prelex-operand x) x) (cdr p)))) + exts)]) + (hashtable-set! exts-table exts new-exts) + new-exts))) + (let ([e (Expr e)]) + `(cte-optimization-loc ,box ,e ,new-exts))]) (CaseLambdaClause : CaseLambdaClause (ir) -> CaseLambdaClause () [(clause (,x* ...) ,interface ,body) (with-initialized-ids x* @@ -1367,7 +1377,8 @@ (nanopass-case (Lexpand Program) (program-node-ir program) [(program ,uid ,body) body]) node*) - (make-patch-env (list node*)))))) + (make-patch-env (list node*)) + (make-eq-hashtable))))) (define build-combined-library-ir (lambda (cluster*) @@ -1442,7 +1453,8 @@ ,body)) body cluster)) (build-void) cluster* cluster-idx*))))) - (make-patch-env cluster*))))) + (make-patch-env cluster*) + (make-eq-hashtable))))) (with-output-language (Lexpand Outer) (define add-recompile-info diff --git a/racket/src/ChezScheme/s/cp0.ss b/racket/src/ChezScheme/s/cp0.ss index 763eddc0d0..0be771fed6 100644 --- a/racket/src/ChezScheme/s/cp0.ss +++ b/racket/src/ChezScheme/s/cp0.ss @@ -87,6 +87,9 @@ ;;; used to memoize pure?, etc. (define-threaded cp0-info-hashtable) + ;; use to preserve sharing with `exts` renaming + (define-threaded exts-table) + (module () (define-syntax define-cp0-param (syntax-rules () @@ -991,7 +994,7 @@ (let loop ([exts exts]) (cond [(null? exts) #f] - [(eq? (prelex-name x) (prelex-name (caar exts))) + [(eq? (prelex-uname x) (prelex-uname (caar exts))) (cdar exts)] [else (loop (cdr exts))])))) (define (ids->do-clause ids) @@ -5467,6 +5470,12 @@ [(moi) (if moi `(quote ,moi) ir)] [(pariah) ir] [(cte-optimization-loc ,box ,[cp0 : e ctxt env sc wd name moi -> e] ,exts) + (define new-exts (or (hashtable-ref exts-table exts #f) + (let ([new-exts (map (lambda (p) + (cons (lookup (car p) env) (cdr p))) + exts)]) + (hashtable-set! exts-table exts new-exts) + new-exts))) (when (enable-cross-library-optimization) (let () (define update-box! @@ -5487,7 +5496,7 @@ ;; than supported by the original, since only inlinable clauses ;; are kept (let ([new-cl* (fold-right (lambda (cl cl*) - (let ([cl (externally-inlinable cl exts)]) + (let ([cl (externally-inlinable cl new-exts)]) (if cl (cons cl cl*) cl*))) @@ -5505,7 +5514,7 @@ sv?))))] [else #f])))] [else (void)]))) - `(cte-optimization-loc ,box ,e ,exts)] + `(cte-optimization-loc ,box ,e ,new-exts)] [(cpvalid-defer ,e) (sorry! who "cpvalid leaked a cpvalid-defer form ~s" ir)] [(profile ,src) ir] [else ($oops who "unrecognized record ~s" ir)]) @@ -5519,7 +5528,8 @@ [(x ltbc?) (fluid-let ([likely-to-be-compiled? ltbc?] [opending-list '()] - [cp0-info-hashtable (make-weak-eq-hashtable)]) + [cp0-info-hashtable (make-weak-eq-hashtable)] + [exts-table (make-weak-eq-hashtable)]) (cp0 x 'tail empty-env (new-scorer) (new-watchdog) #f #f))])))) ; check to make sure all required handlers were seen, after expansion of the diff --git a/racket/src/ChezScheme/s/cpletrec.ss b/racket/src/ChezScheme/s/cpletrec.ss index 5b4cfb2055..070d052e1c 100644 --- a/racket/src/ChezScheme/s/cpletrec.ss +++ b/racket/src/ChezScheme/s/cpletrec.ss @@ -57,6 +57,9 @@ Handling letrec and letrec* (define rtd-flds (csv7:record-field-accessor #!base-rtd 'flds)) (define rtd-mpm (csv7:record-field-accessor #!base-rtd 'mpm)) + ;; use to preserve sharing with `exts` renaming + (define-threaded exts-table) + (define-pass lift-profile-forms : Lsrc (ir) -> Lsrc () (definitions (with-output-language (Lsrc Expr) @@ -388,7 +391,14 @@ Handling letrec and letrec* [(moi) (values ir #t)] [(pariah) (values ir #t)] [(cte-optimization-loc ,box ,[e pure?] ,exts) - (values `(cte-optimization-loc ,box ,e ,exts) pure?)] + (let ([new-exts (or (hashtable-ref exts-table exts #f) + (let ([new-exts (map (lambda (p) + (let ([x (car p)]) + (cons (or (prelex-operand x) x) (cdr p)))) + exts)]) + (hashtable-set! exts-table exts new-exts) + new-exts))]) + (values `(cte-optimization-loc ,box ,e ,new-exts) pure?))] [(profile ,src) (values ir #f)] [else (sorry! who "unhandled record ~s" ir)]) (CaseLambdaClause : CaseLambdaClause (ir) -> CaseLambdaClause () @@ -401,5 +411,6 @@ Handling letrec and letrec* (lambda (x) (let ([x (if (eq? ($compile-profile) 'source) (lift-profile-forms x) x)]) - (cpletrec x))) + (fluid-let ([exts-table (make-weak-eq-hashtable)]) + (cpletrec x)))) ))