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

cs & schemify: fix inlining that fold to #f

Browse Source 
When the schemify inliner tries to inline, and inlining is supposed to
succeed with a result expression `#f`, the #f was being treated as a
failure to inline.
This commit is contained in:
Matthew Flatt 2021-03-07 16:55:18 -07:00
parent e45cd87511
commit 9651b45c83
3 changed files with 80 additions and 52 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

100
pkgs/racket-test-core/tests/racket/optimize.rktl
View File

@ -56,6 +56,7 @@
(define bundle (if (linkl-directory? lnkl) (define bundle (if (linkl-directory? lnkl)
(hash-ref (linkl-directory-table lnkl) '() #f) (hash-ref (linkl-directory-table lnkl) '() #f)
lnkl)) lnkl))
(define top-level? (not (hash-ref (linkl-bundle-table bundle) 'decl #f)))
(unless bundle (unless bundle
(error 'compile/optimize (string-append "didn't find main linklet bundle in directory;" (error 'compile/optimize (string-append "didn't find main linklet bundle in directory;"
" maybe a top-level `begin` sequence?"))) " maybe a top-level `begin` sequence?")))
@ -71,15 +72,22 @@
(error 'compile/optimize "compiled content does not have expected shape: ~s" (error 'compile/optimize "compiled content does not have expected shape: ~s"
s-exp)) s-exp))
;; Support cross-module inlining, at least through one layer of `require`
(define-values (mpi-vector requires provides phase-to-link-modules) (define-values (mpi-vector requires provides phase-to-link-modules)
(deserialize-requires-and-provides bundle)) (deserialize-requires-and-provides bundle))
(define link-modules (hash-ref phase-to-link-modules 0 '())) (define link-modules (hash-ref phase-to-link-modules 0 '()))
(define keys (for/list ([r (in-list link-modules)])
(gensym))) ;; Support cross-module inlining
(define mod-uses (for/hasheq ([key (in-list keys)] (define (bundle->keys+uses bundle)
[mod-use (in-list link-modules)]) (define-values (mpi-vector requires provides phase-to-link-modules)
(values key mod-use))) (deserialize-requires-and-provides bundle))
(define link-modules (hash-ref phase-to-link-modules 0 '()))
(define keys (for/list ([r (in-list link-modules)])
(gensym)))
(define mod-uses (for/hasheq ([key (in-list keys)]
[mod-use (in-list link-modules)])
(values key mod-use)))
(values keys mod-uses))
(define-values (keys mod-uses) (bundle->keys+uses bundle))
(define (get-module-info key) (define (get-module-info key)
(define mu (hash-ref mod-uses key #f)) (define mu (hash-ref mod-uses key #f))
(cond (cond
@ -95,7 +103,8 @@
mpi mpi
(module-path-index-join name new-base))] (module-path-index-join name new-base))]
[else mpi])) [else mpi]))
(define mp (module-path-index-resolve (replace-self (module-use-module mu)) #f)) (define mpi (replace-self (module-use-module mu)))
(define mp (module-path-index-resolve mpi #f))
(define path (resolved-module-path-name mp)) (define path (resolved-module-path-name mp))
(cond (cond
[(path? path) [(path? path)
@ -105,7 +114,10 @@
(hash-ref (linkl-directory-table lnkl) '() #f) (hash-ref (linkl-directory-table lnkl) '() #f)
lnkl)) lnkl))
(define code (hash-ref (linkl-bundle-table bundle) (module-use-phase mu) #f)) (define code (hash-ref (linkl-bundle-table bundle) (module-use-phase mu) #f))
(values code #f)] (define-values (new-keys new-mod-uses) (bundle->keys+uses bundle))
(for ([(k mu) (in-hash new-mod-uses)])
(set! mod-uses (hash-set mod-uses k mu)))
(values code (list->vector (append '(#f #f) new-keys)))]
[else [else
(values #f #f)])] (values #f #f)])]
[else (values #f #f)])) [else (values #f #f)]))
@ -114,7 +126,10 @@
(expand/optimize-linklet s-exp) (expand/optimize-linklet s-exp)
(expand/optimize-linklet s-exp (expand/optimize-linklet s-exp
#f #f
(list->vector (append '(#f #f #f) keys)) (list->vector (append (if top-level?
'(#f #f #f)
'(#f #f))
keys))
get-module-info get-module-info
'()))) '())))
@ -3147,17 +3162,17 @@
(unsafe-fl+ 10 x) (unsafe-fl+ 10 x)
f))))) f)))))
;; double-check that previous test doesn't succeed due to copying ;; double-check that previous test doesn't succeed due to copying
(test-comp '(lambda (y) (test-comp '(lambda (y g)
(let ([q (unsafe-fl* y y)]) (let ([q (unsafe-fl* y y)])
(let ([x (unsafe-fl* q q)]) (let ([x (unsafe-fl* q q)])
(define (f z) (unsafe-fl+ z x)) (define (f z) (unsafe-fl+ z x))
(if y (if (g)
(unsafe-fl+ 10 x) (unsafe-fl+ 10 x)
f)))) f))))
'(lambda (y) '(lambda (y g)
(let ([q (unsafe-fl* y y)]) (let ([q (unsafe-fl* y y)])
(define (f z) (unsafe-fl+ z (unsafe-fl* q q))) (define (f z) (unsafe-fl+ z (unsafe-fl* q q)))
(if y (if (g)
(unsafe-fl+ 10 (unsafe-fl* q q)) (unsafe-fl+ 10 (unsafe-fl* q q))
f))) f)))
#f) #f)
@ -3212,7 +3227,8 @@
(+ p m (- p p) t)) (+ p m (- p p) t))
'ok)))) 'ok))))
(test-comp '(lambda (n) (test-comp #:except 'chez-scheme ; reordering is not important to Chez Scheme backend
'(lambda (n)
(let ([p (fx+ n n)]) (let ([p (fx+ n n)])
(if n (if n
(let ([m (unsafe-fx- p 1)] (let ([m (unsafe-fx- p 1)]
@ -3245,16 +3261,18 @@
'(lambda (n) '(lambda (n)
(let ([p (fx+ n n)]) (let ([p (fx+ n n)])
(fx+ p p)))) (fx+ p p))))
(test-comp '(lambda (n) (when (extflonum-available?)
(let ([p (extfl+ n n)]) (test-comp '(lambda (n)
(if (extflonum? p) (let ([p (extfl+ n n)])
(extfl+ p p) (if (extflonum? p)
'bad))) (extfl+ p p)
'(lambda (n) 'bad)))
(let ([p (extfl+ n n)]) '(lambda (n)
(extfl+ p p)))) (let ([p (extfl+ n n)])
(extfl+ p p)))))
(test-comp '(lambda (n) (test-comp #:except 'chez-scheme ; lifting out `random` requires another pass?
'(lambda (n)
(let ([p (fl+ n n)]) (let ([p (fl+ n n)])
(list (list
p p p p
@ -3269,7 +3287,8 @@
(begin (random) #t) (begin (random) #t)
(letrec ([x (lambda (t) x)]) (x x) #t))))) (letrec ([x (lambda (t) x)]) (x x) #t)))))
(test-comp '(lambda (n) (test-comp #:except 'chez-scheme ; lifting out `random` requires another pass?
'(lambda (n)
(let ([p (fx+ n n)]) (let ([p (fx+ n n)])
(list (list
p p p p
@ -3283,27 +3302,30 @@
#t #t
(begin (random) #t) (begin (random) #t)
(letrec ([x (lambda (t) x)]) (x x) #t))))) (letrec ([x (lambda (t) x)]) (x x) #t)))))
(test-comp '(lambda (n) (when (extflonum-available?)
(let ([p (extfl+ n n)]) (test-comp '(lambda (n)
(list (let ([p (extfl+ n n)])
p p (list
(extflonum? p) p p
(extflonum? (begin (random) p)) (extflonum? p)
(extflonum? (letrec ([x (lambda (t) x)]) (x x) p))))) (extflonum? (begin (random) p))
'(lambda (n) (extflonum? (letrec ([x (lambda (t) x)]) (x x) p)))))
(let ([p (extfl+ n n)]) '(lambda (n)
(list (let ([p (extfl+ n n)])
p p (list
#t p p
(begin (random) #t) #t
(letrec ([x (lambda (t) x)]) (x x) #t))))) (begin (random) #t)
(letrec ([x (lambda (t) x)]) (x x) #t))))))
;; simple cross-module inlining ;; simple cross-module inlining
(test-comp `(module m racket/base (test-comp `(module m racket/base
(require racket/bool) (require racket/bool)
true
(list true)) (list true))
`(module m racket/base `(module m racket/base
(require racket/bool) (require racket/bool)
true ; so that it counts as imported
(list #t))) (list #t)))
(test-comp `(module m racket/base (test-comp `(module m racket/base

22
racket/src/cs/schemified/schemify.scm
View File

@ -29866,15 +29866,19 @@
formal-args_1) formal-args_1)
(if (null? (if (null?
args_0) args_0)
(schemify/knowns_0 (let ((r_0
knowns_1 (schemify/knowns_0
inline-fuel_1 knowns_1
wcm-state_2 inline-fuel_1
(list* wcm-state_2
'let-values (list*
(reverse$1 'let-values
binds_0) (reverse$1
bodys_0)) binds_0)
bodys_0))))
(if r_0
r_0
''#f))
#f) #f)
(if (null? (if (null?
args_0) args_0)

10
racket/src/schemify/schemify.rkt
View File

@ -818,10 +818,12 @@
(cond (cond
[(null? formal-args) [(null? formal-args)
(and (null? args) (and (null? args)
(schemify/knowns knowns (let ([r (schemify/knowns knowns
inline-fuel inline-fuel
wcm-state wcm-state
`(let-values ,(reverse binds) . ,bodys)))] `(let-values ,(reverse binds) . ,bodys))])
;; make suure constant-fold to #f counts as success:
(or r `(quote #f))))]
[(null? args) #f] [(null? args) #f]
[(not (pair? formal-args)) [(not (pair? formal-args))
(loop '() '() (cons (list (list formal-args) (loop '() '() (cons (list (list formal-args)