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

cs: repairs for chaperoned events

Browse Source 
The recent `sync` shortcut was wrong for chaperoned events.
This commit is contained in:
Matthew Flatt 2018-08-20 18:06:58 -06:00
parent ae7a64b4ea
commit 34231aca7e
5 changed files with 30 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
racket/src/cs/rumble/control.ss
View File

@ -1245,7 +1245,7 @@
(make-continuation-mark-set
(prune-mark-chain-suffix
tag
(get-current-mark-chain #f #f mc))
(get-current-mark-chain '() #f mc))
(get-metacontinuation-traces mc)))]
[(full-continuation? k)
(make-continuation-mark-set

33
racket/src/cs/rumble/memory.ss
View File

@ -177,19 +177,20 @@
(enable-object-backreferences #f)
(chez:fprintf (current-error-port) "Begin Dump\n")
(chez:fprintf (current-error-port) "Current memory use: ~a\n" (bytes-allocated))
(chez:fprintf (current-error-port) "Begin RacketCS\n")
(for-each (lambda (e)
(chez:fprintf (current-error-port)
(layout-line (chez:format "~a" (car e))
((get-count #f) e) ((get-bytes #f) e)
((get-count #t) e) ((get-bytes #t) e))))
(list-sort (lambda (a b) (< ((get-bytes #f) a) ((get-bytes #f) b))) counts))
(chez:fprintf (current-error-port) (layout-line "total"
(apply + (map (get-count #f) counts))
(apply + (map (get-bytes #f) counts))
(apply + (map (get-count #t) counts))
(apply + (map (get-bytes #t) counts))))
(chez:fprintf (current-error-port) "End RacketCS\n")
(unless (#%memq 'only args)
(chez:fprintf (current-error-port) "Begin RacketCS\n")
(for-each (lambda (e)
(chez:fprintf (current-error-port)
(layout-line (chez:format "~a" (car e))
((get-count #f) e) ((get-bytes #f) e)
((get-count #t) e) ((get-bytes #t) e))))
(list-sort (lambda (a b) (< ((get-bytes #f) a) ((get-bytes #f) b))) counts))
(chez:fprintf (current-error-port) (layout-line "total"
(apply + (map (get-count #f) counts))
(apply + (map (get-bytes #f) counts))
(apply + (map (get-count #t) counts))
(apply + (map (get-bytes #t) counts))))
(chez:fprintf (current-error-port) "End RacketCS\n"))
(when backtrace-predicate
(when (and use-prev? (not prev-stats-objects))
(set! prev-stats-objects (make-weak-eq-hashtable)))
@ -248,11 +249,17 @@
(lambda (o)
(and (#%$record? o)
(eq? (record-type-name (#%$record-type-descriptor o)) struct-name))))]
[(weak-box? (car args))
(let ([v (weak-box-value (car args))])
(lambda (o) (eq? o v)))]
[(eq? 'code (car args))
#%$code?]
[(eq? 'ephemeron (car args))
ephemeron-pair?]
[(symbol? (car args))
#f
;; This is disaterously slow, so don't try it:
#;
(let ([type (car args)])
(lambda (o)
(eq? ((inspect/object o) 'type) type)))]

2
racket/src/io/print/main.rkt
View File

@ -273,6 +273,8 @@
(print-named "struct-type" v mode o max-length)]
[(struct-type-property? v)
(print-named "struct-type-property" v mode o max-length)]
[(thread? v)
(print-named "thread" v mode o max-length)]
[(eof-object? v)
(write-string/max "#<eof>" o max-length)]
[(core-input-port? v)

4
racket/src/thread/sync.rkt
View File

@ -170,6 +170,8 @@
(case-lambda
[(evt)
(cond
[(evt-impersonator? evt)
(do-sync 'sync #f (list evt))]
[(semaphore? evt)
(semaphore-wait evt)
evt]
@ -187,6 +189,8 @@
(case-lambda
[(timeout evt)
(cond
[(evt-impersonator? evt)
(do-sync 'sync/timeout timeout (list evt))]
[(and (semaphore? evt)
(eqv? timeout 0))
(if (semaphore-try-wait? evt)

5
racket/src/thread/thread.rkt
View File

@ -122,7 +122,8 @@
#:suspend! (lambda (t i-cb r-cb) (thread-deschedule! t #f i-cb r-cb))
#:resume! (lambda (t v) (thread-reschedule! t) v))
#:property prop:evt (lambda (t) (wrap-evt (get-thread-dead-evt t)
(lambda (v) t))))
(lambda (v) t)))
#:property prop:object-name (struct-field-index name))
(define root-thread #f)
@ -148,7 +149,7 @@
(define t (thread 'none ; node prev
'none ; node next
(gensym)
(object-name proc)
e
p
#f ; sleeping