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

get rid of rtd-mutables for non-prefab struct

Browse Source
This commit is contained in:
yjqww6 2020-12-05 20:49:30 +08:00 committed by Matthew Flatt
parent 72809879a4
commit d81fa3bba0
5 changed files with 267 additions and 127 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
racket/src/cs/rumble/equal.ss
View File

@ -130,7 +130,11 @@
;; Make sure record sees only booleans: ;; Make sure record sees only booleans:
(and (eql? a b) #t)))] (and (eql? a b) #t)))]
[(and (eq? mode 'chaperone-of?) [(and (eq? mode 'chaperone-of?)
(with-global-lock* (hashtable-contains? rtd-mutables (record-rtd a)))) (let ([rtd (record-rtd a)])
(and (not (eq? 0 (struct-type-mpm rtd)))
(if (struct-type-prefab? rtd)
(with-global-lock* (hashtable-contains? rtd-mutables rtd))
#t))))
;; Mutable records must be `eq?` for `chaperone-of?` ;; Mutable records must be `eq?` for `chaperone-of?`
#f] #f]
[else [else

32
racket/src/cs/rumble/struct.ss
View File

@ -371,7 +371,7 @@
;; ---------------------------------------- ;; ----------------------------------------
;; Records which fields of an rtd are mutable, where an rtd that is ;; Records which fields of an prefab rtd are mutable, where an rtd that is
;; not in the table has no mutable fields, and the field list can be ;; not in the table has no mutable fields, and the field list can be
;; empty if a parent type is mutable; this table is used without ;; empty if a parent type is mutable; this table is used without
;; a lock ;; a lock
@ -504,7 +504,10 @@
(let ([mask (sub1 (general-arithmetic-shift 1 (+ init-count auto-count)))]) (let ([mask (sub1 (general-arithmetic-shift 1 (+ init-count auto-count)))])
(if (eq? insp 'prefab) (if (eq? insp 'prefab)
mask mask
(let loop ([imms immutables] [mask mask]) (let loop ([imms (if (exact-nonnegative-integer? proc-spec)
(cons proc-spec immutables)
immutables)]
[mask mask])
(cond (cond
[(null? imms) mask] [(null? imms) mask]
[else [else
@ -583,8 +586,7 @@
'())] '())]
[all-immutables (if (integer? proc-spec) [all-immutables (if (integer? proc-spec)
(cons proc-spec immutables) (cons proc-spec immutables)
immutables)] immutables)])
[mutables (immutables->mutables all-immutables init-count auto-count)])
(when (not parent-rtd*) (when (not parent-rtd*)
(record-type-equal-procedure rtd default-struct-equal?) (record-type-equal-procedure rtd default-struct-equal?)
(record-type-hash-procedure rtd default-struct-hash)) (record-type-hash-procedure rtd default-struct-hash))
@ -594,7 +596,6 @@
(cons prop:procedure props) (cons prop:procedure props)
props))]) props))])
(add-to-table! rtd-props rtd props)) (add-to-table! rtd-props rtd props))
(register-mutables! mutables rtd parent-rtd*)
;; Copy parent properties for this type: ;; Copy parent properties for this type:
(for-each (lambda (prop) (for-each (lambda (prop)
(let loop ([prop prop]) (let loop ([prop prop])
@ -854,7 +855,17 @@
auto-count auto-count
(make-position-based-accessor rtd* parent-total*-count (+ init-count auto-count)) (make-position-based-accessor rtd* parent-total*-count (+ init-count auto-count))
(make-position-based-mutator rtd* parent-total*-count (+ init-count auto-count)) (make-position-based-mutator rtd* parent-total*-count (+ init-count auto-count))
(if (struct-type-prefab? rtd*)
(mutables->immutables (eq-hashtable-ref rtd-mutables rtd* '#()) init-count) (mutables->immutables (eq-hashtable-ref rtd-mutables rtd* '#()) init-count)
(let ([end (record-type-field-count rtd*)]
[offset (fx+ 1 (struct-type-parent-total*-count rtd*))]
[mpm (struct-type-mpm rtd*)])
(let loop ([i 0])
(cond
[(fx= i end) '()]
[(bitwise-bit-set? mpm (fx+ offset i))
(loop (fx+ i 1))]
[else (cons i (loop (fx+ i 1)))]))))
next-rtd* next-rtd*
skipped?))]) skipped?))])
(cond (cond
@ -1020,8 +1031,16 @@
0))) 0)))
;; ---------------------------------------- ;; ----------------------------------------
(define struct-type-mpm
(let ([mpm (csv7:record-field-accessor #!base-rtd 'mpm)])
(lambda (rtd) (mpm rtd))))
(define (struct-type-prefab? rtd)
(and (getprop (record-type-uid rtd) 'prefab-key+count #f) #t))
(define (struct-type-field-mutable? rtd pos) (define (struct-type-field-mutable? rtd pos)
(and (record-field-mutable? rtd pos)
(if (struct-type-prefab? rtd)
(let ([mutables (eq-hashtable-ref rtd-mutables rtd '#())]) (let ([mutables (eq-hashtable-ref rtd-mutables rtd '#())])
(let loop ([j (#%vector-length mutables)]) (let loop ([j (#%vector-length mutables)])
(cond (cond
@ -1029,7 +1048,8 @@
[else [else
(let ([j (fx1- j)]) (let ([j (fx1- j)])
(or (eqv? pos (#%vector-ref mutables j)) (or (eqv? pos (#%vector-ref mutables j))
(loop j)))])))) (loop j)))])))
#t)))
;; Returns a list of (cons guard-proc field-count) ;; Returns a list of (cons guard-proc field-count)
(define (struct-type-guards rtd) (define (struct-type-guards rtd)

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

@ -2687,7 +2687,7 @@
(raise (raise
(let ((app_0 (string-append "internal error: " msg_0))) (let ((app_0 (string-append "internal error: " msg_0)))
(|#%app| exn:fail app_0 (current-continuation-marks)))))) (|#%app| exn:fail app_0 (current-continuation-marks))))))
(define effect_2977 (define effect_2501
(begin (begin
(void (void
(if (primitive-table '|#%pthread|) (if (primitive-table '|#%pthread|)
@ -2715,7 +2715,7 @@
#f #f
11 11
2047)) 2047))
(define effect_2727 (define effect_2883
(struct-type-install-properties! (struct-type-install-properties!
struct:sandman struct:sandman
'sandman 'sandman
@ -3701,7 +3701,7 @@
(loop_0 #t)))))))))) (loop_0 #t))))))))))
(loop_0 #f)))))) (loop_0 #f))))))
(define struct:exts (make-record-type-descriptor* 'exts #f #f #f #f 2 0)) (define struct:exts (make-record-type-descriptor* 'exts #f #f #f #f 2 0))
(define effect_2438 (define effect_2383
(struct-type-install-properties! (struct-type-install-properties!
struct:exts struct:exts
'exts 'exts
@ -3805,7 +3805,7 @@
(begin (begin
(unsafe-place-local-set! cell.1$10 sleep_0) (unsafe-place-local-set! cell.1$10 sleep_0)
(unsafe-place-local-set! cell.2$3 fd_0)))) (unsafe-place-local-set! cell.2$3 fd_0))))
(define effect_2095 (define effect_2049
(begin (begin
(void (void
(|#%app| (|#%app|
@ -3993,7 +3993,7 @@
(wrap-evt (|#%app| (output-port-evt-ref p_0) p_0) (lambda (v_0) p_0))))) (wrap-evt (|#%app| (output-port-evt-ref p_0) p_0) (lambda (v_0) p_0)))))
(define struct:core-port (define struct:core-port
(make-record-type-descriptor* 'core-port #f #f #f #f 7 124)) (make-record-type-descriptor* 'core-port #f #f #f #f 7 124))
(define effect_3005 (define effect_2716
(struct-type-install-properties! (struct-type-install-properties!
struct:core-port struct:core-port
'core-port 'core-port
@ -4062,7 +4062,7 @@
(void))) (void)))
(define struct:core-port-methods.1 (define struct:core-port-methods.1
(make-record-type-descriptor* 'core-port-methods #f #f #f #f 5 0)) (make-record-type-descriptor* 'core-port-methods #f #f #f #f 5 0))
(define effect_2884 (define effect_2750
(struct-type-install-properties! (struct-type-install-properties!
struct:core-port-methods.1 struct:core-port-methods.1
'core-port-methods 'core-port-methods
@ -4215,7 +4215,7 @@
#f #f
#f)) #f))
(define struct:direct (make-record-type-descriptor* 'direct #f #f #f #f 3 7)) (define struct:direct (make-record-type-descriptor* 'direct #f #f #f #f 3 7))
(define effect_2828 (define effect_3200
(struct-type-install-properties! (struct-type-install-properties!
struct:direct struct:direct
'direct 'direct
@ -4256,7 +4256,7 @@
(void))) (void)))
(define struct:location (define struct:location
(make-record-type-descriptor* 'location #f #f #f #f 5 31)) (make-record-type-descriptor* 'location #f #f #f #f 5 31))
(define effect_2649 (define effect_2872
(struct-type-install-properties! (struct-type-install-properties!
struct:location struct:location
'location 'location
@ -4379,7 +4379,7 @@
#f #f
2 2
3)) 3))
(define effect_2557 (define effect_2614
(struct-type-install-properties! (struct-type-install-properties!
struct:core-input-port struct:core-input-port
'core-input-port 'core-input-port
@ -4475,7 +4475,7 @@
#f #f
6 6
0)) 0))
(define effect_2398 (define effect_3216
(struct-type-install-properties! (struct-type-install-properties!
struct:core-input-port-methods.1 struct:core-input-port-methods.1
'core-input-port-methods 'core-input-port-methods
@ -4749,7 +4749,7 @@
#f #f
4 4
15)) 15))
(define effect_2350 (define effect_2619
(struct-type-install-properties! (struct-type-install-properties!
struct:core-output-port struct:core-output-port
'core-output-port 'core-output-port
@ -4862,7 +4862,7 @@
#f #f
4 4
0)) 0))
(define effect_2513 (define effect_2581
(struct-type-install-properties! (struct-type-install-properties!
struct:core-output-port-methods.1 struct:core-output-port-methods.1
'core-output-port-methods 'core-output-port-methods
@ -5047,7 +5047,7 @@
(values (list v_0) #f))))))))) (values (list v_0) #f)))))))))
(define struct:write-evt (define struct:write-evt
(make-record-type-descriptor* 'write-evt #f #f #f #f 1 0)) (make-record-type-descriptor* 'write-evt #f #f #f #f 1 0))
(define effect_2996 (define effect_2681
(struct-type-install-properties! (struct-type-install-properties!
struct:write-evt struct:write-evt
'write-evt 'write-evt
@ -5118,7 +5118,7 @@
#f)) #f))
(define struct:utf-8-state (define struct:utf-8-state
(make-record-type-descriptor* 'utf-8-state #f #f #f #f 3 0)) (make-record-type-descriptor* 'utf-8-state #f #f #f #f 3 0))
(define effect_2404 (define effect_2417
(struct-type-install-properties! (struct-type-install-properties!
struct:utf-8-state struct:utf-8-state
'utf-8-state 'utf-8-state
@ -7271,7 +7271,7 @@
(void)))))) (void))))))
(define struct:commit-manager (define struct:commit-manager
(make-record-type-descriptor* 'commit-manager #f #f #f #f 3 0)) (make-record-type-descriptor* 'commit-manager #f #f #f #f 3 0))
(define effect_2365 (define effect_3024
(struct-type-install-properties! (struct-type-install-properties!
struct:commit-manager struct:commit-manager
'commit-manager 'commit-manager
@ -7372,7 +7372,7 @@
(void))) (void)))
(define struct:commit-request (define struct:commit-request
(make-record-type-descriptor* 'commit-request #f #f #f #f 5 0)) (make-record-type-descriptor* 'commit-request #f #f #f #f 5 0))
(define effect_2526 (define effect_2327
(struct-type-install-properties! (struct-type-install-properties!
struct:commit-request struct:commit-request
'commit-request 'commit-request
@ -7515,7 +7515,7 @@
(void))) (void)))
(define struct:commit-response (define struct:commit-response
(make-record-type-descriptor* 'commit-response #f #f #f #f 2 0)) (make-record-type-descriptor* 'commit-response #f #f #f #f 2 0))
(define effect_2717 (define effect_2424
(struct-type-install-properties! (struct-type-install-properties!
struct:commit-response struct:commit-response
'commit-response 'commit-response
@ -7850,7 +7850,7 @@
#f #f
2 2
3)) 3))
(define effect_2490 (define effect_2713
(struct-type-install-properties! (struct-type-install-properties!
struct:commit-input-port struct:commit-input-port
'commit-input-port 'commit-input-port
@ -7916,7 +7916,7 @@
#f #f
0 0
0)) 0))
(define effect_2304 (define effect_2628
(struct-type-install-properties! (struct-type-install-properties!
struct:commit-input-port-methods.1 struct:commit-input-port-methods.1
'commit-input-port-methods 'commit-input-port-methods
@ -8089,7 +8089,7 @@
(unsafe-end-atomic)))))))) (unsafe-end-atomic))))))))
(define struct:pipe-data (define struct:pipe-data
(make-record-type-descriptor* 'pipe-data #f #f #f #f 16 65534)) (make-record-type-descriptor* 'pipe-data #f #f #f #f 16 65534))
(define effect_2355 (define effect_3136
(struct-type-install-properties! (struct-type-install-properties!
struct:pipe-data struct:pipe-data
'pipe-data 'pipe-data
@ -8268,7 +8268,7 @@
(void))) (void)))
(define struct:pipe-data-methods.1 (define struct:pipe-data-methods.1
(make-record-type-descriptor* 'pipe-data-methods #f #f #f #f 0 0)) (make-record-type-descriptor* 'pipe-data-methods #f #f #f #f 0 0))
(define effect_2017 (define effect_2891
(struct-type-install-properties! (struct-type-install-properties!
struct:pipe-data-methods.1 struct:pipe-data-methods.1
'pipe-data-methods 'pipe-data-methods
@ -8407,7 +8407,7 @@
#f #f
1 1
1)) 1))
(define effect_2673 (define effect_2367
(struct-type-install-properties! (struct-type-install-properties!
struct:pipe-input-port struct:pipe-input-port
'pipe-input-port 'pipe-input-port
@ -8453,7 +8453,7 @@
#f #f
0 0
0)) 0))
(define effect_2740 (define effect_2379
(struct-type-install-properties! (struct-type-install-properties!
struct:pipe-input-port-methods.1 struct:pipe-input-port-methods.1
'pipe-input-port-methods 'pipe-input-port-methods
@ -8828,7 +8828,7 @@
#f #f
1 1
1)) 1))
(define effect_2583 (define effect_2458
(struct-type-install-properties! (struct-type-install-properties!
struct:pipe-output-port struct:pipe-output-port
'pipe-output-port 'pipe-output-port
@ -8854,7 +8854,7 @@
(|#%name| (|#%name|
set-pipe-output-port-d! set-pipe-output-port-d!
(record-mutator struct:pipe-output-port 0))) (record-mutator struct:pipe-output-port 0)))
(define effect_2379 (define effect_2380
(begin (begin
(register-struct-constructor! create-pipe-output-port) (register-struct-constructor! create-pipe-output-port)
(register-struct-predicate! pipe-output-port?) (register-struct-predicate! pipe-output-port?)
@ -8876,7 +8876,7 @@
#f #f
0 0
0)) 0))
(define effect_2521 (define effect_2137
(struct-type-install-properties! (struct-type-install-properties!
struct:pipe-output-port-methods.1 struct:pipe-output-port-methods.1
'pipe-output-port-methods 'pipe-output-port-methods
@ -9420,7 +9420,7 @@
((limit24_0) (make-pipe_0 limit24_0 'pipe 'pipe)))))) ((limit24_0) (make-pipe_0 limit24_0 'pipe 'pipe))))))
(define struct:pipe-write-poller (define struct:pipe-write-poller
(make-record-type-descriptor* 'pipe-write-poller #f #f #f #f 1 0)) (make-record-type-descriptor* 'pipe-write-poller #f #f #f #f 1 0))
(define effect_2289 (define effect_2371
(struct-type-install-properties! (struct-type-install-properties!
struct:pipe-write-poller struct:pipe-write-poller
'pipe-write-poller 'pipe-write-poller
@ -9507,7 +9507,7 @@
(void))) (void)))
(define struct:pipe-read-poller (define struct:pipe-read-poller
(make-record-type-descriptor* 'pipe-read-poller #f #f #f #f 1 0)) (make-record-type-descriptor* 'pipe-read-poller #f #f #f #f 1 0))
(define effect_2446 (define effect_2394
(struct-type-install-properties! (struct-type-install-properties!
struct:pipe-read-poller struct:pipe-read-poller
'pipe-read-poller 'pipe-read-poller
@ -9602,7 +9602,7 @@
#f #f
5 5
31)) 31))
(define effect_1948 (define effect_2246
(struct-type-install-properties! (struct-type-install-properties!
struct:peek-via-read-input-port struct:peek-via-read-input-port
'peek-via-read-input-port 'peek-via-read-input-port
@ -9721,7 +9721,7 @@
#f #f
1 1
0)) 0))
(define effect_2315 (define effect_2651
(struct-type-install-properties! (struct-type-install-properties!
struct:peek-via-read-input-port-methods.1 struct:peek-via-read-input-port-methods.1
'peek-via-read-input-port-methods 'peek-via-read-input-port-methods
@ -10438,7 +10438,7 @@
#f #f
3 3
7)) 7))
(define effect_2291 (define effect_2504
(struct-type-install-properties! (struct-type-install-properties!
struct:fd-input-port struct:fd-input-port
'fd-input-port 'fd-input-port
@ -10518,7 +10518,7 @@
#f #f
2 2
0)) 0))
(define effect_2561 (define effect_2334
(struct-type-install-properties! (struct-type-install-properties!
struct:fd-input-port-methods.1 struct:fd-input-port-methods.1
'fd-input-port-methods 'fd-input-port-methods
@ -10784,7 +10784,7 @@
#f #f
8 8
255)) 255))
(define effect_2417 (define effect_2781
(struct-type-install-properties! (struct-type-install-properties!
struct:fd-output-port struct:fd-output-port
'fd-output-port 'fd-output-port
@ -10962,7 +10962,7 @@
#f #f
2 2
0)) 0))
(define effect_2541 (define effect_2413
(struct-type-install-properties! (struct-type-install-properties!
struct:fd-output-port-methods.1 struct:fd-output-port-methods.1
'fd-output-port-methods 'fd-output-port-methods
@ -11587,7 +11587,7 @@
(|#%app| exn:fail app_0 (current-continuation-marks))))))) (|#%app| exn:fail app_0 (current-continuation-marks)))))))
(void))))) (void)))))
(define struct:fd-evt (make-record-type-descriptor* 'fd-evt #f #f #f #f 3 4)) (define struct:fd-evt (make-record-type-descriptor* 'fd-evt #f #f #f #f 3 4))
(define effect_2836 (define effect_2590
(struct-type-install-properties! (struct-type-install-properties!
struct:fd-evt struct:fd-evt
'fd-evt 'fd-evt
@ -11732,7 +11732,7 @@
(void))) (void)))
(define struct:rktio-fd-flushed-evt (define struct:rktio-fd-flushed-evt
(make-record-type-descriptor* 'rktio-fd-flushed-evt #f #f #f #f 1 0)) (make-record-type-descriptor* 'rktio-fd-flushed-evt #f #f #f #f 1 0))
(define effect_2592 (define effect_2959
(struct-type-install-properties! (struct-type-install-properties!
struct:rktio-fd-flushed-evt struct:rktio-fd-flushed-evt
'rktio-fd-flushed-evt 'rktio-fd-flushed-evt
@ -12547,7 +12547,7 @@
(loop_0 pos_0)))))))))) (loop_0 pos_0))))))))))
(define struct:progress-evt (define struct:progress-evt
(make-record-type-descriptor* 'progress-evt #f #f #f #f 2 0)) (make-record-type-descriptor* 'progress-evt #f #f #f #f 2 0))
(define effect_2476 (define effect_2604
(struct-type-install-properties! (struct-type-install-properties!
struct:progress-evt struct:progress-evt
'progress-evt 'progress-evt
@ -15865,7 +15865,7 @@
(unsafe-bytes-set! out-bstr_0 (+ j_0 1) hi_0))))) (unsafe-bytes-set! out-bstr_0 (+ j_0 1) hi_0)))))
(define struct:utf-8-converter (define struct:utf-8-converter
(make-record-type-descriptor* 'utf-8-converter #f #f #f #f 2 0)) (make-record-type-descriptor* 'utf-8-converter #f #f #f #f 2 0))
(define effect_2497 (define effect_2723
(struct-type-install-properties! (struct-type-install-properties!
struct:utf-8-converter struct:utf-8-converter
'utf-8-converter 'utf-8-converter
@ -16894,7 +16894,7 @@
out-start23_0)))))) out-start23_0))))))
(define struct:bytes-converter (define struct:bytes-converter
(make-record-type-descriptor* 'bytes-converter #f #f #f #f 2 3)) (make-record-type-descriptor* 'bytes-converter #f #f #f #f 2 3))
(define effect_2305 (define effect_2529
(struct-type-install-properties! (struct-type-install-properties!
struct:bytes-converter struct:bytes-converter
'bytes-converter 'bytes-converter
@ -17798,7 +17798,7 @@
(void))) (void)))
(check-not-unsafe-undefined bstr_0 'bstr_119)))))) (check-not-unsafe-undefined bstr_0 'bstr_119))))))
(define struct:cache (make-record-type-descriptor* 'cache #f #f #f #f 4 15)) (define struct:cache (make-record-type-descriptor* 'cache #f #f #f #f 4 15))
(define effect_2033 (define effect_2666
(struct-type-install-properties! (struct-type-install-properties!
struct:cache struct:cache
'cache 'cache
@ -18172,7 +18172,7 @@
((in-bstr_0 err-char5_0) ((in-bstr_0 err-char5_0)
(bytes->string/locale_0 in-bstr_0 err-char5_0 0 unsafe-undefined)))))) (bytes->string/locale_0 in-bstr_0 err-char5_0 0 unsafe-undefined))))))
(define struct:path (make-record-type-descriptor* 'path #f #f #f #f 2 0)) (define struct:path (make-record-type-descriptor* 'path #f #f #f #f 2 0))
(define effect_3031 (define effect_2407
(struct-type-install-properties! (struct-type-install-properties!
struct:path struct:path
'path 'path
@ -19506,7 +19506,7 @@
#f #f
3 3
7)) 7))
(define effect_2217 (define effect_2730
(struct-type-install-properties! (struct-type-install-properties!
struct:bytes-input-port struct:bytes-input-port
'bytes-input-port 'bytes-input-port
@ -19584,7 +19584,7 @@
#f #f
0 0
0)) 0))
(define effect_2813 (define effect_2624
(struct-type-install-properties! (struct-type-install-properties!
struct:bytes-input-port-methods.1 struct:bytes-input-port-methods.1
'bytes-input-port-methods 'bytes-input-port-methods
@ -19820,7 +19820,7 @@
#f #f
3 3
7)) 7))
(define effect_2227 (define effect_2717
(struct-type-install-properties! (struct-type-install-properties!
struct:bytes-output-port struct:bytes-output-port
'bytes-output-port 'bytes-output-port
@ -19902,7 +19902,7 @@
#f #f
2 2
0)) 0))
(define effect_3566 (define effect_2372
(struct-type-install-properties! (struct-type-install-properties!
struct:bytes-output-port-methods.1 struct:bytes-output-port-methods.1
'bytes-output-port-methods 'bytes-output-port-methods
@ -20367,7 +20367,7 @@
#f #f
2 2
3)) 3))
(define effect_2220 (define effect_3238
(struct-type-install-properties! (struct-type-install-properties!
struct:max-output-port struct:max-output-port
'max-output-port 'max-output-port
@ -20429,7 +20429,7 @@
#f #f
0 0
0)) 0))
(define effect_2319 (define effect_2860
(struct-type-install-properties! (struct-type-install-properties!
struct:max-output-port-methods.1 struct:max-output-port-methods.1
'max-output-port-methods 'max-output-port-methods
@ -21383,7 +21383,7 @@
#f #f
0 0
0)) 0))
(define effect_2619 (define effect_2671
(struct-type-install-properties! (struct-type-install-properties!
struct:nowhere-output-port struct:nowhere-output-port
'nowhere-output-port 'nowhere-output-port
@ -21419,7 +21419,7 @@
#f #f
0 0
0)) 0))
(define effect_2409 (define effect_2396
(struct-type-install-properties! (struct-type-install-properties!
struct:nowhere-output-port-methods.1 struct:nowhere-output-port-methods.1
'nowhere-output-port-methods 'nowhere-output-port-methods
@ -21729,7 +21729,7 @@
(quick-no-graph?_0 config_0 mode_0 print-graph?_0 v_0 fuel_0)))) (quick-no-graph?_0 config_0 mode_0 print-graph?_0 v_0 fuel_0))))
(define struct:as-constructor (define struct:as-constructor
(make-record-type-descriptor* 'as-constructor #f #f #f #f 1 0)) (make-record-type-descriptor* 'as-constructor #f #f #f #f 1 0))
(define effect_2345 (define effect_2971
(struct-type-install-properties! (struct-type-install-properties!
struct:as-constructor struct:as-constructor
'as-constructor 'as-constructor
@ -25012,7 +25012,7 @@
#f)))))) #f))))))
(define struct:starting-point (define struct:starting-point
(make-record-type-descriptor* 'starting-point #f #f #f #f 7 0)) (make-record-type-descriptor* 'starting-point #f #f #f #f 7 0))
(define effect_2228 (define effect_2720
(struct-type-install-properties! (struct-type-install-properties!
struct:starting-point struct:starting-point
'starting-point 'starting-point
@ -27113,7 +27113,7 @@
(lambda (v_0) (if (fixnum? v_0) (<= 0 v_0 65535) #f))) (lambda (v_0) (if (fixnum? v_0) (<= 0 v_0 65535) #f)))
(define struct:security-guard (define struct:security-guard
(make-record-type-descriptor* 'security-guard #f #f #f #f 4 0)) (make-record-type-descriptor* 'security-guard #f #f #f #f 4 0))
(define effect_2643 (define effect_2690
(struct-type-install-properties! (struct-type-install-properties!
struct:security-guard struct:security-guard
'security-guard 'security-guard
@ -31536,7 +31536,7 @@
(current-directory$1)) (current-directory$1))
'() '()
hash2725))))) hash2725)))))
(define effect_2316 (define effect_2315
(begin (void (begin-unsafe (set! simplify-path/dl 1/simplify-path))) (void))) (begin (void (begin-unsafe (set! simplify-path/dl 1/simplify-path))) (void)))
(define bytes-no-nuls? (define bytes-no-nuls?
(lambda (s_0) (lambda (s_0)
@ -31583,7 +31583,7 @@
k_0))) k_0)))
(define struct:environment-variables (define struct:environment-variables
(make-record-type-descriptor* 'environment-variables #f #f #f #f 1 1)) (make-record-type-descriptor* 'environment-variables #f #f #f #f 1 1))
(define effect_2491 (define effect_2652
(struct-type-install-properties! (struct-type-install-properties!
struct:environment-variables struct:environment-variables
'environment-variables 'environment-variables
@ -33366,7 +33366,7 @@
(lambda (p_0) (if (is-path? p_0) (relative-to-user-directory p_0) p_0))) (lambda (p_0) (if (is-path? p_0) (relative-to-user-directory p_0) p_0)))
(define struct:logger (define struct:logger
(make-record-type-descriptor* 'logger #f #f #f #f 11 376)) (make-record-type-descriptor* 'logger #f #f #f #f 11 376))
(define effect_2358 (define effect_2192
(struct-type-install-properties! (struct-type-install-properties!
struct:logger struct:logger
'logger 'logger
@ -33873,7 +33873,7 @@
(define level->user-representation (define level->user-representation
(lambda (lvl_0) (if (eq? lvl_0 'none) #f lvl_0))) (lambda (lvl_0) (if (eq? lvl_0 'none) #f lvl_0)))
(define struct:queue (make-record-type-descriptor* 'queue #f #f #f #f 2 3)) (define struct:queue (make-record-type-descriptor* 'queue #f #f #f #f 2 3))
(define effect_3001 (define effect_2520
(struct-type-install-properties! (struct-type-install-properties!
struct:queue struct:queue
'queue 'queue
@ -33908,7 +33908,7 @@
(register-struct-field-mutator! set-queue-end! struct:queue 1) (register-struct-field-mutator! set-queue-end! struct:queue 1)
(void))) (void)))
(define struct:node (make-record-type-descriptor* 'node #f #f #f #f 3 6)) (define struct:node (make-record-type-descriptor* 'node #f #f #f #f 3 6))
(define effect_2107 (define effect_2547
(struct-type-install-properties! (struct-type-install-properties!
struct:node struct:node
'node 'node
@ -33975,7 +33975,7 @@
(set-queue-end! q_0 (node-prev n_0)))))) (set-queue-end! q_0 (node-prev n_0))))))
(define struct:log-receiver (define struct:log-receiver
(make-record-type-descriptor* 'log-receiver #f #f #f #f 1 0)) (make-record-type-descriptor* 'log-receiver #f #f #f #f 1 0))
(define effect_1970 (define effect_2708
(struct-type-install-properties! (struct-type-install-properties!
struct:log-receiver struct:log-receiver
'log-receiver 'log-receiver
@ -34042,7 +34042,7 @@
#f #f
3 3
0)) 0))
(define effect_3157 (define effect_2757
(struct-type-install-properties! (struct-type-install-properties!
struct:queue-log-receiver struct:queue-log-receiver
'log-receiver 'log-receiver
@ -34174,7 +34174,7 @@
s s
'log-receiver 'log-receiver
'backref)))))) 'backref))))))
(define effect_2529 (define effect_2530
(begin (begin
(register-struct-constructor! queue-log-receiver2.1) (register-struct-constructor! queue-log-receiver2.1)
(register-struct-predicate! queue-log-receiver?) (register-struct-predicate! queue-log-receiver?)
@ -34236,7 +34236,7 @@
#f #f
2 2
0)) 0))
(define effect_2067 (define effect_2592
(struct-type-install-properties! (struct-type-install-properties!
struct:stdio-log-receiver struct:stdio-log-receiver
'stdio-log-receiver 'stdio-log-receiver
@ -34395,7 +34395,7 @@
#f #f
2 2
0)) 0))
(define effect_2311 (define effect_2241
(struct-type-install-properties! (struct-type-install-properties!
struct:syslog-log-receiver struct:syslog-log-receiver
'syslog-log-receiver 'syslog-log-receiver
@ -35395,7 +35395,7 @@
(void)))))) (void))))))
(define struct:fs-change-evt (define struct:fs-change-evt
(make-record-type-descriptor* 'filesystem-change-evt #f #f #f #f 2 3)) (make-record-type-descriptor* 'filesystem-change-evt #f #f #f #f 2 3))
(define effect_2451 (define effect_2322
(struct-type-install-properties! (struct-type-install-properties!
struct:fs-change-evt struct:fs-change-evt
'filesystem-change-evt 'filesystem-change-evt
@ -35697,7 +35697,7 @@
(unsafe-place-local-ref cell.1) (unsafe-place-local-ref cell.1)
rfc_0)) rfc_0))
(void))))) (void)))))
(define effect_2390 (define effect_2149
(begin (begin
(void (void
(|#%app| (|#%app|
@ -35918,7 +35918,7 @@
(begin (|#%app| final_0 p_0 bstr_0) bstr_0)))))))))) (begin (|#%app| final_0 p_0 bstr_0) bstr_0))))))))))
(define struct:subprocess (define struct:subprocess
(make-record-type-descriptor* 'subprocess #f #f #f #f 3 3)) (make-record-type-descriptor* 'subprocess #f #f #f #f 3 3))
(define effect_2587 (define effect_2272
(struct-type-install-properties! (struct-type-install-properties!
struct:subprocess struct:subprocess
'subprocess 'subprocess
@ -36054,7 +36054,7 @@
v v
'subprocess 'subprocess
'cust-ref)))))) 'cust-ref))))))
(define effect_2666 (define effect_2667
(begin (begin
(register-struct-constructor! make-subprocess) (register-struct-constructor! make-subprocess)
(register-struct-predicate! 1/subprocess?) (register-struct-predicate! 1/subprocess?)
@ -36820,7 +36820,7 @@
#f #f
1 1
1)) 1))
(define effect_2403 (define effect_2432
(struct-type-install-properties! (struct-type-install-properties!
struct:tcp-input-port struct:tcp-input-port
'tcp-input-port 'tcp-input-port
@ -36874,7 +36874,7 @@
#f #f
0 0
0)) 0))
(define effect_2480 (define effect_2838
(struct-type-install-properties! (struct-type-install-properties!
struct:tcp-input-port-methods.1 struct:tcp-input-port-methods.1
'tcp-input-port-methods 'tcp-input-port-methods
@ -37014,7 +37014,7 @@
#f #f
1 1
1)) 1))
(define effect_2128 (define effect_2320
(struct-type-install-properties! (struct-type-install-properties!
struct:tcp-output-port struct:tcp-output-port
'tcp-output-port 'tcp-output-port
@ -37070,7 +37070,7 @@
#f #f
0 0
0)) 0))
(define effect_2961 (define effect_2727
(struct-type-install-properties! (struct-type-install-properties!
struct:tcp-output-port-methods.1 struct:tcp-output-port-methods.1
'tcp-output-port-methods 'tcp-output-port-methods
@ -37224,7 +37224,7 @@
(void)))))))) (void))))))))
(define struct:rktio-evt (define struct:rktio-evt
(make-record-type-descriptor* 'rktio-evt #f #f #f #f 2 0)) (make-record-type-descriptor* 'rktio-evt #f #f #f #f 2 0))
(define effect_2172 (define effect_3001
(struct-type-install-properties! (struct-type-install-properties!
struct:rktio-evt struct:rktio-evt
'rktio-evt 'rktio-evt
@ -37260,7 +37260,7 @@
(|#%name| rktio-evt-poll (record-accessor struct:rktio-evt 0))) (|#%name| rktio-evt-poll (record-accessor struct:rktio-evt 0)))
(define rktio-evt-add-to-poll-set (define rktio-evt-add-to-poll-set
(|#%name| rktio-evt-add-to-poll-set (record-accessor struct:rktio-evt 1))) (|#%name| rktio-evt-add-to-poll-set (record-accessor struct:rktio-evt 1)))
(define effect_2396 (define effect_2398
(begin (begin
(register-struct-constructor! rktio-evt1.1) (register-struct-constructor! rktio-evt1.1)
(register-struct-predicate! rktio-evt?) (register-struct-predicate! rktio-evt?)
@ -37419,7 +37419,7 @@
(lambda () (unsafe-place-local-set! cell.1$3 (make-will-executor)))) (lambda () (unsafe-place-local-set! cell.1$3 (make-will-executor))))
(define struct:connect-progress (define struct:connect-progress
(make-record-type-descriptor* 'connect-progress #f #f #f #f 2 3)) (make-record-type-descriptor* 'connect-progress #f #f #f #f 2 3))
(define effect_2584 (define effect_2403
(struct-type-install-properties! (struct-type-install-properties!
struct:connect-progress struct:connect-progress
'connect-progress 'connect-progress
@ -37842,7 +37842,7 @@
(void))))) (void)))))
(define struct:tcp-listener (define struct:tcp-listener
(make-record-type-descriptor* 'tcp-listener #f #f #f #f 3 0)) (make-record-type-descriptor* 'tcp-listener #f #f #f #f 3 0))
(define effect_2591 (define effect_2611
(struct-type-install-properties! (struct-type-install-properties!
struct:tcp-listener struct:tcp-listener
'tcp-listener 'tcp-listener
@ -38240,7 +38240,7 @@
(accept-evt6.1 listener_0)))))) (accept-evt6.1 listener_0))))))
(define struct:accept-evt (define struct:accept-evt
(make-record-type-descriptor* 'tcp-accept-evt #f #f #f #f 1 0)) (make-record-type-descriptor* 'tcp-accept-evt #f #f #f #f 1 0))
(define effect_2505 (define effect_2325
(struct-type-install-properties! (struct-type-install-properties!
struct:accept-evt struct:accept-evt
'tcp-accept-evt 'tcp-accept-evt
@ -38351,7 +38351,7 @@
s s
'tcp-accept-evt 'tcp-accept-evt
'listener)))))) 'listener))))))
(define effect_2644 (define effect_2643
(begin (begin
(register-struct-constructor! accept-evt6.1) (register-struct-constructor! accept-evt6.1)
(register-struct-predicate! accept-evt?) (register-struct-predicate! accept-evt?)
@ -38409,7 +38409,7 @@
(for-loop_0 0 0)))) (for-loop_0 0 0))))
(args (raise-binding-result-arity-error 2 args)))))) (args (raise-binding-result-arity-error 2 args))))))
(define struct:udp (make-record-type-descriptor* 'udp #f #f #f #f 3 7)) (define struct:udp (make-record-type-descriptor* 'udp #f #f #f #f 3 7))
(define effect_2493 (define effect_2368
(struct-type-install-properties! (struct-type-install-properties!
struct:udp struct:udp
'udp 'udp
@ -39618,7 +39618,7 @@
who59_0))))))) who59_0)))))))
(define struct:udp-sending-evt (define struct:udp-sending-evt
(make-record-type-descriptor* 'udp-send-evt #f #f #f #f 2 0)) (make-record-type-descriptor* 'udp-send-evt #f #f #f #f 2 0))
(define effect_2756 (define effect_2358
(struct-type-install-properties! (struct-type-install-properties!
struct:udp-sending-evt struct:udp-sending-evt
'udp-send-evt 'udp-send-evt
@ -39687,7 +39687,7 @@
#f #f
0 0
0)) 0))
(define effect_2742 (define effect_3039
(struct-type-install-properties! (struct-type-install-properties!
struct:udp-sending-ready-evt struct:udp-sending-ready-evt
'udp-send-ready-evt 'udp-send-ready-evt
@ -40040,7 +40040,7 @@
(define cell.2 (unsafe-make-place-local "")) (define cell.2 (unsafe-make-place-local ""))
(define struct:udp-receiving-evt (define struct:udp-receiving-evt
(make-record-type-descriptor* 'udp-receive-evt #f #f #f #f 2 0)) (make-record-type-descriptor* 'udp-receive-evt #f #f #f #f 2 0))
(define effect_2560 (define effect_2355
(struct-type-install-properties! (struct-type-install-properties!
struct:udp-receiving-evt struct:udp-receiving-evt
'udp-receive-evt 'udp-receive-evt
@ -40114,7 +40114,7 @@
#f #f
0 0
0)) 0))
(define effect_2331 (define effect_2341
(struct-type-install-properties! (struct-type-install-properties!
struct:udp-receiving-ready-evt struct:udp-receiving-ready-evt
'udp-receive-ready-evt 'udp-receive-ready-evt

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

@ -7288,7 +7288,57 @@
(void))) (void)))
(define struct-type-info-rest-properties-list-pos 0) (define struct-type-info-rest-properties-list-pos 0)
(define make-struct-type-info (define make-struct-type-info
(letrec ((includes-property?_0 (letrec ((handle-proc-spec_0
(|#%name|
handle-proc-spec
(lambda (imports_0
knowns_0
mutated_0
prim-knowns_0
proc-spec_0
imms_0)
(begin
(if (not proc-spec_0)
imms_0
(if (exact-nonnegative-integer? proc-spec_0)
(cons proc-spec_0 imms_0)
(let ((proc-spec_1 (unwrap proc-spec_0)))
(if (symbol? proc-spec_1)
(let ((k_0
(begin-unsafe
(call-with-values
(lambda ()
(find-known+import
proc-spec_1
prim-knowns_0
knowns_0
imports_0
mutated_0))
(case-lambda
((k_0 im_0) k_0)
(args
(raise-binding-result-arity-error
2
args)))))))
(if (not k_0)
#f
(if (known-literal? k_0)
(let ((v_0 (known-literal-value k_0)))
(if (let ((or-part_0 (not v_0)))
(if or-part_0
or-part_0
(exact-nonnegative-integer? v_0)))
(handle-proc-spec_0
imports_0
knowns_0
mutated_0
prim-knowns_0
v_0
imms_0)
#f))
(if (known-procedure? k_0) imms_0 #f))))
#f))))))))
(includes-property?_0
(|#%name| (|#%name|
includes-property? includes-property?
(lambda (rest_0 name_0) (lambda (rest_0 name_0)
@ -8089,7 +8139,27 @@
#f))) #f)))
#f))) #f)))
#f)) #f))
'() (let ((proc-spec_0
(let ((d_0
(cdr
(unwrap
rest_0))))
(let ((d_1
(cdr
(unwrap
d_0))))
(let ((a_0
(car
(unwrap
d_1))))
a_0)))))
(handle-proc-spec_0
imports_0
knowns_0
mutated_0
prim-knowns_0
proc-spec_0
'()))
(if (let ((p_0 (if (let ((p_0
(unwrap rest_0))) (unwrap rest_0)))
(if (pair? p_0) (if (pair? p_0)
@ -8162,7 +8232,8 @@
#f))) #f)))
#f))) #f)))
#f)) #f))
(let ((immutables_0 (call-with-values
(lambda ()
(let ((d_0 (let ((d_0
(cdr (cdr
(unwrap (unwrap
@ -8171,10 +8242,18 @@
(cdr (cdr
(unwrap (unwrap
d_0)))) d_0))))
(let ((p_0
(unwrap
d_1)))
(let ((proc-spec_0
(let ((a_0
(car
p_0)))
a_0)))
(let ((immutables_0
(let ((d_2 (let ((d_2
(cdr (cdr
(unwrap p_0)))
d_1))))
(let ((a_0 (let ((a_0
(car (car
(unwrap (unwrap
@ -8187,8 +8266,26 @@
(car (car
(unwrap (unwrap
d_3)))) d_3))))
a_1)))))))) a_1))))))
(let ((proc-spec_1
proc-spec_0))
(values
proc-spec_1
immutables_0))))))))
(case-lambda
((proc-spec_0
immutables_0) immutables_0)
(handle-proc-spec_0
imports_0
knowns_0
mutated_0
prim-knowns_0
proc-spec_0
immutables_0))
(args
(raise-binding-result-arity-error
2
args))))
#f))))) #f)))))
#f))) #f)))
(if (if (eq? prefab-imms_1 'non-prefab) (if (if (eq? prefab-imms_1 'non-prefab)

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

@ -60,6 +60,23 @@
(for/or ([prop (in-list props)]) (for/or ([prop (in-list props)])
(eq? (unwrap prop) name))] (eq? (unwrap prop) name))]
[`,_ #f]))) [`,_ #f])))
(define (handle-proc-spec proc-spec imms)
(cond
[(not proc-spec) imms]
[(exact-nonnegative-integer? proc-spec) (cons proc-spec imms)]
[else
(let ([proc-spec (unwrap proc-spec)])
(and
(symbol? proc-spec)
(let ([k (find-known proc-spec prim-knowns knowns imports mutated)])
(cond
[(not k) #f]
[(known-literal? k)
(let ([v (known-literal-value k)])
(and (or (not v) (exact-nonnegative-integer? v))
(handle-proc-spec v imms)))]
[(known-procedure? k) imms]
[else #f]))))]))
(define constructor-name-expr (and ((length rest) . > . 5) (define constructor-name-expr (and ((length rest) . > . 5)
(list-ref rest 5))) (list-ref rest 5)))
(define non-prefab-imms (define non-prefab-imms
@ -68,8 +85,10 @@
[`() '()] [`() '()]
[`(,_) '()] [`(,_) '()]
[`(,_ ,_) '()] [`(,_ ,_) '()]
[`(,_ ,_ ,_) '()] [`(,_ ,_ ,proc-spec)
[`(,_ ,_ ,_ ',immutables . ,_) immutables] (handle-proc-spec proc-spec '())]
[`(,_ ,_ ,proc-spec ',immutables . ,_)
(handle-proc-spec proc-spec immutables)]
[`,_ #f]))) [`,_ #f])))
(and (if (eq? prefab-imms 'non-prefab) (and (if (eq? prefab-imms 'non-prefab)
non-prefab-imms non-prefab-imms