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

add cross-library inlining support for procedure with improper formals

Browse Source
This commit is contained in:
yjqww6 2020-12-08 23:06:50 +08:00 committed by Matthew Flatt
parent d7a226053e
commit cbd7a2b2af
2 changed files with 57 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
racket/src/ChezScheme/mats/8.ms
View File

@ -9302,6 +9302,41 @@
'(#t . #t))
(equal? (let () (import (testfile-clo-3a)) (h)) (void))
(not (let () (import (testfile-clo-3a)) (g)))
; testing support of procedures with improper formals
(begin
(with-output-to-file "testfile-clo-4a.ss"
(lambda ()
(pretty-print
'(library (testfile-clo-4a)
(export f g)
(import (chezscheme))
(define (f a . rest)
(apply list a rest))
(define g
(case-lambda
[(a) "foo"]
[(a . rest) (apply list a rest)])))))
'replace)
#t)
(begin
(load-library "testfile-clo-4a.ss"
(lambda (x) (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f] [current-eval compile])
(eval x))))
#t)
(equivalent-expansion?
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(expand/optimize
'(lambda (x y z)
(import (testfile-clo-4a))
(list
(f x y z)
(g x y z)))))
'(begin
(#3%$invoke-library '(testfile-clo-4a) '() 'testfile-clo-4a)
(lambda (x y z)
(#2%list (#2%list x y z)
((#3%$top-level-value 'g) x y z)))))
)
(mat lots-of-libraries

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

@ -3038,7 +3038,9 @@
(preinfo-call-can-inline? (app-preinfo ctxt)) ; $top-level-value may be marked by previous inline
(assq ($target-machine) ($cte-optimization-info d))) =>
(lambda (as)
(let ([opt (cdr as)])
(let* ([opt (cdr as)]
[full? (pair? opt)]
[opt (if full? (car opt) opt)])
(nanopass-case (Lsrc Expr) opt
[(quote ,d)
(residualize-seq '() (list x) ctxt)
@ -3060,12 +3062,16 @@
;; The `case-lambda` form for inlining may have fewer cases
;; than the actual binding, so only try to inline if there's
;; a matching clause
;; unless all the clauses are preserved
(let ([n (length (app-opnds (app-ctxt ctxt)))])
(cond
[(ormap (lambda (cl)
(nanopass-case (Lsrc CaseLambdaClause) cl
[(clause (,x* ...) ,interface ,body)
(= n interface)]))
(or (= n interface)
(and full?
(fx< interface 0)
(fx>= n (fx- -1 interface))))]))
cl*)
(residualize-seq '() (list x) ctxt)
(cp0 opt (app-ctxt ctxt) empty-env sc wd (app-name ctxt) moi)]
@ -5313,14 +5319,14 @@
(when (enable-cross-library-optimization)
(let ()
(define update-box!
(lambda (box e)
(lambda (box e full?)
(set-box! box
(cons
(cons ($target-machine) e)
(cons ($target-machine) (if full? (cons e #f) e))
(remp (lambda (as) (eq? (car as) ($target-machine))) (unbox box))))))
(nanopass-case (Lsrc Expr) e
[(quote ,d) (and (okay-to-copy? d) (update-box! box e))]
[,pr (update-box! box pr)]
[(quote ,d) (and (okay-to-copy? d) (update-box! box e #f))]
[,pr (update-box! box pr #f)]
[(ref ,maybe-src ,x)
(and (not (prelex-was-assigned x))
(let ([rhs (result-exp (operand-value (prelex-operand x)))])
@ -5329,15 +5335,16 @@
;; Function registered for inlining may report fewer clauses
;; than supported by the original, since only inlinable clauses
;; are kept
(let ([cl* (fold-right (lambda (cl cl*)
(let ([cl (externally-inlinable cl exts)])
(if cl
(cons cl cl*)
cl*)))
'()
cl*)])
(when (pair? cl*)
(update-box! box `(case-lambda ,preinfo ,cl* ...))))]
(let ([new-cl* (fold-right (lambda (cl cl*)
(let ([cl (externally-inlinable cl exts)])
(if cl
(cons cl cl*)
cl*)))
'()
cl*)])
(when (pair? new-cl*)
(update-box! box `(case-lambda ,preinfo ,new-cl* ...)
(= (length cl*) (length new-cl*)))))]
[else #f])))]
[else (void)])))
`(cte-optimization-loc ,box ,e ,exts)]