From 87d84a59c18bc3635887a586fb521b6abc3f404b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 7 Mar 2021 19:09:14 -0700 Subject: [PATCH] cs & schemify: cptypes-nice inline of authentic access and mutate Change schemify to inline accessors and mutators of authentic structure types in a way that lets cptypes eliminate checks for subsequent operations. --- .../tests/racket/optimize.rktl | 192 +++++++++++------- racket/src/cs/schemified/schemify.scm | 28 ++- racket/src/schemify/schemify.rkt | 10 +- 3 files changed, 148 insertions(+), 82 deletions(-) diff --git a/pkgs/racket-test-core/tests/racket/optimize.rktl b/pkgs/racket-test-core/tests/racket/optimize.rktl index a7401b4f30..a5c859340e 100644 --- a/pkgs/racket-test-core/tests/racket/optimize.rktl +++ b/pkgs/racket-test-core/tests/racket/optimize.rktl @@ -22,6 +22,12 @@ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(define saved-top-level-modules (make-hasheq)) +(define-syntax-rule (register-top-level-module m) + (begin + (hash-set! saved-top-level-modules (cadr 'm) 'm) + m)) + ;; For CS: (define compile/optimize (let () @@ -106,18 +112,30 @@ (define mpi (replace-self (module-use-module mu))) (define mp (module-path-index-resolve mpi #f)) (define path (resolved-module-path-name mp)) + (define (handle-linklet lnkl) + (define bundle (if (linkl-directory? lnkl) + (hash-ref (linkl-directory-table lnkl) '() #f) + lnkl)) + (define code (hash-ref (linkl-bundle-table bundle) (module-use-phase mu) #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)))) (cond [(path? path) (define zo-path (get-compilation-bytecode-file path)) - (define lnkl (call-with-input-file* zo-path zo-parse)) - (define bundle (if (linkl-directory? lnkl) - (hash-ref (linkl-directory-table lnkl) '() #f) - lnkl)) - (define code (hash-ref (linkl-bundle-table bundle) (module-use-phase mu) #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)))] + (handle-linklet (call-with-input-file* zo-path zo-parse))] + [(hash-ref saved-top-level-modules path #f) + => (lambda (m) + (handle-linklet + (cond + [(list? m) + (define o (open-output-bytes)) + (write (compile m) o) + (define linkl (zo-parse (open-input-bytes (get-output-bytes o)))) + (hash-set! saved-top-level-modules path linkl) + linkl] + [else m])))] [else (values #f #f)])] [else (values #f #f)])) @@ -3416,17 +3434,18 @@ c c))) -(module check-inline-request racket/base - (require racket/performance-hint) - (provide loop) - (begin-encourage-inline - (define loop - ;; large enough that the compiler wouldn't infer inlining: - (lambda (f n) - (let loop ([i n]) - (if (zero? i) - 10 - (cons (f i) (loop (sub1 n))))))))) +(register-top-level-module + (module check-inline-request racket/base + (require racket/performance-hint) + (provide loop) + (begin-encourage-inline + (define loop + ;; large enough that the compiler wouldn't infer inlining: + (lambda (f n) + (let loop ([i n]) + (if (zero? i) + 10 + (cons (f i) (loop (sub1 n)))))))))) (test-comp `(module m racket/base (require 'check-inline-request) @@ -3524,37 +3543,43 @@ (displayln (list expr 3 '!)) ) (map check-omit-ok - '((unsafe-vector*-ref x y) - (unsafe-struct*-ref x y) - (unsafe-mcar x) - (unsafe-mcdr x) - (unsafe-unbox* x) - (unsafe-bytes-ref x y) - (unsafe-string-ref x y) - (unsafe-flvector-ref x y) - (unsafe-fxvector-ref x y) - (unsafe-f64vector-ref x y) - (unsafe-s16vector-ref x y) - (unsafe-u16vector-ref x y))) + (append + '((unsafe-vector*-ref x y) + (unsafe-struct*-ref x y) + (unsafe-mcar x) + (unsafe-mcdr x) + (unsafe-unbox* x) + (unsafe-bytes-ref x y) + (unsafe-string-ref x y) + (unsafe-flvector-ref x y) + (unsafe-fxvector-ref x y)) + (if (eq? 'chez-scheme (system-type 'vm)) + '() + '((unsafe-f64vector-ref x y) + (unsafe-s16vector-ref x y) + (unsafe-u16vector-ref x y))))) (map (lambda (x) (check-omit-ok x #f)) - '((unsafe-vector-ref x y) - (unsafe-struct-ref x y) - (unsafe-vector-set! x y z) - (unsafe-vector*-set! x y z) - (unsafe-struct-set! x y z) - (unsafe-struct*-set! x y z) - (unsafe-set-mcar! x y) - (unsafe-set-mcdr! x y) - (unsafe-unbox y) - (unsafe-set-box! x y) - (unsafe-set-box*! x y) - (unsafe-bytes-set! x y z) - (unsafe-string-set! x y z) - (unsafe-flvector-set! x y z) - (unsafe-fxvector-set! x y z) - (unsafe-f64vector-set! x y z) - (unsafe-s16vector-set! x y z) - (unsafe-u16vector-set! x y z))) + (append + '((unsafe-vector-ref x y) + (unsafe-struct-ref x y) + (unsafe-vector-set! x y z) + (unsafe-vector*-set! x y z) + (unsafe-struct-set! x y z) + (unsafe-struct*-set! x y z) + (unsafe-set-mcar! x y) + (unsafe-set-mcdr! x y) + (unsafe-unbox y) + (unsafe-set-box! x y) + (unsafe-set-box*! x y) + (unsafe-bytes-set! x y z) + (unsafe-string-set! x y z) + (unsafe-flvector-set! x y z) + (unsafe-fxvector-set! x y z)) + (if (eq? 'chez-scheme (system-type 'vm)) + '() + '((unsafe-f64vector-set! x y z) + (unsafe-s16vector-set! x y z) + (unsafe-u16vector-set! x y z))))) (when (extflonum-available?) (map check-omit-ok @@ -3567,11 +3592,13 @@ )) )) -(test-comp '(lambda (x) +(test-comp #:except 'chez-scheme + '(lambda (x) (hash-ref '#hash((x . y)) x (lambda () 10))) '(lambda (x) (hash-ref '#hash((x . y)) x 10))) -(test-comp '(lambda (x) +(test-comp #:except 'chez-scheme + '(lambda (x) (hash-ref x x (lambda () 10))) '(lambda (x) (hash-ref x x 10)) @@ -3582,7 +3609,8 @@ (hash-ref '#hash((x . y)) x add1)) #f) -(test-comp '(lambda () +(test-comp #:except 'chez-scheme + '(lambda () (hash-ref #hash() 'missing (λ () @@ -3602,7 +3630,7 @@ 'UNEXPECTED!)) #f) -(let () +(unless (eq? 'chez-scheme (system-type 'vm)) (define (check-empty-allocation hash-sym) (test-comp `(lambda () (,hash-sym) 5) '(lambda () 5)) @@ -3664,16 +3692,18 @@ (define (check-discard-iterate op-name) (test-comp `(lambda (ht i) (,op-name ht i) 5) `(lambda (ht i) 5))) - (check-discard-iterate 'unsafe-immutable-hash-iterate-next) - (check-discard-iterate 'unsafe-immutable-hash-iterate-key) - (check-discard-iterate 'unsafe-immutable-hash-iterate-value) - (check-discard-iterate 'unsafe-immutable-hash-iterate-key+value) - (check-discard-iterate 'unsafe-immutable-hash-iterate-pair)) + (unless (eq? 'chez-scheme (system-type 'vm)) + (check-discard-iterate 'unsafe-immutable-hash-iterate-next) + (check-discard-iterate 'unsafe-immutable-hash-iterate-key) + (check-discard-iterate 'unsafe-immutable-hash-iterate-value) + (check-discard-iterate 'unsafe-immutable-hash-iterate-key+value) + (check-discard-iterate 'unsafe-immutable-hash-iterate-pair))) ;; Check elimination of ignored structure predicate ;; and constructor applications: -(test-comp '(module m racket/base +(test-comp #:except 'chez-scheme ; schemify doesn't specialize raw accessor+mutator form + '(module m racket/base (define-values (struct:a a a? a-ref a-set!) (make-struct-type 'a #f 2 0)) (begin0 @@ -3694,7 +3724,7 @@ (test-comp '(module m racket/base (define-values (struct:a a a? a-x a-y) (let-values ([(struct:a a a? a-ref a-set!) - (make-struct-type 'a #f 2 0)]) + (make-struct-type 'a #f 2 0 #f)]) (values struct:a a a? (make-struct-field-accessor a-ref 0) (make-struct-field-accessor a-ref 1)))) @@ -3709,7 +3739,7 @@ '(module m racket/base (define-values (struct:a a a? a-x a-y) (let-values ([(struct:a a a? a-ref a-set!) - (make-struct-type 'a #f 2 0)]) + (make-struct-type 'a #f 2 0 #f)]) (values struct:a a a? (make-struct-field-accessor a-ref 0) (make-struct-field-accessor a-ref 1)))) @@ -3816,16 +3846,18 @@ (a? (a-x (a 1 2))) 5))) -(module struct-a-for-optimize racket/base - (provide (struct-out a) - (struct-out b)) - (struct a (x y)) - (struct b a (z))) +(register-top-level-module + (module struct-a-for-optimize racket/base + (provide (struct-out a) + (struct-out b)) + (struct a (x y)) + (struct b a (z)))) -(module struct-c-for-optimize racket/base - (require 'struct-a-for-optimize) - (provide (struct-out c)) - (struct c a (q))) +(register-top-level-module + (module struct-c-for-optimize racket/base + (require 'struct-a-for-optimize) + (provide (struct-out c)) + (struct c a (q)))) (test-comp '(module m racket/base (require 'struct-a-for-optimize) @@ -3864,7 +3896,8 @@ (list (c? (c-q (c 1 2 3)))) 5))) -(test-comp '(module m racket/base +(test-comp #:except 'chez-scheme ; compilation of known accessor is not the same as `unsafe-struct-ref` + '(module m racket/base (require racket/unsafe/ops) (struct a (x y)) (define (f v) @@ -3896,7 +3929,8 @@ (unsafe-struct*-ref v 1)) (void))))) -(test-comp '(module m racket/base +(test-comp #:except 'chez-scheme ; compilation of known accessor is not the same as `unsafe-struct-ref` + '(module m racket/base (require racket/unsafe/ops) (struct a (x y)) (define (f v) @@ -3909,6 +3943,18 @@ (unsafe-struct-ref v 1))))) (test-comp '(module m racket/base + (require racket/unsafe/ops) + (struct a (x y) #:authentic) + (define (f v) + (list (a-x v) (a? v)))) + '(module m racket/base + (require racket/unsafe/ops) + (struct a (x y) #:authentic) + (define (f v) + (list (a-x v) #t)))) + +(test-comp #:except 'chez-scheme + '(module m racket/base (require racket/unsafe/ops) (struct a (x y)) (define (f v) diff --git a/racket/src/cs/schemified/schemify.scm b/racket/src/cs/schemified/schemify.scm index 123c617eb0..0f663e5ca5 100644 --- a/racket/src/cs/schemified/schemify.scm +++ b/racket/src/cs/schemified/schemify.scm @@ -30297,9 +30297,16 @@ 'if app_0 app_1 - (list - s-rator_0 - tmp_0))))))) + (let ((a_0 + (list + s-rator_0 + tmp_0))) + (if (known-field-accessor-authentic? + k_0) + (cons + '|#%app/no-return| + a_0) + a_0)))))))) (wrap-tmp_0 tmp_0 (car @@ -30372,10 +30379,17 @@ 'if app_0 app_1 - (list - s-rator_0 - tmp_0 - tmp-rhs_0))))))) + (let ((a_0 + (list + s-rator_0 + tmp_0 + tmp-rhs_0))) + (if (known-field-mutator-authentic? + k_0) + (cons + '|#%app/no-return| + a_0) + a_0)))))))) (let ((app_0 (car args_0))) diff --git a/racket/src/schemify/schemify.rkt b/racket/src/schemify/schemify.rkt index 72b9038c75..22ec7ca9a0 100644 --- a/racket/src/schemify/schemify.rkt +++ b/racket/src/schemify/schemify.rkt @@ -909,7 +909,10 @@ `(unsafe-struct*-ref ,tmp ,(known-field-accessor-pos k)) `(if (unsafe-struct? ,tmp ,(schemify type-id 'fresh)) (unsafe-struct*-ref ,tmp ,(known-field-accessor-pos k)) - (,s-rator ,tmp)))) + ,(let ([a `(,s-rator ,tmp)]) + (if (known-field-accessor-authentic? k) + (cons '#%app/no-return a) + a))))) (wrap-tmp tmp (car args) sel)] [else #f])) @@ -927,7 +930,10 @@ `(unsafe-struct*-set! ,tmp ,(known-field-mutator-pos k) ,tmp-rhs) `(if (unsafe-struct? ,tmp ,(schemify type-id 'fresh)) (unsafe-struct*-set! ,tmp ,(known-field-mutator-pos k) ,tmp-rhs) - (,s-rator ,tmp ,tmp-rhs)))) + ,(let ([a `(,s-rator ,tmp ,tmp-rhs)]) + (if (known-field-mutator-authentic? k) + (cons '#%app/no-return a) + a))))) (wrap-tmp tmp (car args) (wrap-tmp tmp-rhs (cadr args) mut))]