diff --git a/racket/src/io/file/main.rkt b/racket/src/io/file/main.rkt index 0f0f7a6880..075146292b 100644 --- a/racket/src/io/file/main.rkt +++ b/racket/src/io/file/main.rkt @@ -180,7 +180,9 @@ (rktio_set_file_modify_seconds rktio host-path secs) (rktio_get_file_modify_seconds rktio host-path))) (define r (if (and (not secs) (not (rktio-error? r0))) - (rktio_timestamp_ref r0) + (begin0 + (rktio_timestamp_ref r0) + (rktio_free r0)) r0)) (end-atomic) (cond diff --git a/racket/src/io/host/bootstrap.rkt b/racket/src/io/host/bootstrap.rkt index a69158fb23..cd870763d3 100644 --- a/racket/src/io/host/bootstrap.rkt +++ b/racket/src/io/host/bootstrap.rkt @@ -100,6 +100,7 @@ 'end-atomic end-atomic 'start-atomic/no-interrupts start-atomic 'end-atomic/no-interrupts end-atomic + 'in-atomic-mode? in-atomic-mode? 'current-custodian current-custodian 'custodian-shut-down? (lambda (c) (define v (box 1)) diff --git a/racket/src/io/host/thread.rkt b/racket/src/io/host/thread.rkt index e7dc0accf8..d4e27b06c4 100644 --- a/racket/src/io/host/thread.rkt +++ b/racket/src/io/host/thread.rkt @@ -4,6 +4,7 @@ (provide atomically non-atomically atomically/no-interrupts + assert-atomic check-current-custodian) (define table @@ -47,6 +48,7 @@ end-atomic start-atomic/no-interrupts ; => disable GC, too, if GC can call back end-atomic/no-interrupts + in-atomic-mode? current-custodian unsafe-custodian-register unsafe-custodian-unregister @@ -76,6 +78,13 @@ (let () e ...) (end-atomic/no-interrupts)))) +;; Enable for debugging +(define (assert-atomic) + (void) + #; + (unless (in-atomic-mode?) + (error 'assert-atomic "not in atomic mode"))) + ;; in atomic mode (define (check-current-custodian who) (when (custodian-shut-down? (current-custodian)) diff --git a/racket/src/io/port/bytes-input.rkt b/racket/src/io/port/bytes-input.rkt index 9bbc998153..96832b1d8b 100644 --- a/racket/src/io/port/bytes-input.rkt +++ b/racket/src/io/port/bytes-input.rkt @@ -34,7 +34,7 @@ [(= v amt) v] [else (let loop ([got v]) - (define v (read-some-bytes! who in bstr got amt #:keep-eof? #t #:special-ok? #f)) + (define v (read-some-bytes! who in bstr (+ start got) end #:keep-eof? #t #:special-ok? #f)) (cond [(eof-object? v) got] diff --git a/racket/src/io/port/pipe.rkt b/racket/src/io/port/pipe.rkt index 7e2538da77..90f1894b70 100644 --- a/racket/src/io/port/pipe.rkt +++ b/racket/src/io/port/pipe.rkt @@ -158,6 +158,7 @@ #:read-byte (lambda () + (assert-atomic) (cond [(input-empty?) (if output-closed? @@ -177,6 +178,7 @@ #:read-in (lambda (dest-bstr dest-start dest-end copy?) + (assert-atomic) (cond [(input-empty?) (if output-closed? @@ -205,6 +207,7 @@ #:peek-byte (lambda () + (assert-atomic) (cond [(input-empty?) (if output-closed? @@ -216,6 +219,7 @@ #:peek-in (lambda (dest-bstr dest-start dest-end skip progress-evt copy?) + (assert-atomic) (define content-amt (content-length)) (cond [(and progress-evt @@ -250,6 +254,7 @@ #:byte-ready (lambda (work-done!) + (assert-atomic) (or output-closed? (not (zero? (content-length))))) @@ -273,6 +278,7 @@ ;; Allows `amt` to be zero and #f for other arguments, ;; which is helpful for `open-input-peek-via-read`. (lambda (amt progress-evt ext-evt finish) + (assert-atomic) ;; `progress-evt` is a `semepahore-peek-evt`, and `ext-evt` ;; is constrained; we can send them over to different threads (cond @@ -314,6 +320,7 @@ #:write-out ;; in atomic mode (lambda (src-bstr src-start src-end nonblock? enable-break? copy?) + (assert-atomic) (let try-again () (define top-pos (if (zero? start) (sub1 len) diff --git a/racket/src/io/port/ready.rkt b/racket/src/io/port/ready.rkt index 368a529792..c4d7f67d79 100644 --- a/racket/src/io/port/ready.rkt +++ b/racket/src/io/port/ready.rkt @@ -31,7 +31,7 @@ (cond [(byte-ready? in) (define peek-byte (core-input-port-peek-byte in)) - (define b (and peek-byte (peek-byte))) + (define b (and peek-byte (atomically (peek-byte)))) (cond [(and b (or (eof-object? b) diff --git a/racket/src/io/port/string-input.rkt b/racket/src/io/port/string-input.rkt index 4eab2a7f5c..7680ff4608 100644 --- a/racket/src/io/port/string-input.rkt +++ b/racket/src/io/port/string-input.rkt @@ -313,7 +313,7 @@ (let ([in (->core-input-port in)]) (define peek-byte (and (zero? skip-k) (core-input-port-peek-byte in))) - (define b (and peek-byte (peek-byte))) + (define b (and peek-byte (atomically (peek-byte)))) (cond [(and b (or (eof-object? b) diff --git a/racket/src/thread/atomic.rkt b/racket/src/thread/atomic.rkt index c1e2d8d7b4..fec2940028 100644 --- a/racket/src/thread/atomic.rkt +++ b/racket/src/thread/atomic.rkt @@ -12,6 +12,8 @@ start-atomic/no-interrupts end-atomic/no-interrupts + in-atomic-mode? + set-end-atomic-callback! start-implicit-atomic-mode @@ -53,6 +55,9 @@ (host:enable-interrupts) (end-atomic)) +(define (in-atomic-mode?) + (positive? (current-atomic))) + ;; ---------------------------------------- (define end-atomic-callback #f) diff --git a/racket/src/thread/instance.rkt b/racket/src/thread/instance.rkt index a8aac1dbf3..05c86b3199 100644 --- a/racket/src/thread/instance.rkt +++ b/racket/src/thread/instance.rkt @@ -43,6 +43,7 @@ 'end-atomic end-atomic 'start-atomic/no-interrupts start-atomic/no-interrupts 'end-atomic/no-interrupts end-atomic/no-interrupts + 'in-atomic-mode? in-atomic-mode? 'current-custodian current-custodian 'unsafe-custodian-register unsafe-custodian-register 'unsafe-custodian-unregister unsafe-custodian-unregister