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

cs: fix thread initial prompt and parameterization

Browse Source 
The initial parameterization needs to be inside the initial prompt,
not outside.
This commit is contained in:
Matthew Flatt 2019-01-19 07:59:25 -07:00
parent a2b1fbea3f
commit 2fe2b7a8a7
4 changed files with 27 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
racket/src/cs/demo/control.ss
View File

@ -431,11 +431,13 @@
;; ---------------------------------------- ;; ----------------------------------------
;; Engines ;; Engines
(define e (make-engine (lambda () 'done) #f #f)) (define engine-tag (default-continuation-prompt-tag))
(define e (make-engine (lambda () 'done) engine-tag #f #f))
(check (cdr (e 100 void list vector)) (check (cdr (e 100 void list vector))
'(done)) '(done))
(define e-forever (make-engine (lambda () (let loop () (loop))) #f #f)) (define e-forever (make-engine (lambda () (let loop () (loop))) engine-tag #f #f))
(check (vector? (e-forever 10 void list vector)) (check (vector? (e-forever 10 void list vector))
#t) #t)
@ -448,6 +450,7 @@
[else [else
(engine-block) (engine-block)
(loop (sub1 n))]))) (loop (sub1 n))])))
engine-tag
#f #f)) #f #f))
(check (let ([started 0]) (check (let ([started 0])
(let loop ([e e-10] [n 0]) (let loop ([e e-10] [n 0])
@ -472,6 +475,7 @@
(lambda () (set! pre (add1 pre))) (lambda () (set! pre (add1 pre)))
(lambda () (loop (sub1 n))) (lambda () (loop (sub1 n)))
(lambda () (set! post (add1 post))))]))) (lambda () (set! post (add1 post))))])))
engine-tag
#f #f)]) #f #f)])
(check (let loop ([e e-10/dw] [n 0]) (check (let loop ([e e-10/dw] [n 0])
(e 200 (e 200
@ -493,10 +497,10 @@
(thread-cell-set! pt (add1 p-old)) (thread-cell-set! pt (add1 p-old))
(list u-old (list u-old
p-old p-old
(make-engine gen #f #f) (make-engine gen engine-tag #f #f)
(thread-cell-ref ut) (thread-cell-ref ut)
(thread-cell-ref pt))) (thread-cell-ref pt)))
(define l1 ((make-engine gen #f #f) (define l1 ((make-engine gen engine-tag #f #f)
100 100
void void
(lambda (remain l) l) (lambda (remain l) l)
@ -522,7 +526,7 @@
(check (procedure? my-param) #t) (check (procedure? my-param) #t)
(let ([e (with-continuation-mark parameterization-key (let ([e (with-continuation-mark parameterization-key
(extend-parameterization (continuation-mark-set-first #f parameterization-key) my-param 'set) (extend-parameterization (continuation-mark-set-first #f parameterization-key) my-param 'set)
(make-engine (lambda () (|#%app| my-param)) #f #f))]) (make-engine (lambda () (|#%app| my-param)) engine-tag #f #f))])
(check (|#%app| my-param) 'init) (check (|#%app| my-param) 'init)
(check (e 1000 void (lambda (remain v) v) (lambda (e) (error 'engine "oops"))) 'set)) (check (e 1000 void (lambda (remain v) v) (lambda (e) (error 'engine "oops"))) 'set))
@ -618,6 +622,7 @@
(loop (sub1 n))))) (loop (sub1 n)))))
(lambda () (lambda ()
(set! post (add1 post)))))))) (set! post (add1 post))))))))
engine-tag
#f #f)) #f #f))
(check (let ([prefixes 0]) (check (let ([prefixes 0])

15
racket/src/cs/rumble/engine.ss
View File

@ -24,17 +24,20 @@
(define (set-engine-exit-handler! proc) (define (set-engine-exit-handler! proc)
(set! engine-exit proc)) (set! engine-exit proc))
(define (make-engine thunk init-break-enabled-cell empty-config?) (define (make-engine thunk prompt-tag init-break-enabled-cell empty-config?)
(let ([paramz (if empty-config? (let ([paramz (if empty-config?
empty-parameterization empty-parameterization
(current-parameterization))]) (current-parameterization))])
(create-engine empty-metacontinuation (create-engine empty-metacontinuation
(lambda (prefix) (lambda (prefix)
(with-continuation-mark (call-with-continuation-prompt
parameterization-key paramz (lambda ()
(begin (with-continuation-mark
(prefix) parameterization-key paramz
(call-with-values (lambda () (|#%app| thunk)) engine-return)))) (begin
(prefix)
(call-with-values (lambda () (|#%app| thunk)) engine-return))))
prompt-tag))
(if empty-config? (if empty-config?
(make-empty-thread-cell-values) (make-empty-thread-cell-values)
(new-engine-thread-cell-values)) (new-engine-thread-cell-values))

15
racket/src/thread/future.rkt
View File

@ -90,14 +90,11 @@
(define (thunk-wrapper f thunk) (define (thunk-wrapper f thunk)
(lambda () (lambda ()
(call-with-continuation-prompt (let ([result (thunk)])
(lambda () (with-lock ((future*-lock f) (current-future))
(let ([result (thunk)]) (set-future*-result! f result)
(with-lock ((future*-lock f) (current-future)) (set-future*-done?! f #t)
(set-future*-result! f result) (future:condition-broadcast (future*-cond f))))))
(set-future*-done?! f #t)
(future:condition-broadcast (future*-cond f)))))
(future*-prompt f))))
(define/who (future thunk) (define/who (future thunk)
(check who (procedure-arity-includes/c 0) thunk) (check who (procedure-arity-includes/c 0) thunk)
@ -106,7 +103,7 @@
(would-be-future thunk)] (would-be-future thunk)]
[else [else
(let ([f (create-future #f)]) (let ([f (create-future #f)])
(set-future*-engine! f (make-engine (thunk-wrapper f thunk) #f #t)) (set-future*-engine! f (make-engine (thunk-wrapper f thunk) (future*-prompt f) #f #t))
(schedule-future f) (schedule-future f)
f)])) f)]))

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

@ -150,8 +150,8 @@
(define p (if (or at-root? initial?) (define p (if (or at-root? initial?)
root-thread-group root-thread-group
(current-thread-group))) (current-thread-group)))
(define e (make-engine (lambda () (define e (make-engine proc
(call-with-continuation-prompt proc)) (default-continuation-prompt-tag)
(if (or initial? at-root?) (if (or initial? at-root?)
break-enabled-default-cell break-enabled-default-cell
(current-break-enabled-cell)) (current-break-enabled-cell))