From 09c9901f6bb2c0a08b18c4726f9eaa7b1b1397bf Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 7 Nov 2020 10:32:11 -0700 Subject: [PATCH] bc: don't drop operations when impersonators can interpose For example, if the result of `(when (box? x) (unbox x))` is not used, then the `(unbox x)` still must be done, because the box might be an impersonator. In contrast, `(when (box*? x) (unbox* x))` can be dropped, since `unbox*` is an authentic unbox. This change applies to unsafe operations like `unsafe-struct-ref`, too, and applies to struct accessors for non-authentic structure types. Racket CS already preserves operations appropriately. Relevant to #3487 --- .../tests/racket/optimize.rktl | 49 ++++++++++++++++--- racket/src/bc/src/list.c | 2 - racket/src/bc/src/vector.c | 8 +-- 3 files changed, 45 insertions(+), 14 deletions(-) diff --git a/pkgs/racket-test-core/tests/racket/optimize.rktl b/pkgs/racket-test-core/tests/racket/optimize.rktl index f192ffc78b..b6f7f58f0a 100644 --- a/pkgs/racket-test-core/tests/racket/optimize.rktl +++ b/pkgs/racket-test-core/tests/racket/optimize.rktl @@ -3213,13 +3213,10 @@ (displayln (list expr 3 '!)) ) (map check-omit-ok - '((unsafe-vector-ref x y) - (unsafe-vector*-ref x y) - (unsafe-struct-ref x y) + '((unsafe-vector*-ref x y) (unsafe-struct*-ref x y) (unsafe-mcar x) (unsafe-mcdr x) - (unsafe-unbox y) (unsafe-unbox* x) (unsafe-bytes-ref x y) (unsafe-string-ref x y) @@ -3229,12 +3226,15 @@ (unsafe-s16vector-ref x y) (unsafe-u16vector-ref x y))) (map (lambda (x) (check-omit-ok x #f)) - '((unsafe-vector-set! x y z) + '((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) @@ -3680,7 +3680,6 @@ (procedure? a-x) (lambda (x) (values (a-x x))) - (lambda (x) (when (a? x) (void (a-x x)))) (procedure? set-a-x!) (lambda (x) (values (set-a-x! x 5)))) @@ -3697,6 +3696,44 @@ (lambda (x) a #t) (lambda (x) (when (a? x) #t)) + #t + (lambda (x) (a-x x)) + + #t + (lambda (x) (set-a-x! x 5)))) + +(test-comp '(module m racket/base + (struct a (x) #:omit-define-syntaxes #:mutable #:authentic) + + (procedure? a) + (lambda (x) (values (a x))) + (lambda (x) (void (a x))) + + (procedure? a?) + (lambda (x) (values (a? x))) + (lambda (x) (void (a? x))) + (lambda (x) (boolean? (a? x))) + (lambda (x) (when (a? x) (a? x))) + + (procedure? a-x) + (lambda (x) (values (a-x x))) + (lambda (x) (when (a? x) (void (a-x x)))) + + (procedure? set-a-x!) + (lambda (x) (values (set-a-x! x 5)))) + '(module m racket/base + (struct a (x) #:omit-define-syntaxes #:mutable #:authentic) + + #t + (lambda (x) (a x)) + (lambda (x) a (void)) + + #t + (lambda (x) (a? x)) + (lambda (x) a (void)) + (lambda (x) a #t) + (lambda (x) (when (a? x) #t)) + #t (lambda (x) (a-x x)) (lambda (x) (when (a? x) (void))) diff --git a/racket/src/bc/src/list.c b/racket/src/bc/src/list.c index 9839c6c0e1..72e9e7a5cc 100644 --- a/racket/src/bc/src/list.c +++ b/racket/src/bc/src/list.c @@ -916,8 +916,6 @@ scheme_init_unsafe_list (Scheme_Startup_Env *env) REGISTER_SO(scheme_unsafe_unbox_proc); p = scheme_make_immed_prim(unsafe_unbox, "unsafe-unbox", 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_UNSAFE_OMITABLE - | SCHEME_PRIM_IS_OMITABLE | SCHEME_PRIM_AD_HOC_OPT); scheme_addto_prim_instance("unsafe-unbox", p, env); scheme_unsafe_unbox_proc = p; diff --git a/racket/src/bc/src/vector.c b/racket/src/bc/src/vector.c index 17bdb08cf7..5d6be1323c 100644 --- a/racket/src/bc/src/vector.c +++ b/racket/src/bc/src/vector.c @@ -250,9 +250,7 @@ scheme_init_unsafe_vector (Scheme_Startup_Env *env) scheme_unsafe_vector_star_length_proc = p; p = scheme_make_immed_prim(unsafe_vector_ref, "unsafe-vector-ref", 2, 2); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED - | SCHEME_PRIM_IS_UNSAFE_OMITABLE - | SCHEME_PRIM_IS_OMITABLE); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED); scheme_addto_prim_instance("unsafe-vector-ref", p, env); REGISTER_SO(scheme_unsafe_vector_star_ref_proc); @@ -280,9 +278,7 @@ scheme_init_unsafe_vector (Scheme_Startup_Env *env) REGISTER_SO(scheme_unsafe_struct_ref_proc); p = scheme_make_immed_prim(unsafe_struct_ref, "unsafe-struct-ref", 2, 2); scheme_unsafe_struct_ref_proc = p; - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED - | SCHEME_PRIM_IS_UNSAFE_OMITABLE - | SCHEME_PRIM_IS_OMITABLE); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED); scheme_addto_prim_instance("unsafe-struct-ref", p, env); REGISTER_SO(scheme_unsafe_struct_ref_proc);