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

cs & schemify: further refinments to left-to-right and letrec

Browse Source 
More cases where the code can be mostly left alone, and then cp0 and
company can make further improvements.
This commit is contained in:
Matthew Flatt 2020-12-30 08:47:54 -07:00
parent 62e8f27bf7
commit a8819af26a
15 changed files with 5207 additions and 4645 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.20")
(define version "7.9.0.21")
(define deps `("racket-lib"
["racket" #:version ,version]))

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

@ -50,10 +50,12 @@
(parameterize ([current-compile-target-machine #f])
(write (compile e) o))
(define lnkl (zo-parse (open-input-bytes (get-output-bytes o))))
(unless (linkl-directory? lnkl)
(error 'compile/optimize "expected a linklet directory"))
(define ht (linkl-directory-table lnkl))
(define bundle (hash-ref ht '() #f))
(unless (or (linkl-directory? lnkl)
(linkl-bundle? lnkl))
(error 'compile/optimize "expected a linklet directory or bundle"))
(define bundle (if (linkl-directory? lnkl)
(hash-ref (linkl-directory-table lnkl) '() #f)
lnkl))
(unless bundle
(error 'compile/optimize (string-append "didn't find main linklet bundle in directory;"
" maybe a top-level `begin` sequence?")))
@ -69,7 +71,7 @@
(error 'compile/optimize "compiled content does not have expected shape: ~s"
s-exp))
;; Support cross-module inling, at least through one layer of `require`
;; Support cross-module inlining, at least through one layer of `require`
(define-values (mpi-vector requires provides phase-to-link-modules)
(deserialize-requires-and-provides bundle))
(define link-modules (hash-ref phase-to-link-modules 0 '()))
@ -82,7 +84,18 @@
(define mu (hash-ref mod-uses key #f))
(cond
[mu
(define mp (module-path-index-resolve (module-use-module mu) #f))
(define (replace-self mpi)
(define-values (name base) (module-path-index-split mpi))
(cond
[(and (not name) (not base))
(make-resolved-module-path 'top-level-module)]
[(module-path-index? base)
(define new-base (replace-self base))
(if (eq? base new-base)
mpi
(module-path-index-join name new-base))]
[else mpi]))
(define mp (module-path-index-resolve (replace-self (module-use-module mu)) #f))
(define path (resolved-module-path-name mp))
(cond
[(path? path)
@ -114,28 +127,37 @@
[else
(new (cdr formals) (new (car formals) env))]))
(let loop ([s s] [env #hasheq()])
(define (body-loop bodys new-env)
;; ad hoc normlization for a pattern that is no different in back end
(match bodys
[`((let ,bindings . ,body) ,simple)
(loop `((let ,bindings ,@body ,simple)) new-env)]
[_ (loop bodys new-env)]))
(match s
[`(lambda ,formals . ,bodys)
(define new-env (new formals env))
`(lambda ,(loop formals new-env) . ,(loop bodys new-env))]
`(lambda ,(loop formals new-env) . ,(body-loop bodys new-env))]
[`(case-lambda [,formalss . ,bodyss] ...)
`(case-lambda
,@(for/list ([formals (in-list formalss)]
[bodys (in-list bodyss)])
(define new-env (new formals env))
`[,(loop formals new-env) . ,(loop bodys new-env)]))]
`[,(loop formals new-env) . ,(body-loop bodys new-env)]))]
[`(let ([,ids ,rhss] ...) . ,bodys)
(define new-env (new ids env))
`(let ,(for/list ([id (in-list ids)]
[rhs (in-list rhss)])
`[,(loop id new-env) ,(loop rhs env)])
. ,(loop bodys new-env))]
. ,(body-loop bodys new-env))]
[`(letrec ([,ids ,rhss] ...) . ,bodys)
(define new-env (new ids env))
`(letrec ,(for/list ([id (in-list ids)]
[rhs (in-list rhss)])
`[,(loop id new-env) ,(loop rhs new-env)])
. ,(loop bodys new-env))]
. ,(body-loop bodys new-env))]
[`(quote ,_) s]
[`(check-not-unsafe-undefined ,id (quote ,name))
`(check-not-unsafe-undefined ,(loop id env) (quote name-dropped-for-normalize))]
[`(,es ...)
(for/list ([e (in-list es)])
(loop e env))]
@ -387,10 +409,10 @@
[y (random)])
(list x x y y))
#f)
(test-comp #:except 'chez-scheme
(test-comp #:except 'chez-scheme ; cptypes could improve here
`(lambda (x y) (when (and (pair? x) (box? y)) (,e? x y)))
`(lambda (x y) (when (and (pair? x) (box? y)) #f)))
(test-comp #:except 'chez-scheme
(test-comp #:except 'chez-scheme ; cptypes could improve here
`(lambda (x y) (car x) (unbox y) (,e? x y))
`(lambda (x y) (car x) (unbox y) #f))
(test-comp #:except (and (eq? e? 'equal?) 'chez-scheme)
@ -588,7 +610,7 @@
(let ([x (list* w z)])
(car x)))
'(lambda (w z) w))
(test-comp #:except 'chez-scheme
(test-comp #:except 'chez-scheme ; cadr not specialized
'(lambda (w z)
(let ([x (list w z)])
(cadr x)))
@ -657,13 +679,13 @@
(test-comp '(lambda (u v) (cdr (unsafe-cons-list u v)))
'(lambda (u v) v))
(test-comp #:except 'chez-scheme
(test-comp #:except 'chez-scheme ; cp0 needs unbox specialization
'(lambda (v) (unbox (box v)))
'(lambda (v) v))
(test-comp #:except 'chez-scheme
(test-comp #:except 'chez-scheme ; cp0 needs unbox specialization
'(lambda (v) (unsafe-unbox (box v)))
'(lambda (v) v))
(test-comp #:except 'chez-scheme
(test-comp #:except 'chez-scheme ; cp0 needs unbox specialization
'(lambda (v) (unsafe-unbox* (box v)))
'(lambda (v) v))
@ -704,7 +726,7 @@
'(lambda (w z) (values (with-continuation-mark 'k 'v (read))) (random) #t))
(test-comp '(lambda (w z) (vector? (vector w z)))
'(lambda (w z) #t))
(test-comp #:except 'chez-scheme
(test-comp #:except 'chez-scheme ; vector-immutable is not primitive
'(lambda (w z) (vector? (vector-immutable w z)))
'(lambda (w z) #t))
(test-comp '(lambda (w z) (vector? (list 1)))
@ -746,10 +768,10 @@
'(lambda (x) (cdr x) (pair? x)))
(test-comp '(lambda (x) (cadr x) #t)
'(lambda (x) (cadr x) (pair? x)))
(test-comp #:except 'chez-scheme
(test-comp #:except 'chez-scheme ; procedure-arity-includes? is not primitive
'(lambda (f) (procedure-arity-includes? f 5) #t)
'(lambda (f) (procedure-arity-includes? f 5) (procedure? f)))
(test-comp #:except 'chez-scheme
(test-comp #:except 'chez-scheme ; procedureness is not primitive
'(lambda (f l) (f l) #t)
'(lambda (f l) (f l) (procedure? f)))
@ -774,7 +796,7 @@
(test-comp '(lambda (z) (let ([f (lambda (i) (car i))]) (f z)) #t)
'(lambda (z) (let ([f (lambda (i) (car i))]) (f z)) (pair? z)))
(test-comp #:except 'chez-scheme
(test-comp #:except 'chez-scheme ; real->double-flonum is not primitive
'(lambda (z) (fl+ z z))
'(lambda (z) (real->double-flonum (fl+ z z))))
(test-comp #:except 'chez-scheme
@ -965,7 +987,7 @@
#f
v v v2 v2))))
(test-comp #:except 'chez-scheme
(test-comp #:except 'chez-scheme ; unsafe car does not assume immutable
'(lambda (w z)
(if (list w z (random 7))
(let ([l (list (random))])
@ -1538,6 +1560,7 @@
(if r #t (something-else))))
'(lambda (x) (if (something) #t (something-else))))
(unless (eq? 'chez-scheme (system-type 'vm))
(let ([test-if-if-reduction
(lambda (dup)
(test-comp `(lambda (x y z) (if (if x y #f) z ,dup))
@ -1555,16 +1578,17 @@
(test-if-if-reduction #t)
(test-if-if-reduction #f)
(test-if-if-reduction 'car)
(test-if-if-reduction 'map))
(test-if-if-reduction 'map)))
(let ([test-pred-implies-val
(lambda (pred? val)
(test-comp `(lambda (x) (if (,pred? x) ,val 0))
`(lambda (x) (if (,pred? x) x 0)))
(unless (eq? 'chez-scheme (system-type 'vm))
(test-comp `(lambda (x) (eq? x ,val))
`(lambda (x) (,pred? x)))
(test-comp `(lambda (x) (eq? ,val x))
`(lambda (x) (,pred? x))))])
`(lambda (x) (,pred? x)))))])
(test-pred-implies-val 'null? 'null)
(test-pred-implies-val 'void? '(void))
(test-pred-implies-val 'eof-object? 'eof)
@ -1580,13 +1604,15 @@
'(lambda (x) (if x 1 (list x))))
(test-comp '(lambda (x) (let ([r (something)])
(test-comp #:except 'chez-scheme
'(lambda (x) (let ([r (something)])
(r)))
'(lambda (x) ((something))))
(test-comp '(lambda (x) (let ([r (something)])
(r (something-else))))
'(lambda (x) ((something) (something-else))))
(test-comp '(lambda (x z) (let ([r (something)])
(test-comp #:except 'chez-scheme
'(lambda (x z) (let ([r (something)])
(z r)))
'(lambda (x z) (z (something))))
(test-comp '(lambda (x) (let ([r (something)])
@ -1601,7 +1627,8 @@
(test-comp '(lambda (x z) (let ([r (something)])
(set! z r)))
'(lambda (x z) (set! z (something))))
(test-comp '(lambda (x z) (let ([r (something)])
(test-comp #:except 'chez-scheme
'(lambda (x z) (let ([r (something)])
(call-with-values (lambda () (z)) r)))
'(lambda (x z) (call-with-values (lambda () (z)) (something))))
@ -1685,7 +1712,8 @@
'(lambda (x)
(let ([n (random 9)]) (random n) (random n) (car x) (cons x 2))))
(test-comp '(lambda (x)
(test-comp #:except 'chez-scheme
'(lambda (x)
(if (begin (random) (not (begin (random) x))) 1 2))
'(lambda (x)
(if (begin (random) (random) x) 2 1)))
@ -1722,21 +1750,24 @@
(+ y 1))))
(test-comp '(let ()
(test-comp #:except 'chez-scheme ; procedure-specialize doesn't inline enough
'(let ()
(define (f x)
(procedure-specialize
(lambda (y) (+ x y))))
((f 10) 12))
'22)
(test-comp '(let ()
(test-comp #:except 'chez-scheme ; procedure-specialize doesn't inline enough
'(let ()
(define (f x)
(procedure-specialize
(lambda (y) (+ x y))))
(procedure? (f 10)))
'#t)
(test-comp '(let ([f (procedure-specialize
(test-comp #:except 'chez-scheme ; procedure-specialize doesn't inline enough
'(let ([f (procedure-specialize
(lambda (y) (+ 1 y)))])
(list f (procedure-arity-includes? f 1)))
'(let ([f (procedure-specialize
@ -1827,7 +1858,8 @@
[y (cons 3 4)])
(list x x y)))
(test-comp '(let ([g (lambda (f)
(test-comp #:except 'chez-scheme ; schemify sequences references to `x` in second
'(let ([g (lambda (f)
(letrec-values ([(x y) (f (cons 1 2)
(cons 3 4))])
(let ([z x])
@ -1872,7 +1904,8 @@
'(lambda (p)
(values (unsafe-cdr p) (car p)))
#f)
(test-comp '(lambda (p)
(test-comp #:except 'chez-scheme ; schemify imposes order on car and cdr
'(lambda (p)
(define-values (x y) (values (car p) (cdr p)))
(values y x))
'(lambda (p)
@ -1887,7 +1920,8 @@
'(lambda (z)
(list (list (z 2)) (list z)))
#f)
(test-comp '(lambda (z)
(test-comp #:except 'chez-scheme ; schemify imposes order: `(z 2)` before `(list z)`
'(lambda (z)
(let-values ([(a b) (values (list (z 2)) (list z))])
(list a a b)))
'(lambda (z)
@ -1945,7 +1979,8 @@
(set! z 5)))
#f)
(test-comp '(lambda (z)
(test-comp #:except 'chez-scheme
'(lambda (z)
;; It's ok to reorder unsafe operations relative
;; to each other:
(let ([x (unsafe-fx+ z z)]
@ -1963,7 +1998,8 @@
(+ (unsafe-car z) (car z)))
#f)
(test-comp '(lambda (z v)
(test-comp #:except 'chez-scheme
'(lambda (z v)
;; It's ok to move an unsafe operation past a
;; safe one:
(let ([x (unsafe-car v)])
@ -1972,7 +2008,8 @@
(+ (car z) (unsafe-car v))))
;; Ok to reorder arithmetic that will not raise an error:
(test-comp '(lambda (x y)
(test-comp #:except 'chez-scheme
'(lambda (x y)
(if (and (real? x) (real? y))
(let ([w (+ x y)]
[z (- y x)])
@ -1988,7 +2025,8 @@
#t])
;; Inference of loop variable as number should allow
;; additions to be reordered:
(test-comp '(lambda ()
(test-comp #:except 'chez-scheme
'(lambda ()
(let loop ([n 0] [m 9])
(let ([a (+ n 9)]
[b (+ m 10)])
@ -2006,7 +2044,8 @@
(+ (values 2 2) (unbox b)))
#f)
(test-comp '(lambda (z)
(test-comp #:except 'chez-scheme
'(lambda (z)
(let-values ([(x y)
(if z
(values z (list z))
@ -2015,7 +2054,8 @@
'(lambda (z)
(list z (if z (list z) (box z)))))
(test-comp '(lambda (z)
(test-comp #:except 'chez-scheme
'(lambda (z)
(let-values ([(x y)
(if z
(values 1 1)
@ -2130,7 +2170,8 @@
0)
0)
(test-comp '(letrec ([foo (lambda () 12)]
(test-comp #:except 'chez-scheme ; same back-end result, anyway
'(letrec ([foo (lambda () 12)]
[goo (lambda () foo)])
goo)
'(let* ([foo (lambda () 12)]
@ -2161,7 +2202,8 @@
(parameterize ([compile-context-preservation-enabled
;; Avoid different amounts of unrolling
#t])
(test-comp '(letrec ((even
(test-comp #:except 'chez-scheme ;; !! schemify is not good enough here?
'(letrec ((even
(let ([unused 6])
(let ([even (lambda (x) (if (zero? x) #t (even (sub1 x))))])
(values even)))))
@ -2208,11 +2250,16 @@
(define h (+ a a))
(define (y) (x))
(list (x) (y) h))
(if (eq? 'chez-scheme (system-type 'vm))
'(lambda (a)
(letrec ([x (lambda () (x))])
(define h (+ a a))
(list (x) (x) h)))
'(lambda (a)
(define h (+ a a))
(letrec ([x (lambda () (y))]
[y (lambda () (x))])
(list (x) (y) h)))))
(list (x) (y) h))))))
(test-comp '(lambda (f a)
(define x (f y))
@ -2249,7 +2296,8 @@
[(p) (q)])
(list x y z))))
(test-comp '(lambda (f a)
(test-comp #:except 'chez-scheme ;; !! schemify is not good enough here
'(lambda (f a)
(letrec ([y (if (zero? a)
(error "no")
8)]
@ -2266,9 +2314,11 @@
'(procedure? add1))
(test-comp '(lambda () #t)
'(lambda () (procedure? add1)))
(test-comp #t
(test-comp #:except 'chez-scheme
#t
'(procedure? (lambda (x) x)))
(test-comp '(lambda () #t)
(test-comp #:except 'chez-scheme
'(lambda () #t)
'(lambda () (procedure? (lambda (x) x))))
(test-comp #f
'(pair? (lambda (x) x)))
@ -2280,7 +2330,8 @@
88))
'(let ([f (lambda (x) x)])
(list f)))
(test-comp '(let ([f (lambda (x) x)])
(test-comp #:except 'chez-scheme
'(let ([f (lambda (x) x)])
(list
f
f
@ -2303,11 +2354,13 @@
(test-comp '(lambda (x) #f)
'(lambda (x) (pair? (if x car cdr))))
(test-comp '(lambda (x) #t)
(test-comp #:except 'chez-scheme
'(lambda (x) #t)
'(lambda (x) (procedure? (if x car cdr))))
(test-comp '(lambda (x) #t)
'(lambda (x) (fixnum? (if x 2 3))))
(test-comp '(lambda (x) #f)
(test-comp #:except 'chez-scheme
'(lambda (x) #f)
'(lambda (x) (procedure? (if x 2 3))))
(test-comp '(lambda ()
@ -2377,7 +2430,8 @@
'(module m racket/base
(printf "pre\n")))
(test-comp '(module out racket/base
(test-comp #:except 'chez-scheme ; test harness `get-module-info` is not smart enough
'(module out racket/base
(module in racket/base
(provide inlinable-function)
(define inlinable-function (lambda (x) (list 1 x 3))))
@ -2390,7 +2444,8 @@
(require 'in)
(lambda () (display (inlinable-function 2)) (inlinable-function 2))))
(test-comp '(module out racket/base
(test-comp #:except 'chez-scheme ; test harness `get-module-info` is not smart enough
'(module out racket/base
(module in racket/base
(provide inlinable-function)
(define inlinable-function (lambda (x) (list 1 x 3))))
@ -2406,7 +2461,8 @@
(let ([try-equiv
(lambda (extras)
(lambda (a b)
(test-comp `(module m racket/base
(test-comp #:except 'chez-scheme ; apply is not primitive
`(module m racket/base
(define (f x)
(apply x ,@extras ,a)))
`(module m racket/base
@ -2447,6 +2503,7 @@
(define (q x)
(+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ x 10))))))))))))))
(unless (eq? 'chez-scheme (system-type 'vm)) ; procedures are not primitivee
(let ([check (lambda (proc arities non-arities)
(test-comp `(procedure? ,proc)
#t)
@ -2508,7 +2565,7 @@
#f)
(test-comp '(lambda () (procedure-arity-includes? (begin (random) car) 2))
'(lambda () #f)
#f)
#f))
(test-comp '(lambda ()
(let ([l '(1 2)])
@ -2534,7 +2591,8 @@
(test-multi 'list)
(test-multi 'list*)
(test-multi 'vector)
(test-multi 'vector-immutable)))
(unless (eq? 'chez-scheme (system-type 'vm)) ; !! vector-immutable is not primitive
(test-multi 'vector-immutable))))
(test-comp `(let ([x 5])
(let ([y (list*)])
x))
@ -2575,15 +2633,18 @@
(test-pred 'keyword?)
(test-pred 'string?)
(test-pred 'bytes?)
(test-pred 'path?)
(unless (eq? 'chez-scheme (system-type 'vm))
(test-pred 'path?))
(test-pred 'char?)
(test-pred 'k:interned-char?)
(test-pred 'boolean?)
(test-pred 'chaperone?)
(test-pred 'impersonator?)
(test-pred 'procedure?)
(unless (eq? 'chez-scheme (system-type 'vm))
(test-pred 'procedure?))
(test-pred 'eof-object?)
(test-pred 'immutable?)
(unless (eq? 'chez-scheme (system-type 'vm))
(test-pred 'immutable?))
(test-pred 'not)
(test-pred 'k:true-object?))
@ -2623,15 +2684,17 @@
(test-implies 'null? 'k:list-pair? '!=)
(test-implies 'null? 'pair? '!=)
(test-implies 'null? 'list?)
(unless (eq? 'chez-scheme (system-type 'vm))
(test-implies 'k:list-pair? 'pair?)
(test-implies 'k:list-pair? 'list?)
(test-implies 'k:list-pair? 'list?))
(test-implies 'list? 'pair? '?)
(test-implies 'k:interned-char? 'char?)
(test-implies 'not 'boolean?)
(test-implies 'k:true-object? 'boolean?)
)
(test-comp '(lambda (z)
(test-comp #:except 'chez-scheme
'(lambda (z)
(when (and (list? z)
(pair? z))
(k:list-pair? z)))
@ -2639,7 +2702,8 @@
(when (and (list? z)
(pair? z))
#t)))
(test-comp '(lambda (z)
(test-comp #:except 'chez-scheme
'(lambda (z)
(when (and (list? z)
(not (null? z)))
(k:list-pair? z)))
@ -2647,7 +2711,8 @@
(when (and (list? z)
(not (null? z)))
#t)))
(test-comp '(lambda (z)
(test-comp #:except 'chez-scheme
'(lambda (z)
(when (and (list? z)
(not (pair? z)))
(null? z)))
@ -2655,7 +2720,8 @@
(when (and (list? z)
(not (pair? z)))
#t)))
(test-comp '(lambda (z)
(test-comp #:except 'chez-scheme
'(lambda (z)
(when (and (list? z)
(not (k:list-pair? z)))
(null? z)))
@ -2663,7 +2729,8 @@
(when (and (list? z)
(not (k:list-pair? z)))
#t)))
(test-comp '(lambda (z)
(test-comp #:except 'chez-scheme
'(lambda (z)
(when (and (boolean? z)
(not (k:true-object? z)))
(not z)))
@ -2671,7 +2738,8 @@
(when (and (boolean? z)
(not (k:true-object? z)))
#t)))
(test-comp '(lambda (z)
(test-comp #:except 'chez-scheme
'(lambda (z)
(when (and (boolean? z)
(not (not z)))
(k:true-object? z)))
@ -2731,6 +2799,7 @@
(test-reduce 'pair? '(cdr (list 1 2)))
(test-reduce 'pair? '(cdr (list 1)) #f)
(unless (eq? 'chez-scheme (system-type 'vm))
(test-reduce 'k:list-pair? 0 #f)
(test-reduce 'k:list-pair? ''() #f)
(test-reduce 'k:list-pair? ''(1))
@ -2743,7 +2812,7 @@
(test-reduce 'k:list-pair? '(cons 1 null))
(test-reduce 'k:list-pair? '(cons 1 (list 2 3)))
(test-reduce 'k:list-pair? '(cdr (list 1 2)))
(test-reduce 'k:list-pair? '(cdr (list 1)) #f)
(test-reduce 'k:list-pair? '(cdr (list 1)) #f))
)
(test-comp '(lambda (z)
@ -5434,7 +5503,9 @@
(if (zero? v)
(let ([vec (make-vector 6)])
(vector-set-performance-stats! vec (current-thread))
(vector-ref vec 3))
(if (eq? 'chez-scheme (system-type 'vm))
0
(vector-ref vec 3)))
(s? (sub1 v)))))
(void (f 5)) ; JIT decides that `s?' is a struct predicate
@ -5444,7 +5515,9 @@
(define init-size
(let ([vec (make-vector 6)])
(vector-set-performance-stats! vec (current-thread))
(vector-ref vec 3)))
(if (eq? 'chez-scheme (system-type 'vm))
0
(vector-ref vec 3))))
(define size (f 500000)) ; make sure that this still leads to a tail loop
((- size init-size) . < . 20000)))
@ -5454,7 +5527,7 @@
;; make sure sfs pass doesn't add a nested begin0
;; to clear the variables used in the first expression
(let ()
(unless (eq? 'chez-scheme (system-type 'vm))
(define c
'(module c racket/base
(define z (let ([result (random)])
@ -5674,7 +5747,7 @@
;; Make sure the compiler unboxes the `v'
;; argument in the loop below:
(let ()
(unless (eq? 'chez-scheme (system-type 'vm))
(define l '(module m racket/base
(require racket/flonum)
(define (f)
@ -5701,7 +5774,7 @@
;; Make sure the compiler doesn't add a check for whether
;; `later` is defined in the body of `kw-proc`:
(let ()
(unless (eq? 'chez-scheme (system-type 'vm))
(define l '(module m racket/base
(define (kw-proc x #:optional [optional 0])
(later))
@ -5719,7 +5792,7 @@
[v (application-rator (lam-body b))])
(test #t toplevel-const? v)))
(let ()
(unless (eq? 'chez-scheme (system-type 'vm))
(define l '(module m racket/base
(struct s (x))
(define (kw-proc x #:optional [optional 0])
@ -5743,7 +5816,7 @@
;; Originally: The validator should understand that a structure
;; constructor always succeeds:
(let ()
(unless (eq? 'chez-scheme (system-type 'vm))
(define (go sub)
(let ([e `(module m racket/base
(provide bar)

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

File diff suppressed because it is too large Load Diff

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

File diff suppressed because it is too large Load Diff

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

@ -2027,19 +2027,19 @@
(if (struct-type? struct:known-accessor)
struct:known-accessor
(check-struct-type 'struct struct:known-accessor))
2
4
0
#f
'(0 1))
'(0 1 2 3))
#f
#f
2
3))
(define effect_1804
4
15))
(define effect_2706
(struct-type-install-properties!
struct:known-field-accessor
'known-field-accessor
2
4
0
(if (struct-type? struct:known-accessor)
struct:known-accessor
@ -2047,7 +2047,7 @@
null
'prefab
#f
'(0 1)
'(0 1 2 3)
#f
'known-field-accessor))
(define known-field-accessor
@ -2087,24 +2087,60 @@
s
'known-field-accessor
'type-id))))))
(define known-field-accessor-pos_2286
(define known-field-accessor-authentic?_2286
(|#%name|
known-field-accessor-authentic?
(record-accessor struct:known-field-accessor 1)))
(define known-field-accessor-authentic?
(|#%name|
known-field-accessor-authentic?
(lambda (s)
(if (known-field-accessor?_2878 s)
(known-field-accessor-authentic?_2286 s)
($value
(impersonate-ref
known-field-accessor-authentic?_2286
struct:known-field-accessor
1
s
'known-field-accessor
'authentic?))))))
(define known-field-accessor-pos_2482
(|#%name|
known-field-accessor-pos
(record-accessor struct:known-field-accessor 1)))
(record-accessor struct:known-field-accessor 2)))
(define known-field-accessor-pos
(|#%name|
known-field-accessor-pos
(lambda (s)
(if (known-field-accessor?_2878 s)
(known-field-accessor-pos_2286 s)
(known-field-accessor-pos_2482 s)
($value
(impersonate-ref
known-field-accessor-pos_2286
known-field-accessor-pos_2482
struct:known-field-accessor
1
2
s
'known-field-accessor
'pos))))))
(define known-field-accessor-known-immutable?_2377
(|#%name|
known-field-accessor-known-immutable?
(record-accessor struct:known-field-accessor 3)))
(define known-field-accessor-known-immutable?
(|#%name|
known-field-accessor-known-immutable?
(lambda (s)
(if (known-field-accessor?_2878 s)
(known-field-accessor-known-immutable?_2377 s)
($value
(impersonate-ref
known-field-accessor-known-immutable?_2377
struct:known-field-accessor
3
s
'known-field-accessor
'known-immutable?))))))
(define struct:known-field-mutator
(make-record-type-descriptor*
'known-field-mutator
@ -2116,19 +2152,19 @@
(if (struct-type? struct:known-mutator)
struct:known-mutator
(check-struct-type 'struct struct:known-mutator))
2
3
0
#f
'(0 1))
'(0 1 2))
#f
#f
2
3))
(define effect_2511
3
7))
(define effect_3046
(struct-type-install-properties!
struct:known-field-mutator
'known-field-mutator
2
3
0
(if (struct-type? struct:known-mutator)
struct:known-mutator
@ -2136,7 +2172,7 @@
null
'prefab
#f
'(0 1)
'(0 1 2)
#f
'known-field-mutator))
(define known-field-mutator
@ -2176,21 +2212,39 @@
s
'known-field-mutator
'type-id))))))
(define known-field-mutator-pos_2735
(define known-field-mutator-authentic?_2735
(|#%name|
known-field-mutator-authentic?
(record-accessor struct:known-field-mutator 1)))
(define known-field-mutator-authentic?
(|#%name|
known-field-mutator-authentic?
(lambda (s)
(if (known-field-mutator?_2222 s)
(known-field-mutator-authentic?_2735 s)
($value
(impersonate-ref
known-field-mutator-authentic?_2735
struct:known-field-mutator
1
s
'known-field-mutator
'authentic?))))))
(define known-field-mutator-pos_2749
(|#%name|
known-field-mutator-pos
(record-accessor struct:known-field-mutator 1)))
(record-accessor struct:known-field-mutator 2)))
(define known-field-mutator-pos
(|#%name|
known-field-mutator-pos
(lambda (s)
(if (known-field-mutator?_2222 s)
(known-field-mutator-pos_2735 s)
(known-field-mutator-pos_2749 s)
($value
(impersonate-ref
known-field-mutator-pos_2735
known-field-mutator-pos_2749
struct:known-field-mutator
1
2
s
'known-field-mutator
'pos))))))

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

@ -2014,7 +2014,8 @@
rx1_0
(if (if (rx:range? rx1_0) (rx:range? rx2_0) #f)
(rx-range
(range-union (rx:range-range rx1_0) (rx:range-range rx2_0))
(let ((app_0 (rx:range-range rx1_0)))
(range-union app_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)
@ -2210,26 +2211,36 @@
(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
(parse-config-who config_0)
(parse-config-px? config_0)
app_0
app_1
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))
app_2
app_3
app_4
(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
(parse-config-who config_0)
(parse-config-px? config_0)
(parse-config-case-sensitive? config_0)
app_0
app_1
app_2
mm?_0
(parse-config-group-number-box config_0)
(parse-config-references?-box config_0)
(parse-config-error-handler? config_0))
app_3
app_4
(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))))
@ -4029,11 +4040,13 @@
(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
(rx:repeat-min rx_0)
(rx:repeat-max rx_0)
(rx:repeat-non-greedy? rx_0)))
app_0
app_1
(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)
@ -4049,14 +4062,18 @@
(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
(rx:conditional-n-start rx_0)
(rx:conditional-num-n rx_0)
app_0
app_1
(rx:conditional-needs-backtrack?
rx_0))))))
rx_0))))))))
(raise-argument-error
'struct-copy
"rx:conditional?"
@ -4064,11 +4081,13 @@
(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
(rx:lookahead-match? rx_0)
(rx:lookahead-n-start rx_0)
(rx:lookahead-num-n rx_0)))
app_0
app_1
(rx:lookahead-num-n rx_0)))))
(raise-argument-error
'struct-copy
"rx:lookahead?"
@ -4077,13 +4096,19 @@
(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
(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)))
app_0
app_1
app_2
app_3
(rx:lookbehind-num-n rx_0)))))))
(raise-argument-error
'struct-copy
"rx:lookbehind?"
@ -4091,11 +4116,13 @@
(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
(rx:cut-n-start rx_0)
(rx:cut-num-n rx_0)
(rx:cut-needs-backtrack? rx_0)))
app_0
app_1
(rx:cut-needs-backtrack? rx_0)))))
(raise-argument-error
'struct-copy
"rx:cut?"
@ -4995,13 +5022,14 @@
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
(lazy-bytes-progress-evt s_0)
app_2
(lazy-bytes-in s_0)
len_0)))))
len_0))))))
(if (eof-object? n_0)
#f
(if (not (fixnum? n_0))
@ -6904,15 +6932,15 @@
(let ((min_0
(rx:repeat-min
rx_1)))
(let ((max_0
(let ((n_0
(rx:repeat-max
rx_1)))
(let ((max_0
(if (=
n_0
+inf.0)
#f
n_0)))
n_0))))
(let ((r-m*_0
(compile*/maybe
r-rx_0
@ -6959,22 +6987,23 @@
r-m_0
min_0
max_0
next-m_0)))))))))))))
next-m_0))))))))))))
(if (rx:group? rx_1)
(let ((n_0
(rx:group-number
rx_1)))
(let ((app_0
(rx:group-rx rx_1)))
(let ((m_0
(let ((app_0
(rx:group-rx
rx_1)))
(compile_0
app_0
(group-set-matcher
n_0
next-m_0))))
next-m_0)))))
(group-push-matcher
n_0
m_0))))
m_0)))
(if (rx:reference? rx_1)
(let ((n_0
(rx:reference-n
@ -6994,11 +7023,14 @@
(compile_0
(rx:cut-rx rx_1)
done-m)))
(let ((app_1
(rx:cut-n-start
rx_1)))
(cut-matcher
app_0
(rx:cut-n-start rx_1)
app_1
(rx:cut-num-n rx_1)
next-m_0))
next-m_0)))
(if (rx:conditional? rx_1)
(let ((tst_0
(rx:conditional-tst
@ -7027,14 +7059,16 @@
(compile_0
tst_0
done-m)))
(let ((app_1
(rx:conditional-n-start
rx_1)))
(conditional/look-matcher
app_0
m1_0
m2_0
(rx:conditional-n-start
rx_1)
app_1
(rx:conditional-num-n
rx_1)))))))
rx_1))))))))
(if (rx:lookahead? rx_1)
(let ((app_0
(rx:lookahead-match?
@ -7044,14 +7078,16 @@
(rx:lookahead-rx
rx_1)
done-m)))
(let ((app_2
(rx:lookahead-n-start
rx_1)))
(lookahead-matcher
app_0
app_1
(rx:lookahead-n-start
rx_1)
app_2
(rx:lookahead-num-n
rx_1)
next-m_0)))
next-m_0))))
(if (rx:lookbehind?
rx_1)
(let ((app_0
@ -7068,24 +7104,28 @@
(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
(rx:lookbehind-n-start
rx_1)
app_4
(rx:lookbehind-num-n
rx_1)
next-m_0)))))
next-m_0))))))
(if (rx:unicode-categories?
rx_1)
(unicode-categories-matcher
(let ((app_0
(rx:unicode-categories-symlist
rx_1)
rx_1)))
(unicode-categories-matcher
app_0
(rx:unicode-categories-match?
rx_1)
next-m_0)
next-m_0))
(error
'compile/bt
"internal error: unrecognized ~s"
@ -7104,7 +7144,7 @@
#f))))))
(define struct:rx:regexp
(make-record-type-descriptor* 'regexp #f #f #f #f 10 0))
(define effect_2629
(define effect_2093
(struct-type-install-properties!
struct:rx:regexp
'regexp
@ -7116,8 +7156,9 @@
prop:equal+hash
(list
(lambda (a_0 b_0 eql?_0)
(if (eq? (rx:regexp-px? a_0) (rx:regexp-px? b_0))
(equal? (rx:regexp-source a_0) (rx:regexp-source b_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)))
#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)))))
@ -8099,8 +8140,9 @@
(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)))
(let ((state_0 (if (positive? n_0) (make-vector n_0 #f) #f)))
(if (positive? n_0) (make-vector n_0 #f) #f))))
(call-with-values
(lambda ()
(search-match
@ -8118,7 +8160,7 @@
(cons app_0 (vector->list state_0)))
(list (cons ms-pos_0 me-pos_0)))
#f))
(args (raise-binding-result-arity-error 2 args))))))))
(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
@ -8127,8 +8169,9 @@
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)))
(let ((state_0 (if (positive? n_0) (make-vector n_0 #f) #f)))
(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))
@ -8190,11 +8233,12 @@
(args (raise-binding-result-arity-error 2 args)))))
null)))
#f)))
(args (raise-binding-result-arity-error 2 args)))))))))
(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)))
(let ((state_0 (if (positive? n_0) (make-vector n_0 #f) #f)))
(if (positive? n_0) (make-vector n_0 #f) #f))))
(call-with-values
(lambda ()
(search-match
@ -8249,7 +8293,7 @@
(args (raise-binding-result-arity-error 2 args)))))
null)))
#f))
(args (raise-binding-result-arity-error 2 args))))))))
(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
@ -8258,16 +8302,16 @@
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)))
(let ((state_0 (if (positive? n_0) (make-vector n_0 #f) #f)))
(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)))
(let ((app_0 (bytes->string/utf-8 in_0 '#\x3f ms-pos_0 me-pos_0)))
(cons
app_0
(if state_0
@ -8288,8 +8332,7 @@
(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 ((p_0 (unsafe-vector-ref vec_0 pos_0)))
(let ((fold-var_1
(let ((fold-var_1
(cons
@ -8311,7 +8354,7 @@
(args (raise-binding-result-arity-error 2 args)))))
null)))
#f))
(args (raise-binding-result-arity-error 2 args)))))))))
(args (raise-binding-result-arity-error 2 args))))))))
(define drive-regexp-match.1
(|#%name|
drive-regexp-match

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

File diff suppressed because it is too large Load Diff

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

@ -1090,10 +1090,12 @@
(lambda (q_0 n_0)
(begin
(if (node-prev$1 n_0)
(set-node-next!$1 (node-prev$1 n_0) (node-next$1 n_0))
(let ((app_0 (node-prev$1 n_0)))
(set-node-next!$1 app_0 (node-next$1 n_0)))
(set-queue-start! q_0 (node-next$1 n_0)))
(if (node-next$1 n_0)
(set-node-prev!$1 (node-next$1 n_0) (node-prev$1 n_0))
(let ((app_0 (node-next$1 n_0)))
(set-node-prev!$1 app_0 (node-prev$1 n_0)))
(set-queue-end! q_0 (node-prev$1 n_0))))))
(define internal-error
(lambda (s_0)
@ -1333,24 +1335,18 @@
(if (|#%app| <?_0 (node-key t_0) key_0)
(insert-to t_0 key_0 val_0 <?_0 node-right node-left reverse-combine)
(if (node?$1 t_0)
(node1.1$1
(node-key t_0)
val_0
(node-height t_0)
(node-left t_0)
(node-right t_0))
(let ((app_0 (node-key t_0)))
(let ((app_1 (node-height t_0)))
(let ((app_2 (node-left t_0)))
(node1.1$1 app_0 val_0 app_1 app_2 (node-right t_0)))))
(raise-argument-error 'struct-copy "node?" t_0)))))))
(define insert-to
(lambda (t_0 new-key_0 new-val_0 <?_0 node-to_0 node-other_0 comb_0)
(let ((new-to_0 (insert (|#%app| node-to_0 t_0) new-key_0 new-val_0 <?_0)))
(let ((new-other_0 (|#%app| node-other_0 t_0)))
(let ((new-t_0
(|#%app|
comb_0
(node-key t_0)
(node-val t_0)
new-to_0
new-other_0)))
(let ((app_0 (node-key t_0)))
(|#%app| comb_0 app_0 (node-val t_0) new-to_0 new-other_0))))
(check-rotate new-t_0 node-to_0 node-other_0 comb_0))))))
(define check-rotate
(lambda (new-t_0 node-to_0 node-other_0 comb_0)
@ -1391,12 +1387,13 @@
comb_0
app_2
app_3
(let ((app_4 (node-key orange_0)))
(|#%app|
comb_0
(node-key orange_0)
app_4
(node-val orange_0)
A_0
B_0)
B_0))
C_0)))
D_0)))
node-to_0
@ -1485,12 +1482,12 @@
(define min-key+value
(lambda (t_0)
(if (not (node-left t_0))
(values (node-key t_0) (node-val t_0))
(let ((app_0 (node-key t_0))) (values app_0 (node-val t_0)))
(min-key+value (node-left t_0)))))
(define max-key+value
(lambda (t_0)
(if (not (node-right t_0))
(values (node-key t_0) (node-val t_0))
(let ((app_0 (node-key t_0))) (values app_0 (node-val t_0)))
(max-key+value (node-right t_0)))))
(define struct:sandman
(make-record-type-descriptor*
@ -4504,10 +4501,12 @@
(begin
(begin-unsafe (void))
(if (node-next n_0)
(set-node-prev! (node-next n_0) (node-prev n_0))
(let ((app_0 (node-next n_0)))
(set-node-prev! app_0 (node-prev n_0)))
(set-thread-group-chain-end! parent_0 (node-prev n_0)))
(if (node-prev n_0)
(set-node-next! (node-prev n_0) (node-next n_0))
(let ((app_0 (node-prev n_0)))
(set-node-next! app_0 (node-next n_0)))
(set-thread-group-chain-start! parent_0 (node-next n_0)))
(if (eq? n_0 (thread-group-chain parent_0))
(set-thread-group-chain! parent_0 (node-next n_0))
@ -5160,15 +5159,14 @@
(|#%app| host:make-will-executor void))
#f)))
(begin
(let ((app_0 (custodian-children cust14_0)))
(hash-set!
app_0
(custodian-children cust14_0)
obj15_0
(if weak?7_0
callback16_0
(if at-exit?6_0
(at-exit-callback3.1 callback16_0 we_0)
(willed-callback2.1 callback16_0 we_0)))))
(willed-callback2.1 callback16_0 we_0))))
(if we_0
(|#%app| host:will-register we_0 obj15_0 void)
(void))
@ -5338,9 +5336,8 @@
(hash-clear! (custodian-children c_0))
(set-custodian-post-shutdown!
parent_0
(append
(custodian-post-shutdown c_0)
(custodian-post-shutdown parent_0)))
(let ((app_0 (custodian-post-shutdown c_0)))
(append app_0 (custodian-post-shutdown parent_0))))
(set-custodian-post-shutdown! c_0 null)
(if gc-roots_0 (hash-clear! gc-roots_0) (void))
(check-limit-custodian parent_0)))))))))))
@ -5905,7 +5902,7 @@
(define memory-limit-lock (|#%app| host:make-mutex))
(define compute-memory-sizes 0)
(define computed-memory-sizes? #f)
(define effect_2285
(define effect_2497
(begin
(void
(|#%app|
@ -5942,11 +5939,11 @@
(if gc-roots_0
(hash-keys gc-roots_0)
null)))
(let ((pl_1 (custodian-place c_0)))
(let ((host-regs_0
(let ((pl_1 (custodian-place c_0)))
(if (eq? (place-custodian pl_1) c_0)
(list pl_1)
null)))
null))))
(letrec*
((loop_0
(|#%name|
@ -5999,8 +5996,7 @@
(append
local-custs_0
accum-custs_1))))
(if (1/custodian?
(car roots_1))
(if (1/custodian? (car roots_1))
(call-with-values
(lambda ()
(c-loop_0
@ -6020,23 +6016,23 @@
2
args))))
(if (1/place? (car roots_1))
(let ((pl_2 (car roots_1)))
(let ((pl_1 (car roots_1)))
(let ((c_1
(place-custodian
pl_2)))
pl_1)))
(begin
(let ((app_0
future-scheduler-add-thread-custodian-mapping!))
(|#%app|
app_0
(place-future-scheduler
pl_2)
pl_1)
custodian-future-threads_0))
(call-with-values
(lambda ()
(c-loop_0
c_1
pl_2
pl_1
accum-roots_1
accum-custs_1))
(case-lambda
@ -6051,8 +6047,7 @@
(raise-binding-result-arity-error
2
args)))))))
(let ((root_0
(car roots_1)))
(let ((root_0 (car roots_1)))
(let ((new-local-roots_0
(cons
root_0
@ -6097,7 +6092,7 @@
roots_0
(cons c_0 host-regs_0)
accum-roots_0
accum-custs_0))))))))))))
accum-custs_0)))))))))))
(c-loop_0
initial-place-root-custodian
initial-place
@ -6189,11 +6184,13 @@
(begin
(set-custodian-memory-use!
c_0
(let ((app_0
(custodian-memory-use
next-c_0)))
(+
app_0
(custodian-memory-use
next-c_0)
(custodian-memory-use
c_0)))
c_0))))
(if root-any-limits?_0
root-any-limits?_0
any-limits?_0))))))
@ -6635,13 +6632,13 @@
(if b_0 (if (unbox b_0) #t #f) #f))))
(define set-thread-suspended?!
(lambda (t_0 suspended?_0)
(let ((or-part_0 (thread-suspended-box t_0)))
(let ((b_0
(let ((or-part_0 (thread-suspended-box t_0)))
(if or-part_0
or-part_0
(let ((b_0 (box #f)))
(begin (set-thread-suspended-box! t_0 b_0) b_0)))))
(set-box! b_0 (if suspended?_0 t_0 #f))))))
(begin (set-thread-suspended-box! t_0 b_0) b_0))))))
(set-box! b_0 (if suspended?_0 t_0 #f)))))
(define 1/thread-running?
(|#%name|
thread-running?
@ -7228,9 +7225,10 @@
(begin
(set-thread-suspended?! b-t_0 (thread-suspended? b-t_0))
(list
(let ((app_0 (make-weak-box b-t_0)))
(transitive-resume16.1
(make-weak-box b-t_0)
(thread-suspended-box b-t_0))))
app_0
(thread-suspended-box b-t_0)))))
(let ((o-t_0
(weak-box-value
(transitive-resume-weak-box (car l_0)))))
@ -7272,7 +7270,8 @@
(let ((t_0 (current-thread/in-atomic)))
(set-thread-suspend+resume-callbacks!
t_0
(cons (cons s-cb_0 r-cb_0) (thread-suspend+resume-callbacks t_0))))))
(let ((app_0 (cons s-cb_0 r-cb_0)))
(cons app_0 (thread-suspend+resume-callbacks t_0)))))))
(define thread-pop-suspend+resume-callbacks!
(lambda ()
(let ((t_0 (current-thread/in-atomic)))
@ -7619,13 +7618,13 @@
#f)
#f)
#f)
(let ((tmp_0 (thread-pending-break t_0)))
(let ((exn:break*_0
(let ((tmp_0 (thread-pending-break t_0)))
(if (eq? tmp_0 'hang-up)
exn:break:hang-up/non-engine
(if (eq? tmp_0 'terminate)
exn:break:terminate/non-engine
exn:break/non-engine))))
exn:break/non-engine)))))
(begin
(set-thread-pending-break! t_0 #f)
(lambda ()
@ -7636,7 +7635,7 @@
exn:break*_0
"user break"
(current-continuation-marks)
k_0))))))))
k_0)))))))
void)
(end-atomic))))
(void))))))))
@ -8041,7 +8040,7 @@
'put-queue))))))
(define struct:channel-put-evt*
(make-record-type-descriptor* 'channel-put-evt #f #f #f #f 2 0))
(define effect_2675
(define effect_2694
(struct-type-install-properties!
struct:channel-put-evt*
'channel-put-evt
@ -8053,11 +8052,12 @@
1/prop:evt
(poller2.1
(lambda (cp_0 poll-ctx_0)
(let ((app_0 (channel-put-evt*-ch cp_0)))
(channel-put/poll
(channel-put-evt*-ch cp_0)
app_0
(channel-put-evt*-v cp_0)
cp_0
poll-ctx_0)))))
poll-ctx_0))))))
(current-inspector)
#f
'(0 1)
@ -8239,10 +8239,9 @@
(values #f ch_0)
(let ((b_0 (box #f)))
(let ((gq_0 (channel-get-queue ch_0)))
(let ((app_0 (poll-ctx-select-proc poll-ctx_0)))
(let ((gw_0
(channel-select-waiter3.1
app_0
(poll-ctx-select-proc poll-ctx_0)
(current-thread/in-atomic))))
(let ((n_0 (queue-add! gq_0 (cons gw_0 b_0))))
(values
@ -8269,7 +8268,7 @@
(values #t #t))
(begin
(set! n_0 (queue-add! gq_0 (cons gw_0 b_0)))
(values #f #f))))))))))))))))))
(values #f #f)))))))))))))))))
(define channel-put
(lambda (ch_0 v_0)
(begin
@ -8321,10 +8320,9 @@
(if (poll-ctx-poll? poll-ctx_0)
(values #f self_0)
(let ((pq_0 (channel-put-queue ch_0)))
(let ((app_0 (poll-ctx-select-proc poll-ctx_0)))
(let ((pw_0
(channel-select-waiter3.1
app_0
(poll-ctx-select-proc poll-ctx_0)
(current-thread/in-atomic))))
(let ((n_0 (queue-add! pq_0 (cons pw_0 v_0))))
(values
@ -8336,9 +8334,7 @@
void
(lambda ()
(let ((gw+b_1
(queue-fremove!
gq_0
not-matching-select-waiter)))
(queue-fremove! gq_0 not-matching-select-waiter)))
(if gw+b_1
(begin
(set-box! (cdr gw+b_1) v_0)
@ -8351,7 +8347,7 @@
(values self_0 #t))
(begin
(set! n_0 (queue-add! pq_0 (cons pw_0 v_0)))
(values #f #f)))))))))))))))))
(values #f #f))))))))))))))))
(define 1/channel-put-evt
(|#%name|
channel-put-evt
@ -8374,7 +8370,8 @@
(|#%app| channel-put_0 old-ch_0 new-v_0))))))
(define channel-put-do
(lambda (v_0)
(channel-put (channel-put-evt*-ch v_0) (channel-put-evt*-v v_0))))
(let ((app_0 (channel-put-evt*-ch v_0)))
(channel-put app_0 (channel-put-evt*-v v_0)))))
(define not-matching-select-waiter
(lambda (w+b/v_0)
(let ((w_0 (car w+b/v_0)))
@ -9628,10 +9625,12 @@
(lambda (sr_0 s_0)
(begin
(if (syncer-prev sr_0)
(set-syncer-next! (syncer-prev sr_0) (syncer-next sr_0))
(let ((app_0 (syncer-prev sr_0)))
(set-syncer-next! app_0 (syncer-next sr_0)))
(set-syncing-syncers! s_0 (syncer-next sr_0)))
(if (syncer-next sr_0)
(set-syncer-prev! (syncer-next sr_0) (syncer-prev sr_0))
(let ((app_0 (syncer-next sr_0)))
(set-syncer-prev! app_0 (syncer-prev sr_0)))
(void)))))
(define syncer-replace!
(lambda (sr_0 new-syncers_0 s_0)
@ -9812,15 +9811,23 @@
app_0
(let ((app_1
evts->syncers))
(let ((app_2
(choice-evt-evts
new-evt_0)))
(let ((app_3
(syncer-wraps
sr_0)))
(let ((app_4
(syncer-commits
sr_0)))
(|#%app|
app_1
#f
(choice-evt-evts
new-evt_0)
(syncer-wraps sr_0)
(syncer-commits sr_0)
app_2
app_3
app_4
(syncer-abandons
sr_0)))))))
sr_0))))))))))
(if (not new-syncers_0)
(begin
(syncer-remove! sr_0 s32_0)
@ -10294,17 +10301,17 @@
(let ((ns_0 (unsafe-car lst_0)))
(let ((rest_0 (unsafe-cdr lst_0)))
(let ((result_1
(syncing-selected ns_0)))
(let ((result_2
(values result_1)))
(let ((result_1
(syncing-selected
ns_0)))
(values result_1))))
(if (if (not
(let ((x_0
(list ns_0)))
result_2))
(let ((x_0 (list ns_0)))
result_1))
#t
#f)
(for-loop_0 result_2 rest_0)
result_2)))))
(for-loop_0 result_1 rest_0)
result_1))))
result_0))))))
(for-loop_0 #f nss_0)))))
void
@ -10488,8 +10495,8 @@
(if (procedure? next_0)
(void)
(raise-argument-error 'replace-evt "procedure?" next_0))
(let ((orig-evt_0 unsafe-undefined))
(set! orig-evt_0
(letrec*
((orig-evt_0
(replacing-evt34.1
(lambda ()
(let ((s_0
@ -10504,7 +10511,7 @@
values
(lambda () (syncing-interrupt! s_0))
(lambda () (syncing-abandon! s_0))
(lambda () (syncing-retry! s_0))))))))
(lambda () (syncing-retry! s_0)))))))))
orig-evt_0)))))))
(define poll-nested-sync
(lambda (ns_0 just-poll?_0 fast-only?_0 sched-info_0)
@ -11675,10 +11682,12 @@
(if or-part_0 or-part_0 (future*-next f_0)))
(begin
(if (future*-prev f_0)
(set-future*-next! (future*-prev f_0) (future*-next f_0))
(let ((app_0 (future*-prev f_0)))
(set-future*-next! app_0 (future*-next f_0)))
(set-scheduler-futures-head! s_0 (future*-next f_0)))
(if (future*-next f_0)
(set-future*-prev! (future*-next f_0) (future*-prev f_0))
(let ((app_0 (future*-next f_0)))
(set-future*-prev! app_0 (future*-prev f_0)))
(set-scheduler-futures-tail! s_0 (future*-prev f_0)))
(set-future*-prev! f_0 #f)
(set-future*-next! f_0 #f))
@ -12302,9 +12311,10 @@
(if (pair? lst_0)
(let ((t_0 (unsafe-car lst_0)))
(let ((rest_0 (unsafe-cdr lst_0)))
(let ((sched-info_0 (thread-sched-info t_0)))
(let ((exts_1
(let ((exts_1
(let ((sched-info_0
(thread-sched-info t_0)))
(let ((t-exts_0
(if sched-info_0
(schedule-info-exts
@ -12315,9 +12325,9 @@
(sandman-do-merge-external-event-sets
the-sandman)
exts_0
t-exts_0)))))
t-exts_0))))))
(values exts_1))))
(for-loop_0 exts_1 rest_0)))))
(for-loop_0 exts_1 rest_0))))
exts_0))))))
(for-loop_0 sleeping-exts_0 ts_0)))))
(begin
@ -13678,10 +13688,11 @@
(let ((temp12_0
(place-id
new-place_0)))
(let ((temp11_1 temp11_0))
(log-place.1
unsafe-undefined
temp12_0
temp11_0)))
temp11_1))))
(values
new-place_0
parent-in_0
@ -13897,7 +13908,8 @@
(end-atomic)))
(let ((temp26_0 "reap"))
(let ((temp27_0 (place-id p_0)))
(log-place.1 unsafe-undefined temp27_0 temp26_0)))
(let ((temp26_1 temp26_0))
(log-place.1 unsafe-undefined temp27_0 temp26_1))))
(void))
(void))
(let ((cref_0 (place-custodian-ref p_0)))
@ -14631,18 +14643,18 @@
(lock-release (fsemaphore-lock fs_0))
(future-suspend)
(void))
(let ((or-part_0 (fsemaphore-dep-box fs_0)))
(let ((dep-box_0
(let ((or-part_0 (fsemaphore-dep-box fs_0)))
(if or-part_0
or-part_0
(let ((b_0 (box #f)))
(begin
(set-fsemaphore-dep-box! fs_0 b_0)
b_0)))))
b_0))))))
(begin
(lock-release (fsemaphore-lock fs_0))
(1/sync (fsemaphore-box-evt2.1 dep-box_0))
(1/fsemaphore-wait fs_0))))))
(1/fsemaphore-wait fs_0)))))
(begin
(set-fsemaphore-c! fs_0 (sub1 c_0))
(lock-release (fsemaphore-lock fs_0)))))))))))
@ -14698,14 +14710,14 @@
(void))))))
(define struct:os-semaphore
(make-record-type-descriptor* 'os-semaphore #f #f #f #f 3 1))
(define effect_2794
(define effect_3038
(struct-type-install-properties!
struct:os-semaphore
'os-semaphore
3
0
#f
null
(list (cons prop:authentic #t))
(current-inspector)
#f
'(1 2)
@ -14716,84 +14728,16 @@
os-semaphore
(record-constructor
(make-record-constructor-descriptor struct:os-semaphore #f #f))))
(define os-semaphore?_1935
(|#%name| os-semaphore? (record-predicate struct:os-semaphore)))
(define os-semaphore?
(|#%name|
os-semaphore?
(lambda (v)
(if (os-semaphore?_1935 v)
#t
($value
(if (impersonator? v)
(os-semaphore?_1935 (impersonator-val v))
#f))))))
(define os-semaphore-count_2300
(|#%name| os-semaphore-count (record-accessor struct:os-semaphore 0)))
(|#%name| os-semaphore? (record-predicate struct:os-semaphore)))
(define os-semaphore-count
(|#%name|
os-semaphore-count
(lambda (s)
(if (os-semaphore?_1935 s)
(os-semaphore-count_2300 s)
($value
(impersonate-ref
os-semaphore-count_2300
struct:os-semaphore
0
s
'os-semaphore
'count))))))
(define os-semaphore-mutex_3012
(|#%name| os-semaphore-mutex (record-accessor struct:os-semaphore 1)))
(|#%name| os-semaphore-count (record-accessor struct:os-semaphore 0)))
(define os-semaphore-mutex
(|#%name|
os-semaphore-mutex
(lambda (s)
(if (os-semaphore?_1935 s)
(os-semaphore-mutex_3012 s)
($value
(impersonate-ref
os-semaphore-mutex_3012
struct:os-semaphore
1
s
'os-semaphore
'mutex))))))
(define os-semaphore-condition_1733
(|#%name| os-semaphore-condition (record-accessor struct:os-semaphore 2)))
(|#%name| os-semaphore-mutex (record-accessor struct:os-semaphore 1)))
(define os-semaphore-condition
(|#%name|
os-semaphore-condition
(lambda (s)
(if (os-semaphore?_1935 s)
(os-semaphore-condition_1733 s)
($value
(impersonate-ref
os-semaphore-condition_1733
struct:os-semaphore
2
s
'os-semaphore
'condition))))))
(define set-os-semaphore-count!_2394
(|#%name| set-os-semaphore-count! (record-mutator struct:os-semaphore 0)))
(|#%name| os-semaphore-condition (record-accessor struct:os-semaphore 2)))
(define set-os-semaphore-count!
(|#%name|
set-os-semaphore-count!
(lambda (s v)
(if (os-semaphore?_1935 s)
(set-os-semaphore-count!_2394 s v)
($value
(impersonate-set!
set-os-semaphore-count!_2394
struct:os-semaphore
0
0
s
v
'os-semaphore
'count))))))
(|#%name| set-os-semaphore-count! (record-mutator struct:os-semaphore 0)))
(define 1/unsafe-make-os-semaphore
(|#%name|
unsafe-make-os-semaphore

11
racket/src/schemify/find-definition.rkt
View File

@ -45,9 +45,10 @@
(if (struct-type-info-pure-constructor? info)
(known-struct-constructor (arithmetic-shift 1 (struct-type-info-field-count info)) type struct:s)
a-known-constant))]
[authentic? (struct-type-info-authentic? info)]
[knowns (hash-set knowns
(unwrap s?)
(known-struct-predicate 2 type struct:s (struct-type-info-authentic? info)))]
(known-struct-predicate 2 type struct:s authentic?))]
[knowns
(let* ([immediate-count (struct-type-info-immediate-field-count info)]
[parent-count (- (struct-type-info-field-count info)
@ -62,10 +63,14 @@
(cond
[(and (wrap-eq? make 'make-struct-field-accessor)
(wrap-eq? ref-or-set -ref))
(hash-set knowns (unwrap id) (known-field-accessor 2 type struct:s (+ parent-count pos)))]
(define immutable? (memv pos (or (struct-type-info-prefab-immutables info)
(struct-type-info-non-prefab-immutables info)
'())))
(hash-set knowns (unwrap id) (known-field-accessor 2 type struct:s authentic? (+ parent-count pos)
immutable?))]
[(and (wrap-eq? make 'make-struct-field-mutator)
(wrap-eq? ref-or-set -set!))
(hash-set knowns (unwrap id) (known-field-mutator 4 type struct:s (+ parent-count pos)))]
(hash-set knowns (unwrap id) (known-field-mutator 4 type struct:s authentic? (+ parent-count pos)))]
[else knowns]))
knowns)]
[`,_ knowns])))])

3
racket/src/schemify/inline.rkt
View File

@ -277,7 +277,9 @@
(known-field-accessor/need-imports (known-procedure-arity-mask k)
(known-accessor-type k)
(known-field-accessor-type-id k)
(known-field-accessor-authentic? k)
(known-field-accessor-pos k)
(known-field-accessor-known-immutable? k)
(needed->list needed))]
[else
(known-accessor (known-procedure-arity-mask k)
@ -289,6 +291,7 @@
(known-field-mutator/need-imports (known-procedure-arity-mask k)
(known-mutator-type k)
(known-field-mutator-type-id k)
(known-field-mutator-authentic? k)
(known-field-mutator-pos k)
(needed->list needed))]
[else

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

@ -36,8 +36,10 @@
known-mutator known-mutator? known-mutator-type
known-struct-constructor known-struct-constructor? known-struct-constructor-type-id
known-struct-predicate known-struct-predicate? known-struct-predicate-type-id known-struct-predicate-authentic?
known-field-accessor known-field-accessor? known-field-accessor-type-id known-field-accessor-pos
known-field-mutator known-field-mutator? known-field-mutator-type-id known-field-mutator-pos
known-field-accessor known-field-accessor? known-field-accessor-type-id known-field-accessor-authentic?
known-field-accessor-pos known-field-accessor-known-immutable?
known-field-mutator known-field-mutator? known-field-mutator-type-id known-field-mutator-authentic?
known-field-mutator-pos
known-struct-constructor/need-imports known-struct-constructor/need-imports? known-struct-constructor/need-imports-needed
known-struct-predicate/need-imports known-struct-predicate/need-imports? known-struct-predicate/need-imports-needed
known-field-accessor/need-imports known-field-accessor/need-imports? known-field-accessor/need-imports-needed
@ -122,8 +124,8 @@
(struct known-mutator (type) #:prefab #:omit-define-syntaxes #:super struct:known-procedure/single-valued)
(struct known-struct-constructor (type-id) #:prefab #:omit-define-syntaxes #:super struct:known-constructor)
(struct known-struct-predicate (type-id authentic?) #:prefab #:omit-define-syntaxes #:super struct:known-predicate)
(struct known-field-accessor (type-id pos) #:prefab #:omit-define-syntaxes #:super struct:known-accessor)
(struct known-field-mutator (type-id pos) #:prefab #:omit-define-syntaxes #:super struct:known-mutator)
(struct known-field-accessor (type-id authentic? pos known-immutable?) #:prefab #:omit-define-syntaxes #:super struct:known-accessor)
(struct known-field-mutator (type-id authentic? pos) #:prefab #:omit-define-syntaxes #:super struct:known-mutator)
(struct known-struct-constructor/need-imports (needed) #:prefab #:omit-define-syntaxes #:super struct:known-struct-constructor)
(struct known-struct-predicate/need-imports (needed) #:prefab #:omit-define-syntaxes #:super struct:known-struct-predicate)
(struct known-field-accessor/need-imports (needed) #:prefab #:omit-define-syntaxes #:super struct:known-field-accessor)

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

@ -857,7 +857,8 @@
(cond
[type-id
(define tmp (maybe-tmp (car args) 'v))
(define sel (if unsafe-mode?
(define sel (if (and unsafe-mode?
(known-field-accessor-authentic? k))
`(unsafe-struct*-ref ,tmp ,(known-field-accessor-pos k))
`(if (unsafe-struct? ,tmp ,(schemify type-id 'fresh))
(unsafe-struct*-ref ,tmp ,(known-field-accessor-pos k))
@ -874,7 +875,8 @@
[type-id
(define tmp (maybe-tmp (car args) 'v))
(define tmp-rhs (maybe-tmp (cadr args) 'rhs))
(define mut (if unsafe-mode?
(define mut (if (and unsafe-mode?
(known-field-mutator-authentic? k))
`(unsafe-struct*-set! ,tmp ,(known-field-mutator-pos k) ,tmp-rhs)
`(if (unsafe-struct? ,tmp ,(schemify type-id 'fresh))
(unsafe-struct*-set! ,tmp ,(known-field-mutator-pos k) ,tmp-rhs)

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

@ -107,15 +107,25 @@
(let ([v (or (hash-ref-either knowns imports proc)
(hash-ref prim-knowns proc #f))])
(and (if pure?
(and (if no-alloc?
(and (or (if no-alloc?
(known-procedure/pure? v)
(or (known-procedure/allocates? v)
(known-procedure/allocates? v))
;; in unsafe mode, we can assume no constract error:
(and unsafe-mode?
(known-accessor? v))))
(known-field-accessor? v)
(known-field-accessor-authentic? v)
(known-field-accessor-known-immutable? v)))
(returns 1))
(and (or (known-procedure/no-prompt? v)
(known-procedure/no-prompt/multi? v))
(eqv? result-arity #f)))
(or (and (known-procedure/no-prompt? v)
(returns 1))
(and (known-procedure/no-prompt/multi? v)
(eqv? result-arity #f))
(and (known-field-accessor? v)
(known-field-accessor-authentic? v)
(returns 1))
(and (known-field-mutator? v)
(known-field-mutator-authentic? v)
(returns 1))))
(bitwise-bit-set? (known-procedure-arity-mask v) (length args))))
(simple-mutated-state? (hash-ref mutated proc #f))
(for/and ([arg (in-list args)])

3
racket/src/thread/os-thread.rkt
View File

@ -20,7 +20,8 @@
(proc)))
(void))
(struct os-semaphore ([count #:mutable] mutex condition))
(struct os-semaphore ([count #:mutable] mutex condition)
#:authentic)
(define/who (unsafe-make-os-semaphore)
(unless threaded? (raise-unsupported who))

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 20
#define MZSCHEME_VERSION_W 21
/* A level of indirection makes `#` work as needed: */
#define AS_a_STR_HELPER(x) #x