From 22b48e03c84305068c76881c8b0ab0d25d9273de Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 16 Apr 2014 11:25:47 -0600 Subject: [PATCH] make assignment-before-initialization an error Recent changes made use-before-initialization an error for `letrec` bindings, `class` fields, and `unit` definitions. Now, assignment-before-initialization is also an error. --- .../reference/unsafe-undefined.scrbl | 34 ++++++++--- .../racket-test/tests/racket/object.rktl | 17 ++++-- .../racket-test/tests/racket/syntax.rktl | 3 + .../typed-racket/base-env/base-env.rkt | 1 + .../racket/private/class-internal.rkt | 26 +++++++-- .../collects/racket/private/class-undef.rkt | 43 ++++++++------ racket/collects/racket/private/classidmap.rkt | 17 +++++- racket/collects/racket/unsafe/ops.rkt | 1 + racket/collects/racket/unsafe/undefined.rkt | 1 + racket/src/racket/src/cstartup.inc | 58 +++++++++---------- racket/src/racket/src/fun.c | 25 +++++++- racket/src/racket/src/jit.h | 2 +- racket/src/racket/src/jit_ts.c | 2 + racket/src/racket/src/jitcommon.c | 49 ++++++++++------ racket/src/racket/src/jitinline.c | 14 +++-- racket/src/racket/src/letrec_check.c | 31 +++++++++- racket/src/racket/src/schminc.h | 2 +- racket/src/racket/src/schpriv.h | 2 + racket/src/racket/src/schvers.h | 4 +- racket/src/racket/src/struct.c | 54 ++++++++++++----- 20 files changed, 273 insertions(+), 113 deletions(-) diff --git a/pkgs/racket-pkgs/racket-doc/scribblings/reference/unsafe-undefined.scrbl b/pkgs/racket-pkgs/racket-doc/scribblings/reference/unsafe-undefined.scrbl index 81e4e19028..a2ff551b4f 100644 --- a/pkgs/racket-pkgs/racket-doc/scribblings/reference/unsafe-undefined.scrbl +++ b/pkgs/racket-pkgs/racket-doc/scribblings/reference/unsafe-undefined.scrbl @@ -18,7 +18,7 @@ raised instead of producing an @racket[undefined] value. The @racket[unsafe-undefined] value is always @racket[eq?] to itself. -@history[#:added "6.0.0.6"] +@history[#:added "6.0.1.2"] @defthing[unsafe-undefined any/c]{ @@ -30,15 +30,27 @@ The unsafe ``undefined'' constant.} Checks whether @racket[v] is @racket[unsafe-undefined], and raises @racket[exn:fail:contract:variable] in that case with an error message -along the lines of ``@racket[sym]: variable used before its -definition.'' If @racket[v] is not @racket[unsafe-undefined], then -@racket[v] is returned.} +along the lines of ``@racket[sym]: undefined; use before +initialization.'' If @racket[v] is not @racket[unsafe-undefined], +then @racket[v] is returned.} + +@defproc[(check-not-unsafe-undefined/assign [v any/c] [sym symbol?]) + (and/c any/c (not/c (one-of/c unsafe-undefined)))]{ + +The same as @racket[check-not-unsafe-undefined], except that the error +message (if any) is along the lines of ``@racket[sym]: undefined; +assignment before initialization.''} + @defthing[prop:chaperone-unsafe-undefined struct-type-property?]{ A @tech{structure type property} that causes a structure type's -constructor to produce a @tech{chaperone} of an instance where every -access of a field in the structure is checked to prevent returning +constructor to produce a @tech{chaperone} of an instance. Every access + +of a field in the structure is checked to prevent returning +@racket[unsafe-undefined]. Similarly, every assignment to a field in +the structure is checked (unless the check disabled as described +below) to prevent assignment of a field whose current value is @racket[unsafe-undefined]. The property value should be a list of symbols used as field names, @@ -46,4 +58,12 @@ but the list should be in reverse order of the structure's fields. When a field access would otherwise produce @racket[unsafe-undefined], the @racket[exn:fail:contract:variable] exception is raised if a field name is provided by the structure property's value, otherwise the -@racket[exn:fail:contract] exception is raised.} +@racket[exn:fail:contract] exception is raised. + +The chaperone's field-assignment check is disabled whenever +@racket[(continuation-mark-set-first #f +prop:chaperone-unsafe-undefined)] returns @racket[unsafe-undefined]. +Thus, a field-initializing assignment---one that is intended to replace the +@racket[unsafe-undefined] value of a field---should be wrapped with +@racket[(with-continuation-mark prop:chaperone-unsafe-undefined +unsafe-undefined ....)].} diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/object.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/object.rktl index db0e81f2dc..b3f65ed02f 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/object.rktl +++ b/pkgs/racket-pkgs/racket-test/tests/racket/object.rktl @@ -1937,6 +1937,11 @@ (define z z) (super-new))) + (define d!% + (class c% + (define z (set! z 0)) + (super-new))) + (define e% (class d% (define q 1) @@ -1958,6 +1963,9 @@ (err/rt-test (new d%) (lambda (exn) (and (exn:fail:contract:variable? exn) (eq? 'z (exn:fail:contract:variable-id exn))))) + (err/rt-test (new d!%) (lambda (exn) + (and (exn:fail:contract:variable? exn) + (eq? 'z (exn:fail:contract:variable-id exn))))) (err/rt-test (new e%) (lambda (exn) (and (exn:fail:contract:variable? exn) (eq? 'z (exn:fail:contract:variable-id exn))))) @@ -2003,6 +2011,7 @@ (check-opt '(class object% (init-field [x 1]) (super-new)) #t) (check-opt '(class object% (define x (+ 1 2))) #t) (check-opt '(class object% (define x (free-var 1))) #t) + (check-opt '(class object% (set! y 7) (define x 2) (define y 1) (super-new)) #f) (check-opt '(class object% (define x x)) #f) (check-opt '(class object% (field [x x])) #f) @@ -2030,12 +2039,8 @@ (check-opt '(class object% (inherit-field f) (super-new) (displayln f)) #t) (check-opt '(class object% (inherit-field f) (displayln f) (super-new)) #f) (check-opt '(class object% (inherit-field f) (set! f 10) (super-new)) #t) - - ;; Ok to use after explicit assignment that's before the decl: - (check-opt '(class object% (set! y 7) (define x y) (define y 1) (super-new)) #t) - ;; But not in a branch - (check-opt '(class object% (when ? (set! y 7)) (define x y) (define y 1) (super-new)) #f) - + (check-opt '(class object% (inherit-field f) (when ? (super-new)) (displayln f)) #f) + (void)) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/syntax.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/syntax.rktl index 8b7b1d6558..463ece2111 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/syntax.rktl +++ b/pkgs/racket-pkgs/racket-test/tests/racket/syntax.rktl @@ -89,6 +89,7 @@ (test 10 add4 6) (err/rt-test (let ([x (lambda () (define d d) d)]) (x)) exn:fail:contract:variable?) (err/rt-test ((lambda () (define d d) d)) exn:fail:contract:variable?) +(err/rt-test ((lambda () (define d (set! d #f)) d)) exn:fail:contract:variable?) (test '(3 4 5 6) (lambda x x) 3 4 5 6) (test '(5 6) (lambda (x y . z) z) 3 4 5 6) (test 'second (lambda () (cons 'first 2) 'second)) @@ -645,6 +646,8 @@ (err/rt-test (letrec-values ([(a b c) (values 1 a b)]) (list a b c)) exn:fail:contract:variable?) +(err/rt-test (letrec-values ([(a b c) (values (set! a 0) a b)]) (list a b c)) + exn:fail:contract:variable?) (test '(10 11) 'letrec-values (letrec-values ([(names kps) (letrec ([oloop 10]) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-env.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-env.rkt index 24bedeb771..054227a821 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-env.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-env.rkt @@ -2719,6 +2719,7 @@ ;; Section 17.4 (Unsafe Undefined) [check-not-unsafe-undefined (-poly (a) (-> a -Symbol a))] +[check-not-unsafe-undefined/assign (-poly (a) (-> a -Symbol a))] ;; Section 18.2 (Libraries and Collections) [find-library-collection-paths (->opt [(-lst -Pathlike) (-lst -Pathlike)] (-lst -Path))] diff --git a/racket/collects/racket/private/class-internal.rkt b/racket/collects/racket/private/class-internal.rkt index 00bf874926..6324870b29 100644 --- a/racket/collects/racket/private/class-internal.rkt +++ b/racket/collects/racket/private/class-internal.rkt @@ -1195,9 +1195,20 @@ [(d-v (id ...) expr) (and (identifier? #'d-v) (free-identifier=? #'d-v #'define-values)) - (syntax-track-origin (syntax/loc e (set!-values (id ...) expr)) - e - #'d-v)] + (let* ([ids (syntax->list #'(id ...))] + [assignment + (if (= 1 (length ids)) + ;; Special-case single variable in case the RHS + ;; uses the name: + (syntax/loc e + (set! id ... (field-initialization-value expr))) + ;; General case: + (with-syntax ([(temp ...) (generate-temporaries ids)]) + (syntax/loc e + (let-values ([(temp ...) expr]) + (set! id (field-initialization-value temp)) + ...))))]) + (syntax-track-origin assignment e #'d-v))] [(_init orig idp ...) (and (identifier? (syntax _init)) (ormap (lambda (it) @@ -1217,11 +1228,14 @@ (with-syntax ([defexp (stx-car (stx-cdr norm))]) (syntax (lambda () defexp))))) norms)] - [class-name class-name]) + [class-name class-name] + [wrapper (if (free-identifier=? #'_init #'-init-field) + #'field-initialization-value + #'begin)]) (syntax-track-origin (syntax/loc e (begin - (set! id (extract-arg 'class-name `idpos init-args defval)) + (set! id (wrapper (extract-arg 'class-name `idpos init-args defval))) ...)) e #'_init)))] @@ -1232,7 +1246,7 @@ (map normalize-init/field (syntax->list #'(idp ...)))]) (syntax-track-origin (syntax/loc e (begin - (set! iid expr) + (set! iid (field-initialization-value expr)) ...)) e #'-fld))] diff --git a/racket/collects/racket/private/class-undef.rkt b/racket/collects/racket/private/class-undef.rkt index e34c066d13..ac9060dfd1 100644 --- a/racket/collects/racket/private/class-undef.rkt +++ b/racket/collects/racket/private/class-undef.rkt @@ -4,11 +4,14 @@ syntax/kerncase)) (provide declare-field-use-start - declare-field-assignment + declare-field-initialization declare-field-use declare-inherit-use + declare-field-assignment declare-this-escapes declare-super-new + + field-initialization-value detect-field-unsafe-undefined) @@ -16,12 +19,17 @@ ;; of the form `(begin (_declare-word _id ...) _expr ...)` ;; for each of the following `_declare-word`s: (define-syntax declare-field-use-start #f) ; marks start of initialization -(define-syntax declare-field-assignment #f) +(define-syntax declare-field-initialization #f) (define-syntax declare-field-use #f) (define-syntax declare-inherit-use #f) +(define-syntax declare-field-assignment #f) (define-syntax declare-this-escapes #f) (define-syntax declare-super-new #f) +;; A wrapper around the RHS of an initlization assignment, +;; recognized by field identifier macros: +(define-syntax field-initialization-value #f) + ;; A wrapper macro that runs the `need-undeed-check?` analysis ;; and adds a boolean argument to a call to `compose-class`: (define-syntax (detect-field-unsafe-undefined stx) @@ -67,23 +75,11 @@ (cloop #`(begin . body) (make-module-identifier-mapping) #f)] [(begin '(decl id ...) . body) (and (identifier? #'decl) - (free-identifier=? #'decl #'declare-field-use)) - ;; A field is used. If tracking has started, make sure the - ;; field is definitely initalized: - (or (and ready - (ormap (lambda (id) - (not (module-identifier-mapping-get ready id (lambda () #f)))) - (syntax->list #'(id ...))) - (report #'body) - #t) - (loop #'(begin . body)))] - [(begin '(decl id ...) . body) - (and (identifier? #'decl) - (free-identifier=? #'decl #'declare-field-assignment)) - ;; A field is assigned. If this is after an action that + (free-identifier=? #'decl #'declare-field-initialization)) + ;; A field is initialized. If this is after an action that ;; might read a field externally, it's too late. Otherwise, ;; assuming that we're not in a branch, the field is after here - ;; assigned (but not before the right-hand side is evaluated): + ;; initialized (but not before the right-hand side is evaluated): (let ([ids (syntax->list #'(id ...))]) (or (and ready init-too-late? @@ -100,6 +96,19 @@ (for-each (lambda (id) (module-identifier-mapping-put! ready id #t)) ids))))))] + [(begin '(decl id ...) . body) + (and (identifier? #'decl) + (or (free-identifier=? #'decl #'declare-field-use) + (free-identifier=? #'decl #'declare-field-assignment))) + ;; A field is used or assigned. If tracking has started, make sure the + ;; field is definitely initalized: + (or (and ready + (ormap (lambda (id) + (not (module-identifier-mapping-get ready id (lambda () #f)))) + (syntax->list #'(id ...))) + (report #'body) + #t) + (loop #'(begin . body)))] [(begin '(decl id ...) . body) (and (identifier? #'decl) (free-identifier=? #'decl #'declare-inherit-use)) diff --git a/racket/collects/racket/private/classidmap.rkt b/racket/collects/racket/private/classidmap.rkt index 87b48db320..1e07205170 100644 --- a/racket/collects/racket/private/classidmap.rkt +++ b/racket/collects/racket/private/classidmap.rkt @@ -48,6 +48,8 @@ (if inherited? stx (quasisyntax/loc src-stx (begin '(declare-field-assignment #,id) #,stx)))) +(define (add-declare-field-initialization id src-stx stx) + (quasisyntax/loc src-stx (begin '(declare-field-initialization #,id) #,stx))) (define (make-this-map orig-id the-finder the-obj) (let ([set!-stx (datum->syntax the-finder 'set!)]) @@ -90,7 +92,20 @@ (lambda (stx) (class-syntax-protect (with-syntax ([obj-expr (find the-finder the-obj stx)]) - (syntax-case stx () + (syntax-case stx (field-initialization-value) + [(set! id (field-initialization-value expr)) + (free-identifier=? (syntax set!) set!-stx) + (add-declare-field-initialization + #'id + #'id + (with-syntax ([bindings (syntax/loc stx ([obj obj-expr] [id expr]))] + [set (quasisyntax/loc stx + ;; This continuation mark disables the chaperone on field assignement + ;; (if any) installed via `prop:chaperone-unsafe-undefined`: + (with-continuation-mark prop:chaperone-unsafe-undefined unsafe-undefined + #,(quasisyntax/loc stx + ((unsyntax field-mutator) obj id))))]) + (syntax/loc (choose-src stx #'id) (let* bindings set))))] [(set! id expr) (free-identifier=? (syntax set!) set!-stx) (add-declare-field-assignment diff --git a/racket/collects/racket/unsafe/ops.rkt b/racket/collects/racket/unsafe/ops.rkt index c4ed47627b..68a6109c86 100644 --- a/racket/collects/racket/unsafe/ops.rkt +++ b/racket/collects/racket/unsafe/ops.rkt @@ -6,6 +6,7 @@ (provide (except-out (all-from-out '#%unsafe) unsafe-undefined check-not-unsafe-undefined + check-not-unsafe-undefined/assign prop:chaperone-unsafe-undefined) (prefix-out unsafe- (combine-out flsin flcos fltan diff --git a/racket/collects/racket/unsafe/undefined.rkt b/racket/collects/racket/unsafe/undefined.rkt index 7ea9fe11ed..3566c36adf 100644 --- a/racket/collects/racket/unsafe/undefined.rkt +++ b/racket/collects/racket/unsafe/undefined.rkt @@ -2,5 +2,6 @@ (require '#%unsafe) (provide check-not-unsafe-undefined + check-not-unsafe-undefined/assign unsafe-undefined prop:chaperone-unsafe-undefined) diff --git a/racket/src/racket/src/cstartup.inc b/racket/src/racket/src/cstartup.inc index 211e2f395b..d4d8ea7f39 100644 --- a/racket/src/racket/src/cstartup.inc +++ b/racket/src/racket/src/cstartup.inc @@ -1,15 +1,15 @@ { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,48,46,49,46,51,84,0,0,0,0,0,0,0,0,0,0, + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,48,46,49,46,52,84,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,51,0,0,0,1,0,0,10,0,14,0, -21,0,28,0,33,0,37,0,40,0,45,0,58,0,62,0,67,0,74,0,83, +27,0,31,0,38,0,42,0,49,0,54,0,61,0,66,0,69,0,74,0,83, 0,87,0,93,0,107,0,121,0,124,0,130,0,134,0,136,0,147,0,149,0, 163,0,170,0,192,0,194,0,208,0,19,1,48,1,59,1,70,1,96,1,129, 1,162,1,224,1,24,2,105,2,161,2,166,2,187,2,84,3,105,3,158,3, 225,3,114,4,2,5,56,5,67,5,150,5,0,0,115,7,0,0,69,35,37, -109,105,110,45,115,116,120,29,11,11,11,66,100,101,102,105,110,101,66,108,101, -116,114,101,99,64,108,101,116,42,63,97,110,100,62,111,114,64,119,104,101,110, -72,112,97,114,97,109,101,116,101,114,105,122,101,63,108,101,116,64,99,111,110, -100,66,117,110,108,101,115,115,68,104,101,114,101,45,115,116,120,29,11,11,11, +109,105,110,45,115,116,120,29,11,11,11,72,112,97,114,97,109,101,116,101,114, +105,122,101,63,97,110,100,66,100,101,102,105,110,101,63,108,101,116,66,117,110, +108,101,115,115,64,99,111,110,100,66,108,101,116,114,101,99,64,108,101,116,42, +62,111,114,64,119,104,101,110,68,104,101,114,101,45,115,116,120,29,11,11,11, 65,113,117,111,116,101,29,94,2,15,68,35,37,107,101,114,110,101,108,11,29, 94,2,15,68,35,37,112,97,114,97,109,122,11,62,105,102,65,98,101,103,105, 110,63,115,116,120,61,115,70,108,101,116,45,118,97,108,117,101,115,61,120,73, @@ -17,10 +17,10 @@ 20,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,110,45,107,101,121, 61,118,73,100,101,102,105,110,101,45,118,97,108,117,101,115,97,36,11,8,240, 18,88,0,0,95,144,2,17,36,36,144,2,16,36,36,144,2,16,36,36,16, -20,2,3,2,2,2,4,2,2,2,5,2,2,2,6,2,2,2,7,2,2, -2,8,2,2,2,11,2,2,2,10,2,2,2,9,2,2,2,12,2,2,97, +20,2,8,2,2,2,4,2,2,2,5,2,2,2,6,2,2,2,7,2,2, +2,10,2,2,2,3,2,2,2,9,2,2,2,11,2,2,2,12,2,2,97, 37,11,8,240,18,88,0,0,93,144,2,16,36,37,16,2,2,13,146,2,2, -37,2,13,2,2,2,13,96,38,11,8,240,18,88,0,0,16,0,96,11,11, +37,2,13,2,2,2,13,96,11,11,8,240,18,88,0,0,16,0,96,38,11, 8,240,18,88,0,0,16,0,18,98,64,104,101,114,101,13,16,6,36,2,14, 2,2,11,11,11,8,32,8,31,8,30,8,29,27,248,22,164,4,195,249,22, 157,4,80,143,39,36,251,22,90,2,18,248,22,102,199,12,249,22,80,2,19, @@ -28,13 +28,13 @@ 2,18,248,22,102,199,249,22,80,2,19,248,22,104,201,12,27,248,22,82,248, 22,164,4,196,28,248,22,88,193,20,14,144,37,36,37,28,248,22,88,248,22, 82,194,248,22,144,18,193,249,22,157,4,80,143,39,36,251,22,90,2,18,248, -22,144,18,199,249,22,80,2,6,248,22,145,18,201,11,18,100,10,13,16,6, +22,144,18,199,249,22,80,2,4,248,22,145,18,201,11,18,100,10,13,16,6, 36,2,14,2,2,11,11,11,8,32,8,31,8,30,8,29,16,4,11,11,2, 20,3,1,8,101,110,118,49,55,54,55,55,16,4,11,11,2,21,3,1,8, 101,110,118,49,55,54,55,56,27,248,22,82,248,22,164,4,196,28,248,22,88, 193,20,14,144,37,36,37,28,248,22,88,248,22,82,194,248,22,144,18,193,249, 22,157,4,80,143,39,36,250,22,90,2,22,248,22,90,249,22,90,248,22,90, -2,23,248,22,144,18,201,251,22,90,2,18,2,23,2,23,249,22,80,2,7, +2,23,248,22,144,18,201,251,22,90,2,18,2,23,2,23,249,22,80,2,11, 248,22,145,18,204,18,100,11,13,16,6,36,2,14,2,2,11,11,11,8,32, 8,31,8,30,8,29,16,4,11,11,2,20,3,1,8,101,110,118,49,55,54, 56,48,16,4,11,11,2,21,3,1,8,101,110,118,49,55,54,56,49,248,22, @@ -52,7 +52,7 @@ 37,47,11,9,222,33,43,248,22,164,4,248,22,81,201,248,22,145,18,198,27, 248,22,82,248,22,164,4,196,27,248,22,164,4,248,22,81,195,249,22,157,4, 80,143,40,36,28,248,22,88,195,250,22,91,2,22,9,248,22,82,199,250,22, -90,2,10,248,22,90,248,22,81,199,250,22,91,2,5,248,22,145,18,201,248, +90,2,6,248,22,90,248,22,81,199,250,22,91,2,10,248,22,145,18,201,248, 22,82,202,27,248,22,82,248,22,164,4,23,197,1,27,249,22,1,22,94,249, 22,2,22,164,4,248,22,164,4,248,22,81,199,248,22,185,4,249,22,157,4, 80,143,41,36,251,22,90,1,22,119,105,116,104,45,99,111,110,116,105,110,117, @@ -63,10 +63,10 @@ 204,27,248,22,82,248,22,164,4,196,28,248,22,88,193,20,14,144,37,36,37, 249,22,157,4,80,143,39,36,27,248,22,164,4,248,22,81,197,28,249,22,167, 9,62,61,62,248,22,158,4,248,22,102,196,250,22,90,2,22,248,22,90,249, -22,90,21,93,2,27,248,22,81,199,250,22,91,2,11,249,22,90,2,27,249, +22,90,21,93,2,27,248,22,81,199,250,22,91,2,8,249,22,90,2,27,249, 22,90,248,22,111,203,2,27,248,22,82,202,251,22,90,2,18,28,249,22,167, 9,248,22,158,4,248,22,81,200,64,101,108,115,101,10,248,22,144,18,197,250, -22,91,2,22,9,248,22,145,18,200,249,22,80,2,11,248,22,82,202,99,13, +22,91,2,22,9,248,22,145,18,200,249,22,80,2,8,248,22,82,202,99,13, 16,6,36,2,14,2,2,11,11,11,8,32,8,31,8,30,8,29,16,4,11, 11,2,20,3,1,8,101,110,118,49,55,55,48,51,16,4,11,11,2,21,3, 1,8,101,110,118,49,55,55,48,52,18,143,94,10,64,118,111,105,100,8,48, @@ -82,25 +82,25 @@ 2,11,2,12,36,46,37,16,0,36,16,1,2,13,37,11,11,11,16,0,16, 0,16,0,36,36,11,12,11,11,16,0,16,0,16,0,36,36,16,11,16,5, 11,20,15,16,2,20,14,144,36,36,37,80,143,36,36,36,20,114,144,36,16, -1,2,13,16,1,33,33,10,16,5,2,12,88,148,8,36,37,53,37,9,223, -0,33,34,36,20,114,144,36,16,1,2,13,16,0,11,16,5,2,8,88,148, +1,2,13,16,1,33,33,10,16,5,2,7,88,148,8,36,37,53,37,9,223, +0,33,34,36,20,114,144,36,16,1,2,13,16,0,11,16,5,2,12,88,148, 8,36,37,53,37,9,223,0,33,35,36,20,114,144,36,16,1,2,13,16,0, -11,16,5,2,6,88,148,8,36,37,53,37,9,223,0,33,36,36,20,114,144, -36,16,1,2,13,16,1,33,37,11,16,5,2,7,88,148,8,36,37,56,37, +11,16,5,2,4,88,148,8,36,37,53,37,9,223,0,33,36,36,20,114,144, +36,16,1,2,13,16,1,33,37,11,16,5,2,11,88,148,8,36,37,56,37, 9,223,0,33,38,36,20,114,144,36,16,1,2,13,16,1,33,39,11,16,5, -2,10,88,148,8,36,37,58,37,9,223,0,33,42,36,20,114,144,36,16,1, -2,13,16,0,11,16,5,2,4,88,148,8,36,37,53,37,9,223,0,33,44, -36,20,114,144,36,16,1,2,13,16,0,11,16,5,2,5,88,148,8,36,37, +2,6,88,148,8,36,37,58,37,9,223,0,33,42,36,20,114,144,36,16,1, +2,13,16,0,11,16,5,2,9,88,148,8,36,37,53,37,9,223,0,33,44, +36,20,114,144,36,16,1,2,13,16,0,11,16,5,2,10,88,148,8,36,37, 54,37,9,223,0,33,45,36,20,114,144,36,16,1,2,13,16,0,11,16,5, -2,9,88,148,8,36,37,56,37,9,223,0,33,46,36,20,114,144,36,16,1, -2,13,16,0,11,16,5,2,11,88,148,8,36,37,58,37,9,223,0,33,47, -36,20,114,144,36,16,1,2,13,16,1,33,49,11,16,5,2,3,88,148,8, +2,3,88,148,8,36,37,56,37,9,223,0,33,46,36,20,114,144,36,16,1, +2,13,16,0,11,16,5,2,8,88,148,8,36,37,58,37,9,223,0,33,47, +36,20,114,144,36,16,1,2,13,16,1,33,49,11,16,5,2,5,88,148,8, 36,37,54,37,9,223,0,33,50,36,20,114,144,36,16,1,2,13,16,0,11, 16,0,94,2,16,2,17,93,2,16,9,9,36,9,0}; EVAL_ONE_SIZED_STR((char *)expr, 2051); } { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,48,46,49,46,51,84,0,0,0,0,0,0,0,0,0,0, + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,48,46,49,46,52,84,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,187,0,0,0,1,0,0,8,0,21,0, 26,0,43,0,55,0,77,0,106,0,150,0,156,0,165,0,172,0,187,0,205, 0,217,0,233,0,247,0,13,1,32,1,39,1,73,1,90,1,107,1,130,1, @@ -559,7 +559,7 @@ 22,131,15,10,22,132,15,10,22,135,15,10,22,134,15,11,22,136,15,10,22, 133,15,10,22,137,15,10,22,138,15,10,22,139,15,10,22,140,15,10,22,141, 15,11,22,142,15,10,22,128,15,11,247,23,193,1,250,22,176,11,2,8,2, -52,23,196,1,248,22,8,20,20,94,88,148,36,37,8,43,16,4,8,128,6, +52,23,196,1,248,22,9,20,20,94,88,148,36,37,8,43,16,4,8,128,6, 8,128,104,8,240,0,64,0,0,36,9,224,1,2,33,144,2,23,195,1,0, 7,35,114,120,34,47,43,34,28,248,22,151,7,23,195,2,27,249,22,154,16, 2,146,2,23,197,2,28,23,193,2,28,249,22,128,4,248,22,101,23,196,2, @@ -1017,7 +1017,7 @@ EVAL_ONE_SIZED_STR((char *)expr, 19187); } { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,48,46,49,46,51,84,0,0,0,0,0,0,0,0,0,0, + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,48,46,49,46,52,84,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,14,0,0,0,1,0,0,15,0,40,0, 57,0,75,0,97,0,120,0,140,0,162,0,171,0,180,0,187,0,196,0,203, 0,0,0,231,1,0,0,74,35,37,112,108,97,99,101,45,115,116,114,117,99, @@ -1047,7 +1047,7 @@ EVAL_ONE_SIZED_STR((char *)expr, 557); } { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,48,46,49,46,51,84,0,0,0,0,0,0,0,0,0,0, + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,48,46,49,46,52,84,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,106,0,0,0,1,0,0,7,0,18,0, 45,0,51,0,60,0,67,0,89,0,102,0,128,0,145,0,167,0,175,0,187, 0,202,0,218,0,236,0,0,1,12,1,28,1,51,1,75,1,87,1,118,1, @@ -1529,7 +1529,7 @@ EVAL_ONE_SIZED_STR((char *)expr, 10046); } { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,48,46,49,46,51,84,0,0,0,0,0,0,0,0,0,0, + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,48,46,49,46,52,84,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,11,0,0,0,1,0,0,10,0,16,0, 29,0,44,0,58,0,78,0,90,0,104,0,118,0,170,0,0,0,101,1,0, 0,69,35,37,98,117,105,108,116,105,110,65,113,117,111,116,101,29,94,2,2, diff --git a/racket/src/racket/src/fun.c b/racket/src/racket/src/fun.c index 8764dcf992..3a26e0803c 100644 --- a/racket/src/racket/src/fun.c +++ b/racket/src/racket/src/fun.c @@ -87,6 +87,7 @@ READ_ONLY Scheme_Object *scheme_procedure_p_proc; READ_ONLY Scheme_Object *scheme_procedure_arity_includes_proc; READ_ONLY Scheme_Object *scheme_void_proc; READ_ONLY Scheme_Object *scheme_check_not_undefined_proc; +READ_ONLY Scheme_Object *scheme_check_assign_not_undefined_proc; READ_ONLY Scheme_Object *scheme_apply_proc; READ_ONLY Scheme_Object *scheme_call_with_values_proc; /* the function bound to `call-with-values' */ READ_ONLY Scheme_Object *scheme_reduced_procedure_struct; @@ -678,6 +679,12 @@ scheme_init_unsafe_fun (Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(o) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED); scheme_add_global_constant("check-not-unsafe-undefined", o, env); + REGISTER_SO(scheme_check_assign_not_undefined_proc); + o = scheme_make_prim_w_arity(scheme_check_assign_not_undefined, "check-not-unsafe-undefined/assign", 2, 2); + scheme_check_assign_not_undefined_proc = o; + SCHEME_PRIM_PROC_FLAGS(o) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED); + scheme_add_global_constant("check-not-unsafe-undefined/assign", o, env); + scheme_add_global_constant("unsafe-undefined", scheme_undefined, env); REGISTER_SO(scheme_chaperone_undefined_property); @@ -2552,7 +2559,23 @@ scheme_check_not_undefined (int argc, Scheme_Object *argv[]) if (SAME_OBJ(argv[0], scheme_undefined)) { scheme_raise_exn(MZEXN_FAIL_CONTRACT_VARIABLE, argv[1], - "%S: variable used before its definition", + "%S: undefined;\n cannot use before initialization", + argv[1]); + } + + return argv[0]; +} + +Scheme_Object * +scheme_check_assign_not_undefined (int argc, Scheme_Object *argv[]) +{ + if (!SCHEME_SYMBOLP(argv[1])) + scheme_wrong_contract("check-not-unsafe-undefined/assign", "symbol?", 1, argc, argv); + + if (SAME_OBJ(argv[0], scheme_undefined)) { + scheme_raise_exn(MZEXN_FAIL_CONTRACT_VARIABLE, + argv[1], + "%S: assignment disallowed;\n cannot assign before initialization", argv[1]); } diff --git a/racket/src/racket/src/jit.h b/racket/src/racket/src/jit.h index d996d1b45e..f31f345ae9 100644 --- a/racket/src/racket/src/jit.h +++ b/racket/src/racket/src/jit.h @@ -367,7 +367,7 @@ struct scheme_jit_common_record { # endif #endif void *make_rest_list_code, *make_rest_list_clear_code; - void *call_check_not_defined_code; + void *call_check_not_defined_code, *call_check_assign_not_defined_code; Continuation_Apply_Indirect continuation_apply_indirect_code; #ifdef MZ_USE_LWC diff --git a/racket/src/racket/src/jit_ts.c b/racket/src/racket/src/jit_ts.c index f3262a461c..0037cf88cd 100644 --- a/racket/src/racket/src/jit_ts.c +++ b/racket/src/racket/src/jit_ts.c @@ -107,6 +107,7 @@ define_ts_iS_s(scheme_checked_integer_to_char, FSRC_MARKS) define_ts_iSi_s(scheme_build_list_offset, FSRC_OTHER) # endif define_ts_iS_s(scheme_check_not_undefined, FSRC_MARKS) +define_ts_iS_s(scheme_check_assign_not_undefined, FSRC_MARKS) #endif #ifdef JITCALL_TS_PROCS @@ -240,4 +241,5 @@ define_ts_s_s(scheme_box, FSRC_OTHER) # define ts_scheme_checked_char_to_integer scheme_checked_char_to_integer # define ts_scheme_checked_integer_to_char scheme_checked_integer_to_char # define ts_scheme_check_not_undefined scheme_check_not_undefined +# define ts_scheme_check_assign_not_undefined scheme_check_assign_not_undefined #endif diff --git a/racket/src/racket/src/jitcommon.c b/racket/src/racket/src/jitcommon.c index 8ee590d1b8..8c81f13b46 100644 --- a/racket/src/racket/src/jitcommon.c +++ b/racket/src/racket/src/jitcommon.c @@ -3227,35 +3227,48 @@ static int common11(mz_jit_state *jitter, void *_data) static int common12(mz_jit_state *jitter, void *_data) { - /* call_check_not_defined_code */ + /* call_check_[assign_]not_defined_code */ /* ares are in R0 and R1 */ { GC_CAN_IGNORE jit_insn *refr USED_ONLY_FOR_FUTURES; + void *code; + int i; + + for (i = 0; i < 2; i++) { + code = jit_get_ip(); - sjc.call_check_not_defined_code = jit_get_ip(); + if (!i) + sjc.call_check_not_defined_code = code; + else + sjc.call_check_assign_not_defined_code = code; - mz_prolog(JIT_R2); + mz_prolog(JIT_R2); - jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(2)); - JIT_UPDATE_THREAD_RSPTR(); + jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(2)); + JIT_UPDATE_THREAD_RSPTR(); - jit_stxi_p(WORDS_TO_BYTES(1), JIT_RUNSTACK, JIT_R1); - jit_str_p(JIT_RUNSTACK, JIT_R0); + jit_stxi_p(WORDS_TO_BYTES(1), JIT_RUNSTACK, JIT_R1); + jit_str_p(JIT_RUNSTACK, JIT_R0); - CHECK_LIMIT(); - jit_movi_i(JIT_R0, 2); - mz_prepare(2); - jit_pusharg_p(JIT_RUNSTACK); - jit_pusharg_i(JIT_R0); - mz_finish_prim_lwe(ts_scheme_check_not_undefined, refr); + CHECK_LIMIT(); + jit_movi_i(JIT_R0, 2); + mz_prepare(2); + jit_pusharg_p(JIT_RUNSTACK); + jit_pusharg_i(JIT_R0); + if (!i) { + mz_finish_prim_lwe(ts_scheme_check_not_undefined, refr); + } else { + mz_finish_prim_lwe(ts_scheme_check_assign_not_undefined, refr); + } - jit_addi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(2)); - JIT_UPDATE_THREAD_RSPTR(); + jit_addi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(2)); + JIT_UPDATE_THREAD_RSPTR(); - mz_epilog(JIT_R2); + mz_epilog(JIT_R2); - scheme_jit_register_sub_func(jitter, sjc.call_check_not_defined_code, scheme_false); - CHECK_LIMIT(); + scheme_jit_register_sub_func(jitter, code, scheme_false); + CHECK_LIMIT(); + } } return 1; diff --git a/racket/src/racket/src/jitinline.c b/racket/src/racket/src/jitinline.c index 3320094521..ac92787b74 100644 --- a/racket/src/racket/src/jitinline.c +++ b/racket/src/racket/src/jitinline.c @@ -3527,9 +3527,10 @@ int scheme_generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i jit_movr_p(dest, JIT_R0); return 1; - } else if (IS_NAMED_PRIM(rator, "check-not-unsafe-undefined")) { + } else if (IS_NAMED_PRIM(rator, "check-not-unsafe-undefined") + || IS_NAMED_PRIM(rator, "check-not-unsafe-undefined/assign")) { if (SCHEME_SYMBOLP(app->rand2)) { - GC_CAN_IGNORE jit_insn *ref, *ref2; + GC_CAN_IGNORE jit_insn *ref; LOG_IT(("inlined check-not-unsafe-undefined\n")); @@ -3541,17 +3542,18 @@ int scheme_generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i mz_rs_sync_fail_branch(); __START_TINY_JUMPS__(1); - ref = jit_bmsi_ul(jit_forward(), JIT_R0, 0x1); - ref2 = mz_bnei_t(jit_forward(), JIT_R0, scheme_undefined_type, JIT_R2); + ref = jit_bnei_ul(jit_forward(), JIT_R0, scheme_undefined); __END_TINY_JUMPS__(1); scheme_mz_load_retained(jitter, JIT_R1, app->rand2); - (void)jit_calli(sjc.call_check_not_defined_code); + if (IS_NAMED_PRIM(rator, "check-not-unsafe-undefined")) + (void)jit_calli(sjc.call_check_not_defined_code); + else + (void)jit_calli(sjc.call_check_assign_not_defined_code); /* never returns */ __START_TINY_JUMPS__(1); mz_patch_branch(ref); - mz_patch_branch(ref2); __END_TINY_JUMPS__(1); CHECK_LIMIT(); } else { diff --git a/racket/src/racket/src/letrec_check.c b/racket/src/racket/src/letrec_check.c index 209718b47e..0e9e7aaf55 100644 --- a/racket/src/racket/src/letrec_check.c +++ b/racket/src/racket/src/letrec_check.c @@ -1265,15 +1265,42 @@ static Scheme_Object *letrec_check_set(Scheme_Object *o, Letrec_Check_Frame *fra { Scheme_Set_Bang *sb; Scheme_Object *val; + int position; sb = (Scheme_Set_Bang *)o; val = sb->val; - - val = letrec_check_expr(val, frame, uvars, pvars, pos); sb->val = val; + if (SAME_TYPE(SCHEME_TYPE(sb->var), scheme_local_type)) { + /* We may need to insert a definedness check before the assignment */ + position = SCHEME_LOCAL_POS(sb->var); + if (lookup_var(position, uvars, frame) || + lookup_var(position, pvars, frame)) { + /* Insert the check: */ + Scheme_App3_Rec *app3; + Scheme_Object *name; + Scheme_Sequence *seq; + + name = record_checked((Scheme_Local *)sb->var, frame); + + app3 = MALLOC_ONE_TAGGED(Scheme_App3_Rec); + app3->iso.so.type = scheme_application3_type; + app3->rator = scheme_check_assign_not_undefined_proc; + app3->rand1 = sb->var; + app3->rand2 = name; + + seq = scheme_malloc_sequence(2); + seq->so.type = scheme_sequence_type; + seq->count = 2; + seq->array[0] = (Scheme_Object *)app3; + seq->array[1] = (Scheme_Object *)sb; + + return (Scheme_Object *)seq; + } + } + return o; } diff --git a/racket/src/racket/src/schminc.h b/racket/src/racket/src/schminc.h index c81b3f37f1..5a67f42a18 100644 --- a/racket/src/racket/src/schminc.h +++ b/racket/src/racket/src/schminc.h @@ -15,7 +15,7 @@ #define USE_COMPILED_STARTUP 1 #define EXPECTED_PRIM_COUNT 1116 -#define EXPECTED_UNSAFE_COUNT 104 +#define EXPECTED_UNSAFE_COUNT 105 #define EXPECTED_FLFXNUM_COUNT 69 #define EXPECTED_EXTFL_COUNT 45 #define EXPECTED_FUTURES_COUNT 15 diff --git a/racket/src/racket/src/schpriv.h b/racket/src/racket/src/schpriv.h index 2e5310b3a3..eda8a86ec7 100644 --- a/racket/src/racket/src/schpriv.h +++ b/racket/src/racket/src/schpriv.h @@ -437,6 +437,7 @@ extern Scheme_Object *scheme_procedure_p_proc; extern Scheme_Object *scheme_procedure_arity_includes_proc; extern Scheme_Object *scheme_void_proc; extern Scheme_Object *scheme_check_not_undefined_proc; +extern Scheme_Object *scheme_check_assign_not_undefined_proc; extern Scheme_Object *scheme_pair_p_proc; extern Scheme_Object *scheme_mpair_p_proc; extern Scheme_Object *scheme_unsafe_cons_list_proc; @@ -3993,6 +3994,7 @@ Scheme_Object *scheme_checked_char_to_integer (int argc, Scheme_Object *argv[]); Scheme_Object *scheme_checked_integer_to_char (int argc, Scheme_Object *argv[]); Scheme_Object *scheme_check_not_undefined (int argc, Scheme_Object *argv[]); +Scheme_Object *scheme_check_assign_not_undefined (int argc, Scheme_Object *argv[]); Scheme_Object *scheme_chaperone_vector_copy(Scheme_Object *obj); Scheme_Object *scheme_chaperone_hash_table_copy(Scheme_Object *obj); diff --git a/racket/src/racket/src/schvers.h b/racket/src/racket/src/schvers.h index 6d61210357..6942e6aa37 100644 --- a/racket/src/racket/src/schvers.h +++ b/racket/src/racket/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "6.0.1.3" +#define MZSCHEME_VERSION "6.0.1.4" #define MZSCHEME_VERSION_X 6 #define MZSCHEME_VERSION_Y 0 #define MZSCHEME_VERSION_Z 1 -#define MZSCHEME_VERSION_W 3 +#define MZSCHEME_VERSION_W 4 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) diff --git a/racket/src/racket/src/struct.c b/racket/src/racket/src/struct.c index cd24ec6c85..40e3d7dbd2 100644 --- a/racket/src/racket/src/struct.c +++ b/racket/src/racket/src/struct.c @@ -1993,6 +1993,30 @@ static Scheme_Object *chaperone_struct_ref_overflow(const char *who, Scheme_Obje return scheme_handle_stack_overflow(chaperone_struct_ref_k); } +static void raise_undefined_error(Scheme_Object *val, const char *short_error, const char *mode, int i) +{ + int len; + Scheme_Object *o; + + o = scheme_struct_type_property_ref(scheme_chaperone_undefined_property, val); + len = (o ? scheme_proper_list_length(o) : 0); + if (i < len) { + for (i = len - i; --i; ) { + o = SCHEME_CDR(o); + } + o = SCHEME_CAR(o); + scheme_raise_exn(MZEXN_FAIL_CONTRACT_VARIABLE, + o, + "%S: %s;\n cannot %s field before initialization", + o, short_error, mode); + } else { + scheme_raise_exn(MZEXN_FAIL_CONTRACT, + "%s;\n cannot %s field before initialization", + short_error, mode); + } + +} + static Scheme_Object *chaperone_struct_ref(const char *who, Scheme_Object *o, int i) { while (1) { @@ -2014,22 +2038,7 @@ static Scheme_Object *chaperone_struct_ref(const char *who, Scheme_Object *o, in orig = chaperone_struct_ref(who, o, i); if (SAME_OBJ(orig, scheme_undefined)) { - int len; - o = scheme_struct_type_property_ref(scheme_chaperone_undefined_property, px->val); - len = (o ? scheme_proper_list_length(o) : 0); - if (i < len) { - for (i = len - i; --i; ) { - o = SCHEME_CDR(o); - } - o = SCHEME_CAR(o); - scheme_raise_exn(MZEXN_FAIL_CONTRACT_VARIABLE, - o, - "%S: field used before its initialization", - o); - } else { - scheme_raise_exn(MZEXN_FAIL_CONTRACT, - "field used before its initialization"); - } + raise_undefined_error(px->val, "undefined", "use", i); } return orig; @@ -2118,6 +2127,19 @@ static void chaperone_struct_set(const char *who, Scheme_Object *o, int i, Schem if (!SAME_OBJ(v, a[1]) && !scheme_chaperone_of(v, a[1])) scheme_wrong_chaperoned(who, "value", a[1], v); } + } if (SCHEME_VECTORP(px->redirects) + && !(SCHEME_VEC_SIZE(px->redirects) & 1) + && SAME_OBJ(SCHEME_VEC_ELS(px->redirects)[1], scheme_undefined)) { + /* chaperone on every field: check that current value is not undefined + --- unless check is disabled by a mark (bit it's faster to check + for `undefined` before checking the mark) */ + if (SAME_OBJ(scheme_undefined, ((Scheme_Structure *)px->val)->slots[i])) { + Scheme_Object *m; + + m = scheme_extract_one_cc_mark(NULL, scheme_chaperone_undefined_property); + if (!m || !SAME_OBJ(m, scheme_undefined)) + raise_undefined_error(px->val, "assignment disallowed", "assign", i); + } } } }