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

cs & schemify: cptypes-nice inline of authentic access and mutate

Browse Source 
Change schemify to inline accessors and mutators of authentic
structure types in a way that lets cptypes eliminate checks for
subsequent operations.
This commit is contained in:
Matthew Flatt 2021-03-07 19:09:14 -07:00
parent 9651b45c83
commit 87d84a59c1
3 changed files with 148 additions and 82 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

@ -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,10 +112,7 @@
(define mpi (replace-self (module-use-module mu)))
(define mp (module-path-index-resolve mpi #f))
(define path (resolved-module-path-name mp))
(cond
[(path? path)
(define zo-path (get-compilation-bytecode-file path))
(define lnkl (call-with-input-file* zo-path zo-parse))
(define (handle-linklet lnkl)
(define bundle (if (linkl-directory? lnkl)
(hash-ref (linkl-directory-table lnkl) '() #f)
lnkl))
@ -117,7 +120,22 @@
(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)))]
(values code (list->vector (append '(#f #f) new-keys))))
(cond
[(path? path)
(define zo-path (get-compilation-bytecode-file path))
(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,7 +3434,8 @@
c
c)))
(module check-inline-request racket/base
(register-top-level-module
(module check-inline-request racket/base
(require racket/performance-hint)
(provide loop)
(begin-encourage-inline
@ -3426,7 +3445,7 @@
(let loop ([i n])
(if (zero? i)
10
(cons (f i) (loop (sub1 n)))))))))
(cons (f i) (loop (sub1 n))))))))))
(test-comp `(module m racket/base
(require 'check-inline-request)
@ -3524,6 +3543,7 @@
(displayln (list expr 3 '!))
)
(map check-omit-ok
(append
'((unsafe-vector*-ref x y)
(unsafe-struct*-ref x y)
(unsafe-mcar x)
@ -3532,11 +3552,14 @@
(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-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)))
(unsafe-u16vector-ref x y)))))
(map (lambda (x) (check-omit-ok x #f))
(append
'((unsafe-vector-ref x y)
(unsafe-struct-ref x y)
(unsafe-vector-set! x y z)
@ -3551,10 +3574,12 @@
(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-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)))
(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)))
(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-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
(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)))
(struct b a (z))))
(module struct-c-for-optimize racket/base
(register-top-level-module
(module struct-c-for-optimize racket/base
(require 'struct-a-for-optimize)
(provide (struct-out c))
(struct c a (q)))
(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)

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

@ -30297,9 +30297,16 @@
'if
app_0
app_1
(let ((a_0
(list
s-rator_0
tmp_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
(let ((a_0
(list
s-rator_0
tmp_0
tmp-rhs_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)))

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

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