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

cs & schemify: prevent reorder of allocation and continuation capture

Browse Source
This commit is contained in:
Matthew Flatt 2020-12-29 16:14:22 -07:00
parent 95e5acdb0d
commit 4936977c56
20 changed files with 15601 additions and 18032 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/base/info.rkt
View File

@ -14,7 +14,7 @@
;; In the Racket source repo, this version should change only when
;; "racket_version.h" changes:
(define version "7.9.0.18")
(define version "7.9.0.19")
(define deps `("racket-lib"
["racket" #:version ,version]))

19
pkgs/racket-test-core/tests/racket/basic.rktl
View File

@ -2129,6 +2129,25 @@
(escape1 3))))))))
(sync ch))
;; Make sure allocation and continuation capture are left-to-right in
;; a function call:
(let ([join (if (zero? (random 1)) list 'oops)])
(let ([k0 (cadr
(call-with-continuation-prompt
(lambda ()
(join (cons 1 2)
(call/cc (lambda (k) k))))))]
[k1 (car
(call-with-continuation-prompt
(lambda ()
(join (call/cc (lambda (k) k))
(cons 1 2)))))])
(define (do-k k) (call-with-continuation-prompt
(lambda ()
(k k))))
(test #t eq? (car (do-k k0)) (car (do-k k0)))
(test #f eq? (cadr (do-k k1)) (cadr (do-k k1)))))
(arity-test call/cc 1 2)
(arity-test call/ec 1 1)
(err/rt-test (call/cc 4))

33
pkgs/racket-test-core/tests/racket/optimize.rktl
View File

@ -1231,7 +1231,8 @@
;; Ok to move `box' past a side effect (that can't capture a
;; resumable continuation):
(test-comp '(let ([h (box 0.0)])
(test-comp #:except 'chez-scheme
'(let ([h (box 0.0)])
(list (random) h))
'(list (random) (box 0.0)))
@ -1259,7 +1260,8 @@
;; Do copy-propagate a reference to a mutable top-level
;; across non-effects:
(test-comp '(module m racket/base
(test-comp #:except 'chez-scheme
'(module m racket/base
(define x 10)
(define (f y)
(let ([old x])
@ -1319,7 +1321,8 @@
'(let* ([x (cons 1 1)]) (cons x x)))
(test-comp '(let* ([x 1][y (add1 x)]) (+ y x))
'3)
(test-comp '(letrec ([x (cons 1 1)][y x]) (cons x y))
(test-comp #:except 'chez-scheme
'(letrec ([x (cons 1 1)][y x]) (cons x y))
'(letrec ([x (cons 1 1)][y x]) (cons x x)))
;; Remove unnecessary bindings
@ -1426,7 +1429,8 @@
'(values 1 2)
#f)
; car is a primitive, map is required from another module
(test-comp '(lambda (x) (if (null? x) car car))
(test-comp #:except 'chez-scheme
'(lambda (x) (if (null? x) car car))
'(lambda (x) car))
(test-comp '(lambda (x) (if (null? x) map map))
'(lambda (x) map))
@ -1436,11 +1440,14 @@
'(module ? racket/base
(define x (if (zero? (random 2)) '() '(1)))
x))
(test-comp '(lambda (x) (if (null? x) x x))
(test-comp #:except 'chez-scheme
'(lambda (x) (if (null? x) x x))
'(lambda (x) x))
(test-comp '(lambda (x) (if (null? x) null x))
(test-comp #:except 'chez-scheme
'(lambda (x) (if (null? x) null x))
'(lambda (x) x))
(test-comp '(lambda (x) (not (if (null? x) #t x)))
(test-comp #:except 'chez-scheme
'(lambda (x) (not (if (null? x) #t x)))
'(lambda (x) (not x)))
;reduce ignored `if`s
@ -1452,11 +1459,14 @@
'(lambda () (void (random 2))))
(test-comp '(lambda (x) (void (if (eq? (random 2) 0) (box x) (list x))))
'(lambda (x) (void (random 2))))
(test-comp '(lambda (x) (void (if x (random) 1)))
(test-comp #:except 'chez-scheme
'(lambda (x) (void (if x (random) 1)))
'(lambda (x) (void (if x (random) 2))))
(test-comp '(lambda (x) (void (if x 1 (random))))
(test-comp #:except 'chez-scheme
'(lambda (x) (void (if x 1 (random))))
'(lambda (x) (void (if x 2 (random)))))
(test-comp '(lambda (x) (void (if x (random) 1)))
(test-comp #:except 'chez-scheme
'(lambda (x) (void (if x (random) 1)))
'(lambda (x) (void))
#f)
(test-comp '(lambda (x) (void (if x 1 (random))))
@ -1523,7 +1533,8 @@
(test-comp '(lambda (x) (if (pair? x) #t #f))
'(lambda (x) (pair? x)))
(test-comp '(lambda (x) (let ([r (something)])
(test-comp #:except 'chez-scheme
'(lambda (x) (let ([r (something)])
(if r #t (something-else))))
'(lambda (x) (if (something) #t (something-else))))

30
racket/src/cs/primitive/kernel.ss
View File

@ -41,9 +41,9 @@
[bitwise-not (known-procedure/folding 2)]
[bitwise-xor (known-procedure/folding -1)]
[boolean? (known-procedure/pure/folding 2)]
[box (known-procedure/pure 2)]
[box (known-procedure/allocates 2)]
[box-cas! (known-procedure/has-unsafe 8 'unsafe-box*-cas!)]
[box-immutable (known-procedure/pure 2)]
[box-immutable (known-procedure/allocates 2)]
[box? (known-procedure/pure/folding 2)]
[break-enabled (known-procedure/no-prompt 3)]
[break-thread (known-procedure/no-prompt 6)]
@ -185,7 +185,7 @@
[compile-target-machine? (known-procedure/no-prompt 2)]
[complete-path? (known-procedure/no-prompt 2)]
[complex? (known-procedure/pure/folding 2)]
[cons (known-procedure/pure 4)]
[cons (known-procedure/allocates 4)]
[continuation-mark-key? (known-procedure/pure/folding 2)]
[continuation-mark-set->context (known-procedure/no-prompt 2)]
[continuation-mark-set->iterator (known-procedure/no-prompt 28)]
@ -471,8 +471,8 @@
[lcm (known-procedure/folding -1)]
[length (known-procedure/no-prompt 2)]
[link-exists? (known-procedure/no-prompt 2)]
[list (known-procedure/pure -1)]
[list* (known-procedure/pure -2)]
[list (known-procedure/allocates -1)]
[list* (known-procedure/allocates -2)]
[list->bytes (known-procedure/no-prompt 2)]
[list->string (known-procedure/no-prompt 2)]
[list->vector (known-procedure/no-prompt 2)]
@ -493,7 +493,7 @@
[logger? (known-procedure/pure/folding 2)]
[magnitude (known-procedure/folding 2)]
[make-bytes (known-procedure/no-prompt 6)]
[make-channel (known-procedure/pure 1)]
[make-channel (known-procedure/allocates 1)]
[make-continuation-mark-key (known-procedure/no-prompt 3)]
[make-continuation-prompt-tag (known-procedure/no-prompt 3)]
[make-custodian (known-procedure/no-prompt 3)]
@ -501,7 +501,7 @@
[make-derived-parameter (known-procedure/single-valued 8)]
[make-directory (known-procedure/no-prompt 2)]
[make-environment-variables (known-procedure/no-prompt -1)]
[make-ephemeron (known-procedure/pure 4)]
[make-ephemeron (known-procedure/allocates 4)]
[make-file-or-directory-link (known-procedure/no-prompt 4)]
[make-hash (known-procedure/single-valued 3)]
[make-hash-placeholder (known-procedure/no-prompt 2)]
@ -522,8 +522,8 @@
[make-parameter (known-procedure/single-valued 14)]
[make-phantom-bytes (known-procedure/no-prompt 2)]
[make-pipe (known-procedure/no-prompt/multi 15)]
[make-placeholder (known-procedure/pure 2)]
[make-plumber (known-procedure/pure 1)]
[make-placeholder (known-procedure/allocates 2)]
[make-plumber (known-procedure/allocates 1)]
[make-polar (known-procedure/folding 4)]
[make-prefab-struct (known-procedure/single-valued -2)]
[make-pseudo-random-generator (known-procedure/no-prompt 1)] ; not pure, depends on (current-milliseconds)
@ -538,19 +538,19 @@
[make-struct-field-mutator (known-procedure/single-valued 12)]
[make-struct-type (known-procedure 4080)]
[make-struct-type-property (known-procedure 30)]
[make-thread-cell (known-procedure/pure 6)]
[make-thread-cell (known-procedure/allocates 6)]
[make-thread-group (known-procedure/no-prompt 3)]
[make-vector (known-procedure/no-prompt 6)]
[make-weak-box (known-procedure/pure 2)]
[make-weak-box (known-procedure/allocates 2)]
[make-weak-hash (known-procedure/single-valued 3)]
[make-weak-hasheq (known-procedure/no-prompt 3)]
[make-weak-hasheqv (known-procedure/no-prompt 3)]
[make-will-executor (known-procedure/pure 1)]
[make-will-executor (known-procedure/allocates 1)]
[map (known-procedure/single-valued -4)]
[max (known-procedure/folding -2)]
[mcar (known-procedure/has-unsafe 2 'unsafe-mcar)]
[mcdr (known-procedure/has-unsafe 2 'unsafe-mcdr)]
[mcons (known-procedure/pure 4)]
[mcons (known-procedure/allocates 4)]
[memory-order-acquire (known-procedure/single-valued 1)]
[memory-order-release (known-procedure/single-valued 1)]
[min (known-procedure/folding -2)]
@ -944,7 +944,7 @@
[unquoted-printing-string-value (known-procedure/single-valued 2)]
[unquoted-printing-string? (known-procedure/no-prompt 2)]
[values (known-procedure/no-prompt/multi -1)] ; not marked as pure, because it is not single valued
[vector (known-procedure/pure -1)]
[vector (known-procedure/allocates -1)]
[vector->immutable-vector (known-procedure/single-valued 2)]
[vector->list (known-procedure/single-valued 2)]
[vector->pseudo-random-generator (known-procedure/single-valued 2)]
@ -953,7 +953,7 @@
[vector-cas! (known-procedure/has-unsafe 16 'unsafe-vector*-cas!)]
[vector-copy! (known-procedure/single-valued 56)]
[vector-fill! (known-procedure/single-valued 4)]
[vector-immutable (known-procedure/pure -1)]
[vector-immutable (known-procedure/allocates -1)]
[vector-length (known-procedure/no-prompt 2)]
[vector-ref (known-procedure/single-valued 4)]
[vector-set! (known-procedure/single-valued 8)]

25333
racket/src/cs/schemified/expander.scm
View File

File diff suppressed because it is too large Load Diff

3765
racket/src/cs/schemified/io.scm
View File

File diff suppressed because it is too large Load Diff

88
racket/src/cs/schemified/known.scm
View File

@ -1034,14 +1034,14 @@
(if (impersonator? v)
(known-procedure/succeeds?_3041 (impersonator-val v))
#f))))))
(define struct:known-procedure/pure
(define struct:known-procedure/allocates
(make-record-type-descriptor*
'known-procedure/pure
'known-procedure/allocates
(if (struct-type? struct:known-procedure/succeeds)
struct:known-procedure/succeeds
(check-struct-type 'struct struct:known-procedure/succeeds))
(structure-type-lookup-prefab-uid
'known-procedure/pure
'known-procedure/allocates
(if (struct-type? struct:known-procedure/succeeds)
struct:known-procedure/succeeds
(check-struct-type 'struct struct:known-procedure/succeeds))
@ -1053,10 +1053,10 @@
#f
0
0))
(define effect_2377
(define effect_2234
(struct-type-install-properties!
struct:known-procedure/pure
'known-procedure/pure
struct:known-procedure/allocates
'known-procedure/allocates
0
0
(if (struct-type? struct:known-procedure/succeeds)
@ -1067,6 +1067,62 @@
#f
'()
#f
'known-procedure/allocates))
(define known-procedure/allocates
(|#%name|
known-procedure/allocates
(record-constructor
(make-record-constructor-descriptor
struct:known-procedure/allocates
#f
#f))))
(define known-procedure/allocates?_2244
(|#%name|
known-procedure/allocates?
(record-predicate struct:known-procedure/allocates)))
(define known-procedure/allocates?
(|#%name|
known-procedure/allocates?
(lambda (v)
(if (known-procedure/allocates?_2244 v)
#t
($value
(if (impersonator? v)
(known-procedure/allocates?_2244 (impersonator-val v))
#f))))))
(define struct:known-procedure/pure
(make-record-type-descriptor*
'known-procedure/pure
(if (struct-type? struct:known-procedure/allocates)
struct:known-procedure/allocates
(check-struct-type 'struct struct:known-procedure/allocates))
(structure-type-lookup-prefab-uid
'known-procedure/pure
(if (struct-type? struct:known-procedure/allocates)
struct:known-procedure/allocates
(check-struct-type 'struct struct:known-procedure/allocates))
0
0
#f
'())
#f
#f
0
0))
(define effect_2568
(struct-type-install-properties!
struct:known-procedure/pure
'known-procedure/pure
0
0
(if (struct-type? struct:known-procedure/allocates)
struct:known-procedure/allocates
(check-struct-type 'struct struct:known-procedure/allocates))
null
'prefab
#f
'()
#f
'known-procedure/pure))
(define known-procedure/pure
(|#%name|
@ -1530,14 +1586,14 @@
(define struct:known-constructor
(make-record-type-descriptor*
'known-constructor
(if (struct-type? struct:known-procedure/pure)
struct:known-procedure/pure
(check-struct-type 'struct struct:known-procedure/pure))
(if (struct-type? struct:known-procedure/allocates)
struct:known-procedure/allocates
(check-struct-type 'struct struct:known-procedure/allocates))
(structure-type-lookup-prefab-uid
'known-constructor
(if (struct-type? struct:known-procedure/pure)
struct:known-procedure/pure
(check-struct-type 'struct struct:known-procedure/pure))
(if (struct-type? struct:known-procedure/allocates)
struct:known-procedure/allocates
(check-struct-type 'struct struct:known-procedure/allocates))
1
0
#f
@ -1546,15 +1602,15 @@
#f
1
1))
(define effect_2019
(define effect_2907
(struct-type-install-properties!
struct:known-constructor
'known-constructor
1
0
(if (struct-type? struct:known-procedure/pure)
struct:known-procedure/pure
(check-struct-type 'struct struct:known-procedure/pure))
(if (struct-type? struct:known-procedure/allocates)
struct:known-procedure/allocates
(check-struct-type 'struct struct:known-procedure/allocates))
null
'prefab
#f

714
racket/src/cs/schemified/regexp.scm
View File

@ -147,18 +147,20 @@
keyword-procedure?
keyword-procedure-ref
keyword-procedure-set!)
(make-struct-type
'keyword-procedure
#f
4
0
#f
(list
(cons prop:checked-procedure #t)
(cons prop:impersonator-of keyword-procedure-impersonator-of))
(current-inspector)
#f
'(0 1 2 3)))
(let ((app_0
(list
(cons prop:checked-procedure #t)
(cons prop:impersonator-of keyword-procedure-impersonator-of))))
(make-struct-type
'keyword-procedure
#f
4
0
#f
app_0
(current-inspector)
#f
'(0 1 2 3))))
(define keyword-procedure-required
(make-struct-field-accessor keyword-procedure-ref 2))
(define keyword-procedure-allowed
@ -2012,8 +2014,7 @@
rx1_0
(if (if (rx:range? rx1_0) (rx:range? rx2_0) #f)
(rx-range
(let ((app_0 (rx:range-range rx1_0)))
(range-union app_0 (rx:range-range rx2_0)))
(range-union (rx:range-range rx1_0) (rx:range-range rx2_0))
limit-c_0)
(if (if (rx:range? rx1_0)
(if (rx:alts? rx2_0) (rx:range? (rx:alts-rx_1874 rx2_0)) #f)
@ -2209,36 +2210,26 @@
(define config-case-sensitive
(lambda (config_0 cs?_0)
(if (parse-config? config_0)
(let ((app_0 (parse-config-who config_0)))
(let ((app_1 (parse-config-px? config_0)))
(let ((app_2 (parse-config-multi-line? config_0)))
(let ((app_3 (parse-config-group-number-box config_0)))
(let ((app_4 (parse-config-references?-box config_0)))
(parse-config1.1
app_0
app_1
cs?_0
app_2
app_3
app_4
(parse-config-error-handler? config_0)))))))
(parse-config1.1
(parse-config-who config_0)
(parse-config-px? config_0)
cs?_0
(parse-config-multi-line? config_0)
(parse-config-group-number-box config_0)
(parse-config-references?-box config_0)
(parse-config-error-handler? config_0))
(raise-argument-error 'struct-copy "parse-config?" config_0))))
(define config-multi-line
(lambda (config_0 mm?_0)
(if (parse-config? config_0)
(let ((app_0 (parse-config-who config_0)))
(let ((app_1 (parse-config-px? config_0)))
(let ((app_2 (parse-config-case-sensitive? config_0)))
(let ((app_3 (parse-config-group-number-box config_0)))
(let ((app_4 (parse-config-references?-box config_0)))
(parse-config1.1
app_0
app_1
app_2
mm?_0
app_3
app_4
(parse-config-error-handler? config_0)))))))
(parse-config1.1
(parse-config-who config_0)
(parse-config-px? config_0)
(parse-config-case-sensitive? config_0)
mm?_0
(parse-config-group-number-box config_0)
(parse-config-references?-box config_0)
(parse-config-error-handler? config_0))
(raise-argument-error 'struct-copy "parse-config?" config_0))))
(define config-group-number
(lambda (config_0) (unbox (parse-config-group-number-box config_0))))
@ -2310,7 +2301,8 @@
#f
(let ((c_0 (chytes-ref$1 s_0 pos_2)))
(if (if (>= c_0 97) (<= c_0 122) #f)
(loop_0 (cons c_0 accum_0) (add1 pos_2))
(let ((app_0 (cons c_0 accum_0)))
(loop_0 app_0 (add1 pos_2)))
(if (if (= c_0 58)
(if (let ((app_0 (add1 pos_2)))
(< app_0 (chytes-length$1 s_0)))
@ -3208,9 +3200,8 @@
(config-group-number+1 config_0)))
(case-lambda
((rx_0 pos2_0)
(values
(begin-unsafe (rx:group3.1 rx_0 group-number_0))
(check-close-paren s_0 pos2_0 config_0)))
(let ((app_0 (begin-unsafe (rx:group3.1 rx_0 group-number_0))))
(values app_0 (check-close-paren s_0 pos2_0 config_0))))
(args (raise-binding-result-arity-error 2 args))))))))))
(define parse-look
(lambda (s_0 pos2_0 config_0)
@ -3425,7 +3416,8 @@
pos3_0
config_0
"expected `)` after `(?(` followed by digits"))
(values (rx:reference10.1 n_0 #f) (add1 pos3_0))))
(let ((app_0 (rx:reference10.1 n_0 #f)))
(values app_0 (add1 pos3_0)))))
(args (raise-binding-result-arity-error 2 args)))))
(parse-error
s_0
@ -4037,13 +4029,11 @@
(if (rx:repeat? rx_0)
(if (rx:repeat? rx_0)
(let ((rx3_0 (convert (rx:repeat-rx rx_0))))
(let ((app_0 (rx:repeat-min rx_0)))
(let ((app_1 (rx:repeat-max rx_0)))
(rx:repeat4.1
rx3_0
app_0
app_1
(rx:repeat-non-greedy? rx_0)))))
(rx:repeat4.1
rx3_0
(rx:repeat-min rx_0)
(rx:repeat-max rx_0)
(rx:repeat-non-greedy? rx_0)))
(raise-argument-error 'struct-copy "rx:repeat?" rx_0))
(if (rx:maybe? rx_0)
(if (rx:maybe? rx_0)
@ -4059,18 +4049,14 @@
(convert
(rx:conditional-rx_2094 rx_0))))
(let ((rx16_1 rx16_0) (tst5_1 tst5_0))
(let ((app_0
(rx:conditional-n-start rx_0)))
(let ((app_1
(rx:conditional-num-n rx_0)))
(rx:conditional6.1
tst5_1
rx16_1
rx27_0
app_0
app_1
(rx:conditional-needs-backtrack?
rx_0))))))))
(rx:conditional6.1
tst5_1
rx16_1
rx27_0
(rx:conditional-n-start rx_0)
(rx:conditional-num-n rx_0)
(rx:conditional-needs-backtrack?
rx_0))))))
(raise-argument-error
'struct-copy
"rx:conditional?"
@ -4078,13 +4064,11 @@
(if (rx:lookahead? rx_0)
(if (rx:lookahead? rx_0)
(let ((rx8_0 (convert (rx:lookahead-rx rx_0))))
(let ((app_0 (rx:lookahead-match? rx_0)))
(let ((app_1 (rx:lookahead-n-start rx_0)))
(rx:lookahead7.1
rx8_0
app_0
app_1
(rx:lookahead-num-n rx_0)))))
(rx:lookahead7.1
rx8_0
(rx:lookahead-match? rx_0)
(rx:lookahead-n-start rx_0)
(rx:lookahead-num-n rx_0)))
(raise-argument-error
'struct-copy
"rx:lookahead?"
@ -4093,19 +4077,13 @@
(if (rx:lookbehind? rx_0)
(let ((rx9_0
(convert (rx:lookbehind-rx rx_0))))
(let ((app_0 (rx:lookbehind-match? rx_0)))
(let ((app_1 (rx:lookbehind-lb-min rx_0)))
(let ((app_2
(rx:lookbehind-lb-max rx_0)))
(let ((app_3
(rx:lookbehind-n-start rx_0)))
(rx:lookbehind8.1
rx9_0
app_0
app_1
app_2
app_3
(rx:lookbehind-num-n rx_0)))))))
(rx:lookbehind8.1
rx9_0
(rx:lookbehind-match? rx_0)
(rx:lookbehind-lb-min rx_0)
(rx:lookbehind-lb-max rx_0)
(rx:lookbehind-n-start rx_0)
(rx:lookbehind-num-n rx_0)))
(raise-argument-error
'struct-copy
"rx:lookbehind?"
@ -4113,13 +4091,11 @@
(if (rx:cut? rx_0)
(if (rx:cut? rx_0)
(let ((rx10_0 (convert (rx:cut-rx rx_0))))
(let ((app_0 (rx:cut-n-start rx_0)))
(let ((app_1 (rx:cut-num-n rx_0)))
(rx:cut9.1
rx10_0
app_0
app_1
(rx:cut-needs-backtrack? rx_0)))))
(rx:cut9.1
rx10_0
(rx:cut-n-start rx_0)
(rx:cut-num-n rx_0)
(rx:cut-needs-backtrack? rx_0)))
(raise-argument-error
'struct-copy
"rx:cut?"
@ -4151,10 +4127,11 @@
(void)))))))
(if (> end_0 seg-end_0)
(loop_0
(cons
(cons start_1 seg-end_0)
(let ((app_0 (cons (add1 seg-end_0) end_0)))
(cons app_0 (cdr l_1)))))
(let ((app_0 (cons start_1 seg-end_0)))
(cons
app_0
(let ((app_1 (cons (add1 seg-end_0) end_0)))
(cons app_1 (cdr l_1))))))
(if (<= end_0 127)
(let ((app_0
(rx-range
@ -5018,14 +4995,13 @@
app_1
(lazy-bytes-skip-amt s_0)
discarded-count_0))))
(let ((app_2 (lazy-bytes-progress-evt s_0)))
(|#%app|
app_0
bstr_0
app_1
app_2
(lazy-bytes-in s_0)
len_0))))))
(|#%app|
app_0
bstr_0
app_1
(lazy-bytes-progress-evt s_0)
(lazy-bytes-in s_0)
len_0)))))
(if (eof-object? n_0)
#f
(if (not (fixnum? n_0))
@ -6808,7 +6784,8 @@
#f)
(if (eq? c_0 'fail)
#f
(loop_0 (add1 pos_1) (cons b_0 accum_0))))))))))))
(let ((app_0 (add1 pos_1)))
(loop_0 app_0 (cons b_0 accum_0)))))))))))))
(loop_0 pos_0 null)))))
(define 1/compile
(|#%name|
@ -6927,78 +6904,77 @@
(let ((min_0
(rx:repeat-min
rx_1)))
(let ((max_0
(let ((n_0
(rx:repeat-max
rx_1)))
(let ((n_0
(rx:repeat-max
rx_1)))
(let ((max_0
(if (=
n_0
+inf.0)
#f
n_0))))
(let ((r-m*_0
(compile*/maybe
r-rx_0
min_0
max_0)))
(if (if r-m*_0
(not
(rx:repeat-non-greedy?
rx_1))
#f)
(repeat-simple-many-matcher
r-m*_0
min_0
max_0
group-n_0
next-m_0)
(let ((r-m_0
(compile_0
r-rx_0
(if simple?_0
done-m
continue-m))))
(if (rx:repeat-non-greedy?
rx_1)
(if simple?_0
(lazy-repeat-simple-matcher
r-m_0
min_0
max_0
next-m_0)
(lazy-repeat-matcher
r-m_0
min_0
max_0
next-m_0))
(if simple?_0
(repeat-simple-matcher
r-m_0
min_0
max_0
group-n_0
next-m_0)
(repeat-matcher
r-m_0
min_0
max_0
next-m_0))))))))))))
n_0)))
(let ((r-m*_0
(compile*/maybe
r-rx_0
min_0
max_0)))
(if (if r-m*_0
(not
(rx:repeat-non-greedy?
rx_1))
#f)
(repeat-simple-many-matcher
r-m*_0
min_0
max_0
group-n_0
next-m_0)
(let ((r-m_0
(compile_0
r-rx_0
(if simple?_0
done-m
continue-m))))
(if (rx:repeat-non-greedy?
rx_1)
(if simple?_0
(lazy-repeat-simple-matcher
r-m_0
min_0
max_0
next-m_0)
(lazy-repeat-matcher
r-m_0
min_0
max_0
next-m_0))
(if simple?_0
(repeat-simple-matcher
r-m_0
min_0
max_0
group-n_0
next-m_0)
(repeat-matcher
r-m_0
min_0
max_0
next-m_0)))))))))))))
(if (rx:group? rx_1)
(let ((n_0
(rx:group-number
rx_1)))
(let ((m_0
(let ((app_0
(rx:group-rx
rx_1)))
(let ((app_0
(rx:group-rx rx_1)))
(let ((m_0
(compile_0
app_0
(group-set-matcher
n_0
next-m_0)))))
(group-push-matcher
n_0
m_0)))
next-m_0))))
(group-push-matcher
n_0
m_0))))
(if (rx:reference? rx_1)
(let ((n_0
(rx:reference-n
@ -7018,14 +6994,11 @@
(compile_0
(rx:cut-rx rx_1)
done-m)))
(let ((app_1
(rx:cut-n-start
rx_1)))
(cut-matcher
app_0
app_1
(rx:cut-num-n rx_1)
next-m_0)))
(cut-matcher
app_0
(rx:cut-n-start rx_1)
(rx:cut-num-n rx_1)
next-m_0))
(if (rx:conditional? rx_1)
(let ((tst_0
(rx:conditional-tst
@ -7054,16 +7027,14 @@
(compile_0
tst_0
done-m)))
(let ((app_1
(rx:conditional-n-start
rx_1)))
(conditional/look-matcher
app_0
m1_0
m2_0
app_1
(rx:conditional-num-n
rx_1))))))))
(conditional/look-matcher
app_0
m1_0
m2_0
(rx:conditional-n-start
rx_1)
(rx:conditional-num-n
rx_1)))))))
(if (rx:lookahead? rx_1)
(let ((app_0
(rx:lookahead-match?
@ -7073,16 +7044,14 @@
(rx:lookahead-rx
rx_1)
done-m)))
(let ((app_2
(rx:lookahead-n-start
rx_1)))
(lookahead-matcher
app_0
app_1
app_2
(rx:lookahead-num-n
rx_1)
next-m_0))))
(lookahead-matcher
app_0
app_1
(rx:lookahead-n-start
rx_1)
(rx:lookahead-num-n
rx_1)
next-m_0)))
(if (rx:lookbehind?
rx_1)
(let ((app_0
@ -7099,28 +7068,24 @@
(rx:lookbehind-rx
rx_1)
limit-m)))
(let ((app_4
(rx:lookbehind-n-start
rx_1)))
(lookbehind-matcher
app_0
app_1
app_2
app_3
app_4
(rx:lookbehind-num-n
rx_1)
next-m_0))))))
(lookbehind-matcher
app_0
app_1
app_2
app_3
(rx:lookbehind-n-start
rx_1)
(rx:lookbehind-num-n
rx_1)
next-m_0)))))
(if (rx:unicode-categories?
rx_1)
(let ((app_0
(rx:unicode-categories-symlist
rx_1)))
(unicode-categories-matcher
app_0
(rx:unicode-categories-match?
rx_1)
next-m_0))
(unicode-categories-matcher
(rx:unicode-categories-symlist
rx_1)
(rx:unicode-categories-match?
rx_1)
next-m_0)
(error
'compile/bt
"internal error: unrecognized ~s"
@ -7139,7 +7104,7 @@
#f))))))
(define struct:rx:regexp
(make-record-type-descriptor* 'regexp #f #f #f #f 10 0))
(define effect_2093
(define effect_2629
(struct-type-install-properties!
struct:rx:regexp
'regexp
@ -7151,9 +7116,8 @@
prop:equal+hash
(list
(lambda (a_0 b_0 eql?_0)
(if (let ((app_0 (rx:regexp-px? a_0))) (eq? app_0 (rx:regexp-px? b_0)))
(let ((app_0 (rx:regexp-source a_0)))
(equal? app_0 (rx:regexp-source b_0)))
(if (eq? (rx:regexp-px? a_0) (rx:regexp-px? b_0))
(equal? (rx:regexp-source a_0) (rx:regexp-source b_0))
#f))
(lambda (a_0 hc_0) (|#%app| hc_0 (rx:regexp-source a_0)))
(lambda (a_0 hc_0) (|#%app| hc_0 (rx:regexp-source a_0)))))
@ -7564,7 +7528,8 @@
(let ((app_0 (+ ms-pos3_0 delta1_0)))
(cons app_0 (+ me-pos4_0 delta1_0))))
(if (zero? delta1_0)
(cons (cons ms-pos3_0 me-pos4_0) (vector->list state5_0))
(let ((app_0 (cons ms-pos3_0 me-pos4_0)))
(cons app_0 (vector->list state5_0)))
(let ((app_0
(let ((app_0 (+ ms-pos3_0 delta1_0)))
(cons app_0 (+ me-pos4_0 delta1_0)))))
@ -8134,26 +8099,26 @@
(args (raise-binding-result-arity-error 2 args))))))))
(define fast-drive-regexp-match-positions/bytes
(lambda (rx_0 in_0 start-pos_0 end-pos_0)
(let ((state_0
(let ((n_0 (rx:regexp-num-groups rx_0)))
(if (positive? n_0) (make-vector n_0 #f) #f))))
(call-with-values
(lambda ()
(search-match
rx_0
in_0
start-pos_0
start-pos_0
(if end-pos_0 end-pos_0 (unsafe-bytes-length in_0))
state_0))
(case-lambda
((ms-pos_0 me-pos_0)
(if ms-pos_0
(if state_0
(cons (cons ms-pos_0 me-pos_0) (vector->list state_0))
(list (cons ms-pos_0 me-pos_0)))
#f))
(args (raise-binding-result-arity-error 2 args)))))))
(let ((n_0 (rx:regexp-num-groups rx_0)))
(let ((state_0 (if (positive? n_0) (make-vector n_0 #f) #f)))
(call-with-values
(lambda ()
(search-match
rx_0
in_0
start-pos_0
start-pos_0
(if end-pos_0 end-pos_0 (unsafe-bytes-length in_0))
state_0))
(case-lambda
((ms-pos_0 me-pos_0)
(if ms-pos_0
(if state_0
(let ((app_0 (cons ms-pos_0 me-pos_0)))
(cons app_0 (vector->list state_0)))
(list (cons ms-pos_0 me-pos_0)))
#f))
(args (raise-binding-result-arity-error 2 args))))))))
(define fast-drive-regexp-match-positions/string
(lambda (rx_0 in-str_0 start-offset_0 end-offset_0)
(let ((in_0
@ -8162,149 +8127,87 @@
0
start-offset_0
(if end-offset_0 end-offset_0 (string-length in-str_0)))))
(let ((state_0
(let ((n_0 (rx:regexp-num-groups rx_0)))
(if (positive? n_0) (make-vector n_0 #f) #f))))
(call-with-values
(lambda ()
(search-match rx_0 in_0 0 0 (unsafe-bytes-length in_0) state_0))
(case-lambda
((ms-pos_0 me-pos_0)
(let ((string-offset_0
(|#%name|
string-offset
(lambda (pos_0)
(begin
(+
start-offset_0
(bytes-utf-8-length in_0 '#\x3f 0 pos_0)))))))
(if ms-pos_0
(let ((app_0
(let ((app_0 (string-offset_0 ms-pos_0)))
(cons app_0 (string-offset_0 me-pos_0)))))
(cons
app_0
(if state_0
(reverse$1
(call-with-values
(lambda ()
(begin
(check-vector state_0)
(values state_0 (unsafe-vector-length state_0))))
(case-lambda
((vec_0 len_0)
(begin
#f
(letrec*
((for-loop_0
(|#%name|
for-loop
(lambda (fold-var_0 pos_0)
(begin
(if (unsafe-fx< pos_0 len_0)
(let ((p_0
(unsafe-vector-ref vec_0 pos_0)))
(let ((fold-var_1
(let ((fold-var_1
(cons
(if p_0
(let ((app_1
(string-offset_0
(car p_0))))
(cons
app_1
(string-offset_0
(cdr p_0))))
#f)
fold-var_0)))
(values fold-var_1))))
(for-loop_0
fold-var_1
(unsafe-fx+ 1 pos_0))))
fold-var_0))))))
(for-loop_0 null 0))))
(args (raise-binding-result-arity-error 2 args)))))
null)))
#f)))
(args (raise-binding-result-arity-error 2 args))))))))
(let ((n_0 (rx:regexp-num-groups rx_0)))
(let ((state_0 (if (positive? n_0) (make-vector n_0 #f) #f)))
(call-with-values
(lambda ()
(search-match rx_0 in_0 0 0 (unsafe-bytes-length in_0) state_0))
(case-lambda
((ms-pos_0 me-pos_0)
(let ((string-offset_0
(|#%name|
string-offset
(lambda (pos_0)
(begin
(+
start-offset_0
(bytes-utf-8-length in_0 '#\x3f 0 pos_0)))))))
(if ms-pos_0
(let ((app_0
(let ((app_0 (string-offset_0 ms-pos_0)))
(cons app_0 (string-offset_0 me-pos_0)))))
(cons
app_0
(if state_0
(reverse$1
(call-with-values
(lambda ()
(begin
(check-vector state_0)
(values state_0 (unsafe-vector-length state_0))))
(case-lambda
((vec_0 len_0)
(begin
#f
(letrec*
((for-loop_0
(|#%name|
for-loop
(lambda (fold-var_0 pos_0)
(begin
(if (unsafe-fx< pos_0 len_0)
(let ((p_0
(unsafe-vector-ref vec_0 pos_0)))
(let ((fold-var_1
(let ((fold-var_1
(cons
(if p_0
(let ((app_1
(string-offset_0
(car p_0))))
(cons
app_1
(string-offset_0
(cdr p_0))))
#f)
fold-var_0)))
(values fold-var_1))))
(for-loop_0
fold-var_1
(unsafe-fx+ 1 pos_0))))
fold-var_0))))))
(for-loop_0 null 0))))
(args (raise-binding-result-arity-error 2 args)))))
null)))
#f)))
(args (raise-binding-result-arity-error 2 args)))))))))
(define fast-drive-regexp-match/bytes
(lambda (rx_0 in_0 start-pos_0 end-pos_0)
(let ((state_0
(let ((n_0 (rx:regexp-num-groups rx_0)))
(if (positive? n_0) (make-vector n_0 #f) #f))))
(call-with-values
(lambda ()
(search-match
rx_0
in_0
start-pos_0
start-pos_0
(if end-pos_0 end-pos_0 (unsafe-bytes-length in_0))
state_0))
(case-lambda
((ms-pos_0 me-pos_0)
(if ms-pos_0
(let ((app_0 (subbytes in_0 ms-pos_0 me-pos_0)))
(cons
app_0
(if state_0
(reverse$1
(call-with-values
(lambda ()
(begin
(check-vector state_0)
(values state_0 (unsafe-vector-length state_0))))
(case-lambda
((vec_0 len_0)
(begin
#f
(letrec*
((for-loop_0
(|#%name|
for-loop
(lambda (fold-var_0 pos_0)
(begin
(if (unsafe-fx< pos_0 len_0)
(let ((p_0 (unsafe-vector-ref vec_0 pos_0)))
(let ((fold-var_1
(let ((fold-var_1
(cons
(if p_0
(let ((app_1 (car p_0)))
(subbytes
in_0
app_1
(cdr p_0)))
#f)
fold-var_0)))
(values fold-var_1))))
(for-loop_0
fold-var_1
(unsafe-fx+ 1 pos_0))))
fold-var_0))))))
(for-loop_0 null 0))))
(args (raise-binding-result-arity-error 2 args)))))
null)))
#f))
(args (raise-binding-result-arity-error 2 args)))))))
(define fast-drive-regexp-match/string
(lambda (rx_0 in-str_0 start-offset_0 end-offset_0)
(let ((in_0
(string->bytes/utf-8
in-str_0
0
start-offset_0
(if end-offset_0 end-offset_0 (string-length in-str_0)))))
(let ((state_0
(let ((n_0 (rx:regexp-num-groups rx_0)))
(if (positive? n_0) (make-vector n_0 #f) #f))))
(let ((n_0 (rx:regexp-num-groups rx_0)))
(let ((state_0 (if (positive? n_0) (make-vector n_0 #f) #f)))
(call-with-values
(lambda ()
(search-match rx_0 in_0 0 0 (unsafe-bytes-length in_0) state_0))
(search-match
rx_0
in_0
start-pos_0
start-pos_0
(if end-pos_0 end-pos_0 (unsafe-bytes-length in_0))
state_0))
(case-lambda
((ms-pos_0 me-pos_0)
(if ms-pos_0
(let ((app_0 (bytes->string/utf-8 in_0 '#\x3f ms-pos_0 me-pos_0)))
(let ((app_0 (subbytes in_0 ms-pos_0 me-pos_0)))
(cons
app_0
(if state_0
@ -8331,9 +8234,8 @@
(cons
(if p_0
(let ((app_1 (car p_0)))
(bytes->string/utf-8
(subbytes
in_0
'#\x3f
app_1
(cdr p_0)))
#f)
@ -8348,6 +8250,68 @@
null)))
#f))
(args (raise-binding-result-arity-error 2 args))))))))
(define fast-drive-regexp-match/string
(lambda (rx_0 in-str_0 start-offset_0 end-offset_0)
(let ((in_0
(string->bytes/utf-8
in-str_0
0
start-offset_0
(if end-offset_0 end-offset_0 (string-length in-str_0)))))
(let ((n_0 (rx:regexp-num-groups rx_0)))
(let ((state_0 (if (positive? n_0) (make-vector n_0 #f) #f)))
(call-with-values
(lambda ()
(search-match rx_0 in_0 0 0 (unsafe-bytes-length in_0) state_0))
(case-lambda
((ms-pos_0 me-pos_0)
(if ms-pos_0
(let ((app_0
(bytes->string/utf-8 in_0 '#\x3f ms-pos_0 me-pos_0)))
(cons
app_0
(if state_0
(reverse$1
(call-with-values
(lambda ()
(begin
(check-vector state_0)
(values state_0 (unsafe-vector-length state_0))))
(case-lambda
((vec_0 len_0)
(begin
#f
(letrec*
((for-loop_0
(|#%name|
for-loop
(lambda (fold-var_0 pos_0)
(begin
(if (unsafe-fx< pos_0 len_0)
(let ((p_0
(unsafe-vector-ref vec_0 pos_0)))
(let ((fold-var_1
(let ((fold-var_1
(cons
(if p_0
(let ((app_1 (car p_0)))
(bytes->string/utf-8
in_0
'#\x3f
app_1
(cdr p_0)))
#f)
fold-var_0)))
(values fold-var_1))))
(for-loop_0
fold-var_1
(unsafe-fx+ 1 pos_0))))
fold-var_0))))))
(for-loop_0 null 0))))
(args (raise-binding-result-arity-error 2 args)))))
null)))
#f))
(args (raise-binding-result-arity-error 2 args)))))))))
(define drive-regexp-match.1
(|#%name|
drive-regexp-match

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

File diff suppressed because it is too large Load Diff

970
racket/src/cs/schemified/thread.scm
View File

File diff suppressed because it is too large Load Diff

2
racket/src/schemify/infer-known.rkt
View File

@ -93,7 +93,7 @@
[`,_
(cond
[(and defn
(simple? rhs prim-knowns knowns imports mutated simples))
(simple? rhs prim-knowns knowns imports mutated simples unsafe-mode?))
a-known-constant]
[else #f])])])))

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

@ -19,6 +19,7 @@
known-procedure/can-inline/need-imports known-procedure/can-inline/need-imports?
known-procedure/can-inline/need-imports-needed
known-procedure/succeeds known-procedure/succeeds?
known-procedure/allocates known-procedure/allocates?
known-procedure/pure known-procedure/pure?
known-procedure/pure/folding known-procedure/pure/folding? ; not a subtype of `known-procedure/folding`
known-procedure/pure/folding-unsafe known-procedure/pure/folding-unsafe?
@ -96,8 +97,11 @@
;; procedure with single value that never raises an exception or otherwise captures/escapes the calling context
(struct known-procedure/succeeds () #:prefab #:omit-define-syntaxes #:super struct:known-procedure/no-prompt)
;; procedure that accepts any arguments, returns a single value, and is functional so that it can be reordered
(struct known-procedure/pure () #:prefab #:omit-define-syntaxes #:super struct:known-procedure/succeeds)
;; procedure that accepts any arguments, returns a single value, and has allocation as its only effect
(struct known-procedure/allocates () #:prefab #:omit-define-syntaxes #:super struct:known-procedure/succeeds)
;; procedure that accepts any arguments, returns a single value, and has/observes no effect so that it can be reordered
(struct known-procedure/pure () #:prefab #:omit-define-syntaxes #:super struct:known-procedure/allocates)
;; pure and folding:
(struct known-procedure/pure/folding () #:prefab #:omit-define-syntaxes #:super struct:known-procedure/pure)
@ -112,7 +116,7 @@
(struct known-struct-type (type field-count pure-constructor?) #:prefab #:omit-define-syntaxes #:super struct:known-consistent)
;; procedures with a known connection to a structure type:
(struct known-constructor (type) #:prefab #:omit-define-syntaxes #:super struct:known-procedure/pure)
(struct known-constructor (type) #:prefab #:omit-define-syntaxes #:super struct:known-procedure/allocates)
(struct known-predicate (type) #:prefab #:omit-define-syntaxes #:super struct:known-procedure/pure)
(struct known-accessor (type) #:prefab #:omit-define-syntaxes #:super struct:known-procedure/single-valued)
(struct known-mutator (type) #:prefab #:omit-define-syntaxes #:super struct:known-procedure/single-valued)

90
racket/src/schemify/left-to-right.rkt
View File

@ -16,7 +16,7 @@
;; expressions that have no shadowing (and introduce
;; shadowing here)
(define (left-to-right/let ids rhss bodys
prim-knowns knowns imports mutated simples)
prim-knowns knowns imports mutated simples unsafe-mode?)
(cond
[(null? ids) (if (null? (cdr bodys))
(car bodys)
@ -30,7 +30,7 @@
(define id (car ids))
(define rhs (car rhss))
(if (and all-simple?
(simple? rhs prim-knowns knowns imports mutated simples))
(simple? rhs prim-knowns knowns imports mutated simples unsafe-mode?))
`(let ([,id ,rhs])
. ,bodys)
`(let ([,id ,rhs])
@ -43,7 +43,7 @@
,(loop (cdr ids)
(cdr rhss)
(and all-simple?
(simple? rhs prim-knowns knowns imports mutated simples))
(simple? rhs prim-knowns knowns imports mutated simples unsafe-mode?))
(cons `[,id ,id] binds)))]))]))
;; Convert a `let-values` to nested `let-values`es to
@ -74,41 +74,63 @@
binds))
target)]))]))
;; Convert an application to enforce left-to-right
;; evaluation order
;; Convert an application to enforce left-to-right evaluation order.
(define (left-to-right/app rator rands app-form target
prim-knowns knowns imports mutated simples)
prim-knowns knowns imports mutated simples unsafe-mode?)
(cond
[(aim? target 'cify) (cons rator rands)]
[else
(let loop ([l (cons rator rands)] [accum null] [pending-non-simple #f] [pending-id #f])
(cond
[(null? l)
(let ([app
(cond
[pending-non-simple
;; Since the last non-simple was followed only by simples,
;; we don't need that variable
(let loop ([accum accum] [rev-accum null])
(cond
[(null? accum) rev-accum]
[(eq? (car accum) pending-id)
(loop (cdr accum) (cons pending-non-simple rev-accum))]
[else
(loop (cdr accum) (cons (car accum) rev-accum))]))]
[else (reverse accum)])])
(if app-form
(cons app-form app)
app))]
[(simple? (car l) prim-knowns knowns imports mutated simples)
(loop (cdr l) (cons (car l) accum) pending-non-simple pending-id)]
[pending-non-simple
`(let ([,pending-id ,pending-non-simple])
,(loop l accum #f #f))]
[else
(define g (deterministic-gensym "app_"))
(loop (cdr l) (cons g accum) (car l) g)]))]))
(define l (cons rator rands))
(define modes
;; If an argument is pure, we don't have to order it explicitly.
;; If an argument is pure except for allocation, then we only have to
;; order it if a later argument is non-pure.
(let loop ([l l])
(cond
[(null? l) 'pure]
[else
(define modes (loop (cdr l)))
(cond
[(simple? (car l) prim-knowns knowns imports mutated simples unsafe-mode? #:no-alloc? #t)
(if (symbol? modes)
modes
(cons 'pure modes))]
[(simple? (car l) prim-knowns knowns imports mutated simples unsafe-mode?) ; allocates
(if (symbol? modes)
'alloc
(cons 'bind modes))]
[else
(if (eq? modes 'pure)
(cons 'non-simple modes)
(cons 'bind modes))])])))
(define no-bind-needed?
(let loop ([modes modes])
(cond
[(symbol? modes) #t]
[(eq? (car modes) 'pure) (loop (cdr modes))]
[(eq? (car modes) 'non-simple) #t]
[else #f])))
(cond
[no-bind-needed?
(if app-form
(cons app-form l)
l)]
[else
(let loop ([l l] [modes modes] [accum null])
(cond
[(or (symbol? modes)
(eq? (car modes) 'non-simple))
(define app (append (reverse accum) l))
(if app-form
(cons app-form app)
app)]
[(eq? (car modes) 'bind)
(define g (deterministic-gensym "app_"))
`(let ([,g ,(car l)])
,(loop (cdr l) (cdr modes) (cons g accum)))]
[else
(loop (cdr l) (cdr modes) (cons (car l) accum))]))])]))
;; ----------------------------------------
(define (make-let-values ids rhs body target)

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

@ -69,11 +69,11 @@
;; check individual property values using `ids`, so procedures won't
;; count as used until some instace is created
(for ([e (in-list prop-vals)])
(find-mutated! e ids prim-knowns knowns imports mutated simples))]
(find-mutated! e ids prim-knowns knowns imports mutated simples unsafe-mode?))]
[else
(find-mutated! e ids prim-knowns knowns imports mutated simples)]))]
(find-mutated! e ids prim-knowns knowns imports mutated simples unsafe-mode?)]))]
[else
(find-mutated! rhs ids prim-knowns knowns imports mutated simples)])
(find-mutated! rhs ids prim-knowns knowns imports mutated simples unsafe-mode?)])
;; For any among `ids` that didn't get a delay and wasn't used
;; too early, the variable is now ready, so remove from
;; `mutated`:
@ -82,7 +82,7 @@
(when (eq? 'not-ready (hash-ref mutated id #f))
(hash-remove! mutated id))))]
[`,_
(find-mutated! form #f prim-knowns knowns imports mutated simples)])
(find-mutated! form #f prim-knowns knowns imports mutated simples unsafe-mode?)])
knowns)
;; For definitions that are not yet used, force delays:
(for ([form (in-list l)])
@ -101,7 +101,7 @@
;; Schemify `let-values` to `let`, etc., and
;; reorganize struct bindings.
(define (find-mutated! top-v ids prim-knowns knowns imports mutated simples)
(define (find-mutated! top-v ids prim-knowns knowns imports mutated simples unsafe-mode?)
(define (delay! ids thunk)
(define done? #f)
(define force (lambda () (unless done?
@ -153,7 +153,7 @@
[rhs (in-list rhss)])
(find-mutated! rhs (unwrap-list ids))
(define new-maybe-cc? (or maybe-cc?
(not (simple? rhs prim-knowns knowns imports mutated simples
(not (simple? rhs prim-knowns knowns imports mutated simples unsafe-mode?
#:pure? #f
#:result-arity (length ids)))))
;; Each `id` in `ids` is now ready (but might also hold a delay):
@ -222,7 +222,7 @@
(eq? rator 'make-struct-type-property))
(bitwise-bit-set? (known-procedure-arity-mask v) (length exps))))
(for/and ([exp (in-list exps)])
(simple? exp prim-knowns knowns imports mutated simples)))))
(simple? exp prim-knowns knowns imports mutated simples unsafe-mode?)))))
;; Can delay construction
(delay! ids (lambda () (find-mutated!* exps #f)))]
[else

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

@ -377,23 +377,23 @@
(match schemified
[`(define ,id ,rhs)
(cond
[(simple? #:pure? #f rhs prim-knowns knowns imports mutated simples)
[(simple? #:pure? #f rhs prim-knowns knowns imports mutated simples unsafe-mode?)
(finish-definition (list id))]
[else
(finish-wrapped-definition (list id) rhs)])]
[`(define-values ,ids ,rhs)
(cond
[(simple? #:pure? #f rhs prim-knowns knowns imports mutated simples
[(simple? #:pure? #f rhs prim-knowns knowns imports mutated simples unsafe-mode?
#:result-arity (length ids))
(match rhs
[`(values ,rhss ...)
;; Flatten `(define-values (id ...) (values rhs ...))` to
;; a sequence `(define id rhs) ...`
(if (and (= (length rhss) (length ids))
;; Must be pure, otherwise a variable might be referenced
;; Must be simple enough, otherwise a variable might be referenced
;; too early:
(for/and ([rhs (in-list rhss)])
(simple? rhs prim-knowns knowns imports mutated simples)))
(simple? rhs prim-knowns knowns imports mutated simples unsafe-mode?)))
(let values-loop ([ids ids] [rhss rhss] [accum-exprs accum-exprs] [accum-ids accum-ids] [knowns knowns])
(cond
[(null? ids) (loop (cdr l) mut-l accum-exprs accum-ids knowns)]
@ -422,7 +422,7 @@
(finish-definition ids (append set-vars accum-exprs) null)]
[`,_
(cond
[(simple? #:pure? #f schemified prim-knowns knowns imports mutated simples
[(simple? #:pure? #f schemified prim-knowns knowns imports mutated simples unsafe-mode?
#:result-arity #f)
(loop (cdr l) mut-l (cons schemified accum-exprs) accum-ids knowns)]
[else
@ -567,8 +567,8 @@
(schemify rhs 'fresh))
(for/list ([body (in-list bodys)])
(schemify/knowns new-knowns inline-fuel wcm-state body))
prim-knowns knowns imports mutated simples)
prim-knowns knowns imports mutated simples)])]
prim-knowns knowns imports mutated simples unsafe-mode?)
prim-knowns knowns imports mutated simples unsafe-mode?)])]
[`(let-values ([() (begin ,rhss ... (values))]) ,bodys ...)
`(begin ,@(schemify-body rhss 'fresh) ,@(schemify-body bodys wcm-state))]
[`(let-values ([,idss ,rhss] ...) ,bodys ...)
@ -584,7 +584,7 @@
(schemify-body bodys wcm-state)
mutated
target)
prim-knowns knowns imports mutated simples))]
prim-knowns knowns imports mutated simples unsafe-mode?))]
[`(letrec-values () ,bodys ...)
(schemify `(begin . ,bodys) wcm-state)]
[`(letrec-values ([() (values)]) ,bodys ...)
@ -611,7 +611,7 @@
`[,id ,(schemify/knowns rhs-knowns inline-fuel 'fresh rhs)])
,@(for/list ([body (in-list bodys)])
(schemify/knowns body-knowns inline-fuel wcm-state body))))
prim-knowns knowns imports mutated simples)]
prim-knowns knowns imports mutated simples unsafe-mode?)]
[`(letrec-values ([,idss ,rhss] ...) ,bodys ...)
(cond
[(struct-convert-local v #:letrec? #t prim-knowns knowns imports mutated simples
@ -661,7 +661,7 @@
(authentic-valued? key knowns prim-knowns imports mutated))
(cond
[(and authentic-key?
(simple? s-body prim-knowns knowns imports mutated simples #:result-arity #f))
(simple? s-body prim-knowns knowns imports mutated simples unsafe-mode? #:result-arity #f))
`(begin ,(ensure-single-valued s-key knowns prim-knowns imports mutated)
,(ensure-single-valued s-val knowns prim-knowns imports mutated)
,s-body)]
@ -761,7 +761,7 @@
(left-to-right/app 'equal?
(list exp1 exp2)
#f target
prim-knowns knowns imports mutated simples)]))]
prim-knowns knowns imports mutated simples unsafe-mode?)]))]
[`(call-with-values ,generator ,receiver)
(cond
[(and (lambda? generator)
@ -772,7 +772,7 @@
(left-to-right/app (if (aim? target 'cify) 'call-with-values '#%call-with-values)
(list (schemify generator 'fresh) (schemify receiver 'fresh))
#f target
prim-knowns knowns imports mutated simples)])]
prim-knowns knowns imports mutated simples unsafe-mode?)])]
[`(single-flonum-available?)
;; Fold to a boolean to allow earlier simplification
(aim? target 'cify)]
@ -835,7 +835,7 @@
(left-to-right/app 'unsafe-struct
(cons (schemify type-id 'fresh) args)
#f target
prim-knowns knowns imports mutated simples)]
prim-knowns knowns imports mutated simples unsafe-mode?)]
[else #f]))
(define (inline-struct-predicate k s-rator im args)
(define type-id (and (known-struct-predicate-authentic? k)
@ -897,7 +897,7 @@
(left-to-right/app (car e)
(cdr e)
#f target
prim-knowns knowns imports mutated simples))]
prim-knowns knowns imports mutated simples unsafe-mode?))]
[(and (not (or
;; Don't inline in cify mode, because cify takes care of it
(aim? target 'cify)
@ -931,7 +931,7 @@
(left-to-right/app (known-procedure/has-unsafe-alternate k)
args
#f target
prim-knowns knowns imports mutated simples)]
prim-knowns knowns imports mutated simples unsafe-mode?)]
[else
(left-to-right/app s-rator
args
@ -947,7 +947,7 @@
#f]
[else '|#%app|])
target
prim-knowns knowns imports mutated simples)])))]
prim-knowns knowns imports mutated simples unsafe-mode?)])))]
[`,_
(let ([u-v (unwrap v)])
(cond

35
racket/src/schemify/simple.rkt
View File

@ -9,24 +9,35 @@
simple/can-copy?)
;; Check whether an expression is simple in the sense that its order
;; of evaluation isn't detectable. This function receives both
;; schemified and non-schemified expressions.
(define (simple? e prim-knowns knowns imports mutated simples
;; of evaluation isn't detectable (`pure?` = #t) or at least it won't
;; try to capture a comtinuation (`pure?` = #f). In `pure?` mode, if
;; `no-alloc?` is true, then allocation counts as detectable (for
;; ordering with respect to functions that might capture a continuation).
;; This function receives both schemified and non-schemified expressions.
(define (simple? e prim-knowns knowns imports mutated simples unsafe-mode?
#:pure? [pure? #t]
#:no-alloc? [no-alloc? #f]
#:result-arity [result-arity 1])
(let simple? ([e e] [result-arity result-arity])
(define-syntax-rule (cached expr)
(let* ([c (hash-ref simples e #(unknown unknown 1))]
[r (vector-ref c (if pure? 0 1))]
[arity-match? (eqv? result-arity (vector-ref c 2))])
(let* ([c (hash-ref simples e #(unknown unknown unknown 1))]
[r (vector-ref c (if pure? (if no-alloc? 1 0) 2))]
[arity-match? (eqv? result-arity (vector-ref c 3))])
(if (or (eq? 'unknown r)
(not arity-match?))
(let ([r expr])
(hash-set! simples e (if pure?
(vector r
(if arity-match? (vector-ref c 1) 'unknown)
result-arity)
(if no-alloc?
(vector (if arity-match? (vector-ref c 0) 'unknown)
r
(if arity-match? (vector-ref c 2) 'unknown)
result-arity)
(vector r
(if arity-match? (vector-ref c 1) 'unknown)
(if arity-match? (vector-ref c 2) 'unknown)
result-arity))
(vector (if arity-match? (vector-ref c 0) 'unknown)
(if arity-match? (vector-ref c 1) 'unknown)
r
result-arity)))
r)
@ -96,7 +107,11 @@
(let ([v (or (hash-ref-either knowns imports proc)
(hash-ref prim-knowns proc #f))])
(and (if pure?
(and (known-procedure/pure? v)
(and (if no-alloc?
(known-procedure/pure? v)
(or (known-procedure/allocates? v)
(and unsafe-mode?
(known-accessor? v))))
(returns 1))
(and (or (known-procedure/no-prompt? v)
(known-procedure/no-prompt/multi? v))

2
racket/src/schemify/single-valued.rkt
View File

@ -21,7 +21,7 @@
(simple-mutated-state? (hash-ref mutated u #f))
(let ([k (or (hash-ref prim-knowns u #f)
(hash-ref-either knowns imports u))])
(or (known-procedure/pure? k)
(or (known-procedure/allocates? k)
(known-procedure/single-valued? k))))
v]
[else `($value ,v)])]

2
racket/src/schemify/struct-type-info.rkt
View File

@ -128,7 +128,7 @@
(and (symbol? u-prop)
(or (known-struct-type-property/immediate-guard?
(find-known u-prop prim-knowns knowns imports mutated)))
(simple? val prim-knowns knowns imports mutated simples))))
(simple? val prim-knowns knowns imports mutated simples #f))))
vals)]
[`null null]
[`'() null]

4
racket/src/schemify/unnest-let.rkt
View File

@ -29,7 +29,7 @@
;; and <rhs> are immediate `lambda` forms, though, to avoid
;; pessimizing a set of mutually recursive functions.
(define (unnest-let e prim-knowns knowns imports mutated simples)
(define (unnest-let e prim-knowns knowns imports mutated simples unsafe-mode?)
(match e
[`(,let-id (,binds ...) . ,body)
(cond
@ -63,7 +63,7 @@
(for/and ([rhs (in-list rhss)])
(and (or (eq? 'let let-id)
(immediate-lambda? rhs))
(simple? rhs prim-knowns knowns imports mutated simples))))
(simple? rhs prim-knowns knowns imports mutated simples unsafe-mode?))))
(match (car binds)
[`[,_ (,_ ,inner-binds ,_)]
(cond

2
racket/src/version/racket_version.h
View File

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