suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Chez Scheme: repair for cross-library inlining

Browse Source 
The cross-library inlining improvement in commit 6020b944ef did not
manage internal names correctly, and it could mix up bindings that
have the same printed form.

Closes racket/ChezScheme#35
This commit is contained in:
Matthew Flatt 2021-03-23 13:40:51 -06:00
parent 281eed7dda
commit 2a718d8162
4 changed files with 68 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
racket/src/ChezScheme/mats/cp0.ms
View File

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

20
racket/src/ChezScheme/s/compile.ss
View File

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

18
racket/src/ChezScheme/s/cp0.ss
View File

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

15
racket/src/ChezScheme/s/cpletrec.ss
View File

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