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.
This commit is contained in:
Matthew Flatt
parent
9651b45c83
commit
87d84a59c1
|
|
@ -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:
|
;; For CS:
|
||||||
(define compile/optimize
|
(define compile/optimize
|
||||||
(let ()
|
(let ()
|
||||||
|
|
@ -106,18 +112,30 @@
|
||||||
(define mpi (replace-self (module-use-module mu)))
|
(define mpi (replace-self (module-use-module mu)))
|
||||||
(define mp (module-path-index-resolve mpi #f))
|
(define mp (module-path-index-resolve mpi #f))
|
||||||
(define path (resolved-module-path-name mp))
|
(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
|
(cond
|
||||||
[(path? path)
|
[(path? path)
|
||||||
(define zo-path (get-compilation-bytecode-file path))
|
(define zo-path (get-compilation-bytecode-file path))
|
||||||
(define lnkl (call-with-input-file* zo-path zo-parse))
|
(handle-linklet (call-with-input-file* zo-path zo-parse))]
|
||||||
(define bundle (if (linkl-directory? lnkl)
|
[(hash-ref saved-top-level-modules path #f)
|
||||||
(hash-ref (linkl-directory-table lnkl) '() #f)
|
=> (lambda (m)
|
||||||
lnkl))
|
(handle-linklet
|
||||||
(define code (hash-ref (linkl-bundle-table bundle) (module-use-phase mu) #f))
|
(cond
|
||||||
(define-values (new-keys new-mod-uses) (bundle->keys+uses bundle))
|
[(list? m)
|
||||||
(for ([(k mu) (in-hash new-mod-uses)])
|
(define o (open-output-bytes))
|
||||||
(set! mod-uses (hash-set mod-uses k mu)))
|
(write (compile m) o)
|
||||||
(values code (list->vector (append '(#f #f) new-keys)))]
|
(define linkl (zo-parse (open-input-bytes (get-output-bytes o))))
|
||||||
|
(hash-set! saved-top-level-modules path linkl)
|
||||||
|
linkl]
|
||||||
|
[else m])))]
|
||||||
[else
|
[else
|
||||||
(values #f #f)])]
|
(values #f #f)])]
|
||||||
[else (values #f #f)]))
|
[else (values #f #f)]))
|
||||||
|
|
@ -3416,17 +3434,18 @@
|
||||||
c
|
c
|
||||||
c)))
|
c)))
|
||||||
|
|
||||||
(module check-inline-request racket/base
|
(register-top-level-module
|
||||||
(require racket/performance-hint)
|
(module check-inline-request racket/base
|
||||||
(provide loop)
|
(require racket/performance-hint)
|
||||||
(begin-encourage-inline
|
(provide loop)
|
||||||
(define loop
|
(begin-encourage-inline
|
||||||
;; large enough that the compiler wouldn't infer inlining:
|
(define loop
|
||||||
(lambda (f n)
|
;; large enough that the compiler wouldn't infer inlining:
|
||||||
(let loop ([i n])
|
(lambda (f n)
|
||||||
(if (zero? i)
|
(let loop ([i n])
|
||||||
10
|
(if (zero? i)
|
||||||
(cons (f i) (loop (sub1 n)))))))))
|
10
|
||||||
|
(cons (f i) (loop (sub1 n))))))))))
|
||||||
|
|
||||||
(test-comp `(module m racket/base
|
(test-comp `(module m racket/base
|
||||||
(require 'check-inline-request)
|
(require 'check-inline-request)
|
||||||
|
|
@ -3524,37 +3543,43 @@
|
||||||
(displayln (list expr 3 '!))
|
(displayln (list expr 3 '!))
|
||||||
)
|
)
|
||||||
(map check-omit-ok
|
(map check-omit-ok
|
||||||
'((unsafe-vector*-ref x y)
|
(append
|
||||||
(unsafe-struct*-ref x y)
|
'((unsafe-vector*-ref x y)
|
||||||
(unsafe-mcar x)
|
(unsafe-struct*-ref x y)
|
||||||
(unsafe-mcdr x)
|
(unsafe-mcar x)
|
||||||
(unsafe-unbox* x)
|
(unsafe-mcdr x)
|
||||||
(unsafe-bytes-ref x y)
|
(unsafe-unbox* x)
|
||||||
(unsafe-string-ref x y)
|
(unsafe-bytes-ref x y)
|
||||||
(unsafe-flvector-ref x y)
|
(unsafe-string-ref x y)
|
||||||
(unsafe-fxvector-ref x y)
|
(unsafe-flvector-ref x y)
|
||||||
(unsafe-f64vector-ref x y)
|
(unsafe-fxvector-ref x y))
|
||||||
(unsafe-s16vector-ref x y)
|
(if (eq? 'chez-scheme (system-type 'vm))
|
||||||
(unsafe-u16vector-ref x y)))
|
'()
|
||||||
|
'((unsafe-f64vector-ref x y)
|
||||||
|
(unsafe-s16vector-ref x y)
|
||||||
|
(unsafe-u16vector-ref x y)))))
|
||||||
(map (lambda (x) (check-omit-ok x #f))
|
(map (lambda (x) (check-omit-ok x #f))
|
||||||
'((unsafe-vector-ref x y)
|
(append
|
||||||
(unsafe-struct-ref x y)
|
'((unsafe-vector-ref x y)
|
||||||
(unsafe-vector-set! x y z)
|
(unsafe-struct-ref x y)
|
||||||
(unsafe-vector*-set! x y z)
|
(unsafe-vector-set! x y z)
|
||||||
(unsafe-struct-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-struct*-set! x y z)
|
||||||
(unsafe-set-mcdr! x y)
|
(unsafe-set-mcar! x y)
|
||||||
(unsafe-unbox y)
|
(unsafe-set-mcdr! x y)
|
||||||
(unsafe-set-box! x y)
|
(unsafe-unbox y)
|
||||||
(unsafe-set-box*! x y)
|
(unsafe-set-box! x y)
|
||||||
(unsafe-bytes-set! x y z)
|
(unsafe-set-box*! x y)
|
||||||
(unsafe-string-set! x y z)
|
(unsafe-bytes-set! x y z)
|
||||||
(unsafe-flvector-set! x y z)
|
(unsafe-string-set! x y z)
|
||||||
(unsafe-fxvector-set! x y z)
|
(unsafe-flvector-set! x y z)
|
||||||
(unsafe-f64vector-set! x y z)
|
(unsafe-fxvector-set! x y z))
|
||||||
(unsafe-s16vector-set! x y z)
|
(if (eq? 'chez-scheme (system-type 'vm))
|
||||||
(unsafe-u16vector-set! x y z)))
|
'()
|
||||||
|
'((unsafe-f64vector-set! x y z)
|
||||||
|
(unsafe-s16vector-set! x y z)
|
||||||
|
(unsafe-u16vector-set! x y z)))))
|
||||||
|
|
||||||
(when (extflonum-available?)
|
(when (extflonum-available?)
|
||||||
(map check-omit-ok
|
(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)))
|
(hash-ref '#hash((x . y)) x (lambda () 10)))
|
||||||
'(lambda (x)
|
'(lambda (x)
|
||||||
(hash-ref '#hash((x . y)) x 10)))
|
(hash-ref '#hash((x . y)) x 10)))
|
||||||
(test-comp '(lambda (x)
|
(test-comp #:except 'chez-scheme
|
||||||
|
'(lambda (x)
|
||||||
(hash-ref x x (lambda () 10)))
|
(hash-ref x x (lambda () 10)))
|
||||||
'(lambda (x)
|
'(lambda (x)
|
||||||
(hash-ref x x 10))
|
(hash-ref x x 10))
|
||||||
|
|
@ -3582,7 +3609,8 @@
|
||||||
(hash-ref '#hash((x . y)) x add1))
|
(hash-ref '#hash((x . y)) x add1))
|
||||||
#f)
|
#f)
|
||||||
|
|
||||||
(test-comp '(lambda ()
|
(test-comp #:except 'chez-scheme
|
||||||
|
'(lambda ()
|
||||||
(hash-ref #hash()
|
(hash-ref #hash()
|
||||||
'missing
|
'missing
|
||||||
(λ ()
|
(λ ()
|
||||||
|
|
@ -3602,7 +3630,7 @@
|
||||||
'UNEXPECTED!))
|
'UNEXPECTED!))
|
||||||
#f)
|
#f)
|
||||||
|
|
||||||
(let ()
|
(unless (eq? 'chez-scheme (system-type 'vm))
|
||||||
(define (check-empty-allocation hash-sym)
|
(define (check-empty-allocation hash-sym)
|
||||||
(test-comp `(lambda () (,hash-sym) 5)
|
(test-comp `(lambda () (,hash-sym) 5)
|
||||||
'(lambda () 5))
|
'(lambda () 5))
|
||||||
|
|
@ -3664,16 +3692,18 @@
|
||||||
(define (check-discard-iterate op-name)
|
(define (check-discard-iterate op-name)
|
||||||
(test-comp `(lambda (ht i) (,op-name ht i) 5)
|
(test-comp `(lambda (ht i) (,op-name ht i) 5)
|
||||||
`(lambda (ht i) 5)))
|
`(lambda (ht i) 5)))
|
||||||
(check-discard-iterate 'unsafe-immutable-hash-iterate-next)
|
(unless (eq? 'chez-scheme (system-type 'vm))
|
||||||
(check-discard-iterate 'unsafe-immutable-hash-iterate-key)
|
(check-discard-iterate 'unsafe-immutable-hash-iterate-next)
|
||||||
(check-discard-iterate 'unsafe-immutable-hash-iterate-value)
|
(check-discard-iterate 'unsafe-immutable-hash-iterate-key)
|
||||||
(check-discard-iterate 'unsafe-immutable-hash-iterate-key+value)
|
(check-discard-iterate 'unsafe-immutable-hash-iterate-value)
|
||||||
(check-discard-iterate 'unsafe-immutable-hash-iterate-pair))
|
(check-discard-iterate 'unsafe-immutable-hash-iterate-key+value)
|
||||||
|
(check-discard-iterate 'unsafe-immutable-hash-iterate-pair)))
|
||||||
|
|
||||||
;; Check elimination of ignored structure predicate
|
;; Check elimination of ignored structure predicate
|
||||||
;; and constructor applications:
|
;; 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!)
|
(define-values (struct:a a a? a-ref a-set!)
|
||||||
(make-struct-type 'a #f 2 0))
|
(make-struct-type 'a #f 2 0))
|
||||||
(begin0
|
(begin0
|
||||||
|
|
@ -3694,7 +3724,7 @@
|
||||||
(test-comp '(module m racket/base
|
(test-comp '(module m racket/base
|
||||||
(define-values (struct:a a a? a-x a-y)
|
(define-values (struct:a a a? a-x a-y)
|
||||||
(let-values ([(struct:a a a? a-ref a-set!)
|
(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?
|
(values struct:a a a?
|
||||||
(make-struct-field-accessor a-ref 0)
|
(make-struct-field-accessor a-ref 0)
|
||||||
(make-struct-field-accessor a-ref 1))))
|
(make-struct-field-accessor a-ref 1))))
|
||||||
|
|
@ -3709,7 +3739,7 @@
|
||||||
'(module m racket/base
|
'(module m racket/base
|
||||||
(define-values (struct:a a a? a-x a-y)
|
(define-values (struct:a a a? a-x a-y)
|
||||||
(let-values ([(struct:a a a? a-ref a-set!)
|
(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?
|
(values struct:a a a?
|
||||||
(make-struct-field-accessor a-ref 0)
|
(make-struct-field-accessor a-ref 0)
|
||||||
(make-struct-field-accessor a-ref 1))))
|
(make-struct-field-accessor a-ref 1))))
|
||||||
|
|
@ -3816,16 +3846,18 @@
|
||||||
(a? (a-x (a 1 2)))
|
(a? (a-x (a 1 2)))
|
||||||
5)))
|
5)))
|
||||||
|
|
||||||
(module struct-a-for-optimize racket/base
|
(register-top-level-module
|
||||||
(provide (struct-out a)
|
(module struct-a-for-optimize racket/base
|
||||||
(struct-out b))
|
(provide (struct-out a)
|
||||||
(struct a (x y))
|
(struct-out b))
|
||||||
(struct b a (z)))
|
(struct a (x y))
|
||||||
|
(struct b a (z))))
|
||||||
|
|
||||||
(module struct-c-for-optimize racket/base
|
(register-top-level-module
|
||||||
(require 'struct-a-for-optimize)
|
(module struct-c-for-optimize racket/base
|
||||||
(provide (struct-out c))
|
(require 'struct-a-for-optimize)
|
||||||
(struct c a (q)))
|
(provide (struct-out c))
|
||||||
|
(struct c a (q))))
|
||||||
|
|
||||||
(test-comp '(module m racket/base
|
(test-comp '(module m racket/base
|
||||||
(require 'struct-a-for-optimize)
|
(require 'struct-a-for-optimize)
|
||||||
|
|
@ -3864,7 +3896,8 @@
|
||||||
(list (c? (c-q (c 1 2 3))))
|
(list (c? (c-q (c 1 2 3))))
|
||||||
5)))
|
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)
|
(require racket/unsafe/ops)
|
||||||
(struct a (x y))
|
(struct a (x y))
|
||||||
(define (f v)
|
(define (f v)
|
||||||
|
|
@ -3896,7 +3929,8 @@
|
||||||
(unsafe-struct*-ref v 1))
|
(unsafe-struct*-ref v 1))
|
||||||
(void)))))
|
(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)
|
(require racket/unsafe/ops)
|
||||||
(struct a (x y))
|
(struct a (x y))
|
||||||
(define (f v)
|
(define (f v)
|
||||||
|
|
@ -3909,6 +3943,18 @@
|
||||||
(unsafe-struct-ref v 1)))))
|
(unsafe-struct-ref v 1)))))
|
||||||
|
|
||||||
(test-comp '(module m racket/base
|
(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)
|
(require racket/unsafe/ops)
|
||||||
(struct a (x y))
|
(struct a (x y))
|
||||||
(define (f v)
|
(define (f v)
|
||||||
|
|
|
||||||
|
|
@ -30297,9 +30297,16 @@
|
||||||
'if
|
'if
|
||||||
app_0
|
app_0
|
||||||
app_1
|
app_1
|
||||||
(list
|
(let ((a_0
|
||||||
s-rator_0
|
(list
|
||||||
tmp_0)))))))
|
s-rator_0
|
||||||
|
tmp_0)))
|
||||||
|
(if (known-field-accessor-authentic?
|
||||||
|
k_0)
|
||||||
|
(cons
|
||||||
|
'|#%app/no-return|
|
||||||
|
a_0)
|
||||||
|
a_0))))))))
|
||||||
(wrap-tmp_0
|
(wrap-tmp_0
|
||||||
tmp_0
|
tmp_0
|
||||||
(car
|
(car
|
||||||
|
|
@ -30372,10 +30379,17 @@
|
||||||
'if
|
'if
|
||||||
app_0
|
app_0
|
||||||
app_1
|
app_1
|
||||||
(list
|
(let ((a_0
|
||||||
s-rator_0
|
(list
|
||||||
tmp_0
|
s-rator_0
|
||||||
tmp-rhs_0)))))))
|
tmp_0
|
||||||
|
tmp-rhs_0)))
|
||||||
|
(if (known-field-mutator-authentic?
|
||||||
|
k_0)
|
||||||
|
(cons
|
||||||
|
'|#%app/no-return|
|
||||||
|
a_0)
|
||||||
|
a_0))))))))
|
||||||
(let ((app_0
|
(let ((app_0
|
||||||
(car
|
(car
|
||||||
args_0)))
|
args_0)))
|
||||||
|
|
|
||||||
|
|
@ -909,7 +909,10 @@
|
||||||
`(unsafe-struct*-ref ,tmp ,(known-field-accessor-pos k))
|
`(unsafe-struct*-ref ,tmp ,(known-field-accessor-pos k))
|
||||||
`(if (unsafe-struct? ,tmp ,(schemify type-id 'fresh))
|
`(if (unsafe-struct? ,tmp ,(schemify type-id 'fresh))
|
||||||
(unsafe-struct*-ref ,tmp ,(known-field-accessor-pos k))
|
(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)
|
(wrap-tmp tmp (car args)
|
||||||
sel)]
|
sel)]
|
||||||
[else #f]))
|
[else #f]))
|
||||||
|
|
@ -927,7 +930,10 @@
|
||||||
`(unsafe-struct*-set! ,tmp ,(known-field-mutator-pos k) ,tmp-rhs)
|
`(unsafe-struct*-set! ,tmp ,(known-field-mutator-pos k) ,tmp-rhs)
|
||||||
`(if (unsafe-struct? ,tmp ,(schemify type-id 'fresh))
|
`(if (unsafe-struct? ,tmp ,(schemify type-id 'fresh))
|
||||||
(unsafe-struct*-set! ,tmp ,(known-field-mutator-pos k) ,tmp-rhs)
|
(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 (car args)
|
||||||
(wrap-tmp tmp-rhs (cadr args)
|
(wrap-tmp tmp-rhs (cadr args)
|
||||||
mut))]
|
mut))]
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user