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

cs & schemify: fix set!-vs.-define tracking

Browse Source
This commit is contained in:
Matthew Flatt 2019-06-29 07:00:39 -06:00
parent 2bff59766d
commit efeb9116d5
8 changed files with 49 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/base/info.rkt
View File

@ -12,7 +12,7 @@
(define collection 'multi) (define collection 'multi)
(define version "7.3.0.9") (define version "7.3.0.10")
(define deps `("racket-lib" (define deps `("racket-lib"
["racket" #:version ,version])) ["racket" #:version ,version]))

20
racket/src/cs/linklet.sls
View File

@ -53,6 +53,7 @@
;; schemify glue: ;; schemify glue:
make-internal-variable make-internal-variable
variable-set! variable-set!
variable-set!/define
variable-set!/check-undefined variable-set!/check-undefined
variable-ref variable-ref
variable-ref/no-check variable-ref/no-check
@ -234,7 +235,8 @@
(define (outer-eval s paths format) (define (outer-eval s paths format)
(if (eq? format 'interpret) (if (eq? format 'interpret)
(interpret-linklet s paths primitives variable-ref variable-ref/no-check variable-set! (interpret-linklet s paths primitives variable-ref variable-ref/no-check
variable-set! variable-set!/define
make-arity-wrapper-procedure) make-arity-wrapper-procedure)
(let ([proc (compile* s)]) (let ([proc (compile* s)])
(if (null? paths) (if (null? paths)
@ -759,7 +761,7 @@
(|#%app| (|#%app|
exn:fail:contract:variable exn:fail:contract:variable
(string-append (symbol->string (variable-source-name var)) (string-append (symbol->string (variable-source-name var))
": cannot modify constant") ": cannot modify a constant")
(current-continuation-marks) (current-continuation-marks)
(variable-name var)))])] (variable-name var)))])]
[else [else
@ -767,13 +769,16 @@
(when constance (when constance
(set-variable-constance! var constance))])) (set-variable-constance! var constance))]))
(define (variable-set! var val constance) (define (variable-set! var val)
(do-variable-set! var val constance #f)) (do-variable-set! var val #f #f))
(define (variable-set!/check-undefined var val constance) (define (variable-set!/define var val constance)
(do-variable-set! var val constance #t))
(define (variable-set!/check-undefined var val)
(when (eq? (variable-val var) variable-undefined) (when (eq? (variable-val var) variable-undefined)
(raise-undefined var #t)) (raise-undefined var #t))
(variable-set! var val constance)) (variable-set! var val))
(define (variable-ref var) (define (variable-ref var)
(let ([v (variable-val var)]) (let ([v (variable-val var)])
@ -976,7 +981,7 @@
(let ([var (make-variable variable-undefined k k #f (weak-cons i #f))]) (let ([var (make-variable variable-undefined k k #f (weak-cons i #f))])
(hash-set! (instance-hash i) k var) (hash-set! (instance-hash i) k var)
var))]) var))])
(variable-set! var v mode))])) (do-variable-set! var v mode #f))]))
(define (instance-unset-variable! i k) (define (instance-unset-variable! i k)
(unless (instance? i) (unless (instance? i)
@ -1138,6 +1143,7 @@
(primitive-table (primitive-table
variable-set! variable-set!
variable-set!/check-undefined variable-set!/check-undefined
variable-set!/define
variable-ref variable-ref
variable-ref/no-check variable-ref/no-check
make-instance-variable-reference make-instance-variable-reference

1
racket/src/expander/compile/built-in-symbol.rkt
View File

@ -62,6 +62,7 @@
variable-ref variable-ref
variable-ref/no-check variable-ref/no-check
variable-set!/check-undefined variable-set!/check-undefined
variable-set!/define
make-instance-variable-reference make-instance-variable-reference
instance-variable-reference instance-variable-reference
annotation? annotation?

2
racket/src/racket/src/schvers.h
View File

@ -16,7 +16,7 @@
#define MZSCHEME_VERSION_X 7 #define MZSCHEME_VERSION_X 7
#define MZSCHEME_VERSION_Y 3 #define MZSCHEME_VERSION_Y 3
#define MZSCHEME_VERSION_Z 0 #define MZSCHEME_VERSION_Z 0
#define MZSCHEME_VERSION_W 9 #define MZSCHEME_VERSION_W 10
/* A level of indirection makes `#` work as needed: */ /* A level of indirection makes `#` work as needed: */
#define AS_a_STR_HELPER(x) #x #define AS_a_STR_HELPER(x) #x

1
racket/src/racket/src/startup.inc
View File

@ -19873,6 +19873,7 @@ static const char *startup_source =
" variable-ref" " variable-ref"
" variable-ref/no-check" " variable-ref/no-check"
" variable-set!/check-undefined" " variable-set!/check-undefined"
" variable-set!/define"
" make-instance-variable-reference" " make-instance-variable-reference"
" instance-variable-reference" " instance-variable-reference"
" annotation?" " annotation?"

33
racket/src/schemify/interpret.rkt
View File

@ -320,13 +320,22 @@
ids ids
constances constances
(compile-list vars env stack-depth stk-i #f))] (compile-list vars env stack-depth stk-i #f))]
[`(variable-set! ,dest-id ,e ',constance) [`(variable-set! ,dest-id ,e)
(define dest-var (hash-ref env (unwrap dest-id))) (define dest-var (hash-ref env (unwrap dest-id)))
(define new-expr (compile-expr e env stack-depth stk-i #f)) (define new-expr (compile-expr e env stack-depth stk-i #f))
(vector 'set-variable! (vector 'set-variable!
(stack->pos dest-var stk-i) (stack->pos dest-var stk-i)
new-expr new-expr
constance)] #f
#f)]
[`(variable-set!/define ,dest-id ,e ',constance)
(define dest-var (hash-ref env (unwrap dest-id)))
(define new-expr (compile-expr e env stack-depth stk-i #f))
(vector 'set-variable!
(stack->pos dest-var stk-i)
new-expr
constance
#t)]
[`(variable-ref ,id) [`(variable-ref ,id)
(define var (hash-ref env (unwrap id))) (define var (hash-ref env (unwrap id)))
(vector 'ref-variable/checked (stack->pos var stk-i))] (vector 'ref-variable/checked (stack->pos var stk-i))]
@ -425,7 +434,7 @@
paths ; unmarshaled paths paths ; unmarshaled paths
primitives ; hash of symbol -> value primitives ; hash of symbol -> value
;; the implementation of variables: ;; the implementation of variables:
variable-ref variable-ref/no-check variable-set! variable-ref variable-ref/no-check variable-set! variable-set!/define
;; to create a procedure with a specific arity mask: ;; to create a procedure with a specific arity mask:
make-arity-wrapper-procedure) make-arity-wrapper-procedure)
(interp-match (interp-match
@ -441,7 +450,7 @@
(vector-set! vec i (car paths)) (vector-set! vec i (car paths))
(cdr paths)] (cdr paths)]
[else [else
(vector-set! vec i (interpret-expr b stack primitives void void void void)) (vector-set! vec i (interpret-expr b stack primitives void void void void void))
paths])) paths]))
vec))]) vec))])
(lambda args (lambda args
@ -454,10 +463,10 @@
(define post-args-pos (stack-count args-stack)) (define post-args-pos (stack-count args-stack))
(define stack (for/fold ([stack args-stack]) ([i (in-range num-body-vars)]) (define stack (for/fold ([stack args-stack]) ([i (in-range num-body-vars)])
(stack-set stack (+ i post-args-pos) (box unsafe-undefined)))) (stack-set stack (+ i post-args-pos) (box unsafe-undefined))))
(interpret-expr b stack primitives variable-ref variable-ref/no-check variable-set! (interpret-expr b stack primitives variable-ref variable-ref/no-check variable-set! variable-set!/define
make-arity-wrapper-procedure)))])) make-arity-wrapper-procedure)))]))
(define (interpret-expr b stack primitives variable-ref variable-ref/no-check variable-set! (define (interpret-expr b stack primitives variable-ref variable-ref/no-check variable-set! variable-set!/define
make-arity-wrapper-procedure) make-arity-wrapper-procedure)
;; Returns `result ...` when `tail?` is #t, and ;; Returns `result ...` when `tail?` is #t, and
@ -711,10 +720,12 @@
(if tail? (if tail?
val val
(values new-stack val))] (values new-stack val))]
[#(set-variable! ,s ,b ,c) [#(set-variable! ,s ,b ,c ,defn?)
(define-values (var-stack var) (stack-ref stack s)) (define-values (var-stack var) (stack-ref stack s))
(define-values (val-stack val) (interpret b var-stack)) (define-values (val-stack val) (interpret b var-stack))
(variable-set! var val c) (if defn?
(variable-set!/define var val c)
(variable-set! var val))
(if tail? (if tail?
(void) (void)
(values val-stack (void)))] (values val-stack (void)))]
@ -826,7 +837,7 @@
(list x y (let ([z 2]) (list x y (let ([z 2])
z))))) z)))))
(define-values (one two) (values 100 200)) (define-values (one two) (values 100 200))
(variable-set! two-box two 'constant) (variable-set!/define two-box two 'constant)
(letrec ([ok 'ok]) (letrec ([ok 'ok])
(set! other (call-with-values (lambda () (values 71 (begin0 88 ok))) (set! other (call-with-values (lambda () (values 71 (begin0 88 ok)))
(lambda (v q) (list q v)))) (lambda (v q) (list q v))))
@ -838,7 +849,7 @@
(continuation-mark-set-first #f 'x 'no)))))) (continuation-mark-set-first #f 'x 'no))))))
values)) values))
(pretty-print b) (pretty-print b)
(define l (interpret-linklet b primitives var-val var-val (lambda (b v c) (define l (interpret-linklet b null primitives var-val var-val
(set-var-val! b v)) (lambda (b v) (set-var-val! b v)) (lambda (b v c) (set-var-val! b v))
(lambda (proc mask name) proc))) (lambda (proc mask name) proc)))
(l 'the-x (var #f))) (l 'the-x (var #f)))

14
racket/src/schemify/jitify.rkt
View File

@ -146,6 +146,8 @@
(match v (match v
[`(variable-set! ,var-id ,id . ,_) [`(variable-set! ,var-id ,id . ,_)
(hash-set env (unwrap id) `(variable-ref ,(unwrap var-id)))] (hash-set env (unwrap id) `(variable-ref ,(unwrap var-id)))]
[`(variable-set!/define ,var-id ,id . ,_)
(hash-set env (unwrap id) `(variable-ref ,(unwrap var-id)))]
[`(call-with-module-prompt ,_ ',ids ,_ ,var-ids ...) [`(call-with-module-prompt ,_ ',ids ,_ ,var-ids ...)
(for/fold ([env env]) ([id (in-list ids)] (for/fold ([env env]) ([id (in-list ids)]
[var-id (in-list var-ids)]) [var-id (in-list var-ids)])
@ -159,7 +161,7 @@
(let loop ([body body]) (let loop ([body body])
(for/list ([v (in-list body)]) (for/list ([v (in-list body)])
(match v (match v
[`(variable-set! ,var-id ,id ',constance) [`(variable-set!/define ,var-id ,id ',constance)
(when constance (when constance
;; From now on, a direct reference is ok ;; From now on, a direct reference is ok
(set! top-env (hash-set top-env (unwrap id) '#:direct))) (set! top-env (hash-set top-env (unwrap id) '#:direct)))
@ -316,7 +318,7 @@
(match (hash-ref env id '#:direct) (match (hash-ref env id '#:direct)
[`#:direct (reannotate v `(set! ,var ,new-rhs))] [`#:direct (reannotate v `(set! ,var ,new-rhs))]
[`(self ,m . ,_) (error 'set! "[internal error] self-referenceable ~s" id)] [`(self ,m . ,_) (error 'set! "[internal error] self-referenceable ~s" id)]
[`(variable-ref ,var-id) (reannotate v `(variable-set! ,var-id ,new-rhs '#f))] [`(variable-ref ,var-id) (reannotate v `(variable-set! ,var-id ,new-rhs))]
[`(unbox ,box-id) (reannotate v `(set-box! ,box-id ,new-rhs))] [`(unbox ,box-id) (reannotate v `(set-box! ,box-id ,new-rhs))]
[`(unbox/check-undefined ,box-id ,_) (reannotate v `(set-box!/check-undefined ,box-id ,new-rhs ',var))])) [`(unbox/check-undefined ,box-id ,_) (reannotate v `(set-box!/check-undefined ,box-id ,new-rhs ',var))]))
(values new-v newer-free new-lifts)])] (values new-v newer-free new-lifts)])]
@ -834,9 +836,9 @@
[selfy (lambda (x) (vector (selfy x) selfy))]) [selfy (lambda (x) (vector (selfy x) selfy))])
(odd 5))) (odd 5)))
(define top-selfx (lambda (x) (top-selfx x))) (define top-selfx (lambda (x) (top-selfx x)))
(variable-set! top-selfx-var top-selfx 'const) (variable-set!/define top-selfx-var top-selfx 'const)
(define top-selfy (lambda (x) (vector (top-selfy x) top-selfy))) (define top-selfy (lambda (x) (vector (top-selfy x) top-selfy)))
(variable-set! top-selfy-var top-selfy 'const) (variable-set!/define top-selfy-var top-selfy 'const)
(call-with-values (lambda (x) (x (lambda (w) (w)))) (call-with-values (lambda (x) (x (lambda (w) (w))))
(lambda (z w) 10)) (lambda (z w) 10))
(call-with-values (lambda (x) (x (lambda (w) (w)))) (call-with-values (lambda (x) (x (lambda (w) (w))))
@ -851,7 +853,7 @@
(define x1 (lambda () (lambda () (other iv)))) (define x1 (lambda () (lambda () (other iv))))
(define x2 (lambda () (letrec ([other (lambda () (other iv))]) (define x2 (lambda () (letrec ([other (lambda () (other iv))])
other))) other)))
(define whatever (begin (variable-set! xv x 'const) (void))) (define whatever (begin (variable-set!/define xv x 'const) (void)))
(define end (letrec ([w (lambda (x) (let ([proc (lambda (x) x)]) (define end (letrec ([w (lambda (x) (let ([proc (lambda (x) x)])
(proc q)))] (proc q)))]
[q q]) [q q])
@ -859,7 +861,7 @@
(define topz (letrec ([helper (lambda (x) (define topz (letrec ([helper (lambda (x)
(helper (topz x)))]) (helper (topz x)))])
(lambda (y) (helper y)))) (lambda (y) (helper y))))
(variable-set! topz-var topz 'const) (variable-set!/define topz-var topz 'const)
(do-immediate topz) (do-immediate topz)
(define sets-arg (lambda (x) (define sets-arg (lambda (x)
(values (lambda () (set! x (add1 x))) (values (lambda () (set! x (add1 x)))

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

@ -347,7 +347,7 @@
(define (make-set-variable id exports knowns mutated [extra-variables #f]) (define (make-set-variable id exports knowns mutated [extra-variables #f])
(define int-id (unwrap id)) (define int-id (unwrap id))
(define ex-id (id-to-variable int-id exports knowns mutated extra-variables)) (define ex-id (id-to-variable int-id exports knowns mutated extra-variables))
`(variable-set! ,ex-id ,id ',(variable-constance int-id knowns mutated))) `(variable-set!/define ,ex-id ,id ',(variable-constance int-id knowns mutated)))
(define (id-to-variable int-id exports knowns mutated extra-variables) (define (id-to-variable int-id exports knowns mutated extra-variables)
(export-id (export-id
@ -550,7 +550,7 @@
(define new-rhs (schemify rhs)) (define new-rhs (schemify rhs))
(cond (cond
[ex [ex
`(,(if allow-set!-undefined? 'variable-set! 'variable-set!/check-undefined) ,(export-id ex) ,new-rhs '#f)] `(,(if allow-set!-undefined? 'variable-set! 'variable-set!/check-undefined) ,(export-id ex) ,new-rhs)]
[else [else
(define state (hash-ref mutated int-id #f)) (define state (hash-ref mutated int-id #f))
(cond (cond