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