diff --git a/racket/src/expander/extract/primitive-table.rkt b/racket/src/expander/extract/primitive-table.rkt index d330b3262b..1f985a0aad 100644 --- a/racket/src/expander/extract/primitive-table.rkt +++ b/racket/src/expander/extract/primitive-table.rkt @@ -4,8 +4,8 @@ ;; Replace ;; (hash-ref (or (primitive-table ') ...) [default]) ;; with just if
is in `primitive-table-directs`. -(define (substitute-primitive-table-access s primitive-table-directs) - (let loop ([s s]) +(define (substitute-primitive-table-access l primitive-table-directs) + (define (subst s) (cond [(primitive-table-lookup-match s) => (lambda (tables+id) @@ -17,8 +17,25 @@ (string->symbol (string-append prefix (symbol->string (cdr tables+id))))] [else s]))] [(pair? s) - (cons (loop (car s)) (loop (cdr s)))] - [else s]))) + (cons (subst (car s)) (subst (cdr s)))] + [else s])) + (let loop ([l l]) + (cond + [(null? l) null] + [else + (let ([s (car l)]) + ;; Watch out for `(define x x)` and drop it + (cond + [(and (pair? s) + (eq? 'define-values (car s)) + (pair? (cadr s)) + (null? (cdadr s))) + (define rhs (subst (caddr s))) + (if (eq? rhs (caadr s)) + (loop (cdr l)) + (cons `(define-values ,(cadr s) ,rhs) + (loop (cdr l))))] + [else (cons (subst s) (loop (cdr l)))]))]))) (define (primitive-table-lookup-match s) (cond diff --git a/racket/src/io/Makefile b/racket/src/io/Makefile index 3974c8f3ab..7ca16e6359 100644 --- a/racket/src/io/Makefile +++ b/racket/src/io/Makefile @@ -7,6 +7,10 @@ RACO = $(RACKET) -N raco -l- raco # Can be set to empty to avoid building rktio RKTIO_DEP=../build/so-rktio/Makefile +# When flattening, replace a dynamic lookup from a primitive table to +# a direct use of the primitive name: +DIRECT = ++direct thread + io-src: $(RKTIO_DEP) $(RACO) make ../expander/bootstrap-run.rkt $(MAKE) io-src-generate @@ -18,7 +22,7 @@ GENERATE_ARGS = -t main.rkt --submod main \ --depends $(BUILDDIR)compiled/io-dep.rktd \ --makefile-depends $(DEPENDSDIR)compiled/io.rktl $(BUILDDIR)compiled/io.d \ -c $(BUILDDIR)compiled/cache-src \ - -k ../.. -s -x \ + -k ../.. -s -x $(DIRECT) \ -o $(BUILDDIR)compiled/io.rktl # This target can be used with a `RACKET` that builds via `-l- setup --chain ...` diff --git a/racket/src/io/host/bootstrap.rkt b/racket/src/io/host/bootstrap.rkt index cd870763d3..7b5cf87170 100644 --- a/racket/src/io/host/bootstrap.rkt +++ b/racket/src/io/host/bootstrap.rkt @@ -96,8 +96,8 @@ 'async-evt async-evt 'schedule-info-current-exts schedule-info-current-exts 'current-sandman current-sandman - 'start-atomic start-atomic - 'end-atomic end-atomic + 'unsafe-start-atomic start-atomic + 'unsafe-end-atomic end-atomic 'start-atomic/no-interrupts start-atomic 'end-atomic/no-interrupts end-atomic 'in-atomic-mode? in-atomic-mode? diff --git a/racket/src/io/host/thread.rkt b/racket/src/io/host/thread.rkt index eacde5e88c..01f62c2f17 100644 --- a/racket/src/io/host/thread.rkt +++ b/racket/src/io/host/thread.rkt @@ -1,7 +1,10 @@ #lang racket/base -(require (only-in '#%linklet primitive-table)) +(require racket/private/primitive-table + (only-in '#%linklet primitive-table)) -(provide atomically +(provide start-atomic + end-atomic + atomically non-atomically atomically/no-interrupts/no-wind assert-atomic @@ -11,14 +14,21 @@ (or (primitive-table '#%thread) (error '#%thread "scheduler cooperation not supported by host"))) -(define-syntax bounce - (syntax-rules () - [(_ id) - (begin - (provide id) - (define id (hash-ref table 'id)))] - [(_ id ...) - (begin (bounce id) ...)])) +(define-syntax-rule (bounce id ...) + (begin + (provide id ...) + (import-from-primitive-table + (#%thread) + id ...))) + +;; Values with `bounce*` cannot be redirected +;; to refer directly to exports of `thread`, +;; generally because there's no such export +(define-syntax-rule (bounce* id ...) + (begin + (provide id ...) + (define id (hash-ref table 'id)) + ...)) (bounce make-semaphore semaphore-post @@ -26,35 +36,39 @@ semaphore-peek-evt wrap-evt always-evt - choice-evt ; raw variant that takes a list of evts sync sync/timeout evt? - sync-atomic-poll-evt? prop:evt - prop:secondary-evt - poller - poller-evt - poll-ctx-poll? - poll-ctx-select-proc - poll-ctx-sched-info - set-poll-ctx-incomplete?! - schedule-info-did-work! - control-state-evt - async-evt - schedule-info-current-exts - current-sandman - start-atomic - 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 - thread-push-kill-callback! - thread-pop-kill-callback! - set-get-subprocesses-time!) + unsafe-start-atomic + unsafe-end-atomic + current-custodian) + +(bounce* choice-evt ; raw variant that takes a list of evts + prop:secondary-evt + sync-atomic-poll-evt? + poller + poller-evt + poll-ctx-poll? + poll-ctx-select-proc + poll-ctx-sched-info + set-poll-ctx-incomplete?! + schedule-info-did-work! + control-state-evt + async-evt + schedule-info-current-exts + current-sandman + start-atomic/no-interrupts ; => disable GC, too, if GC can call back + end-atomic/no-interrupts + in-atomic-mode? + unsafe-custodian-register + unsafe-custodian-unregister + thread-push-kill-callback! + thread-pop-kill-callback! + set-get-subprocesses-time!) + +(define start-atomic unsafe-start-atomic) +(define end-atomic unsafe-end-atomic) (define-syntax-rule (atomically e ...) (begin diff --git a/racket/src/io/print/main.rkt b/racket/src/io/print/main.rkt index 1a1e49f575..55187208bd 100644 --- a/racket/src/io/print/main.rkt +++ b/racket/src/io/print/main.rkt @@ -58,9 +58,17 @@ (void))) (define (do-display who v o [max-length #f]) - (define config (make-print-config)) - (dots (p who v DISPLAY-MODE o (sub3 max-length) (detect-graph v DISPLAY-MODE config) config) o) - (void)) + (cond + [(and (bytes? v) (not max-length)) + (write-bytes v o) + (void)] + [(and (string? v) (not max-length)) + (write-string v o) + (void)] + [else + (define config (make-print-config)) + (dots (p who v DISPLAY-MODE o (sub3 max-length) (detect-graph v DISPLAY-MODE config) config) o) + (void)])) (define/who (write v [o (current-output-port)]) (check who output-port? o) diff --git a/racket/src/thread/Makefile b/racket/src/thread/Makefile index f40d96392d..29cd6c0124 100644 --- a/racket/src/thread/Makefile +++ b/racket/src/thread/Makefile @@ -8,13 +8,17 @@ thread-src: $(RACO) make ../expander/bootstrap-run.rkt $(MAKE) thread-src-generate +# When flattening, replace a dynamic lookup from a primitive table to +# a direct use of the primitive name: +DIRECT = ++direct pthread + GENERATE_ARGS = -t main.rkt --submod main \ --check-depends $(BUILDDIR)compiled/thread-dep.rktd \ ++depend-module ../expander/bootstrap-run.rkt \ --depends $(BUILDDIR)compiled/thread-dep.rktd \ --makefile-depends $(DEPENDSDIR)compiled/thread.rktl $(BUILDDIR)compiled/thread.d \ -c $(BUILDDIR)compiled/cache-src \ - -k ../.. -s -x \ + -k ../.. -s -x $(DIRECT) \ -o $(BUILDDIR)compiled/thread.rktl # This target can be used with a `RACKET` that builds via `-l- setup --chain ...` diff --git a/racket/src/thread/instance.rkt b/racket/src/thread/instance.rkt index 05c86b3199..6e7516375e 100644 --- a/racket/src/thread/instance.rkt +++ b/racket/src/thread/instance.rkt @@ -7,6 +7,7 @@ "atomic.rkt" "custodian.rkt" "thread.rkt" + "unsafe.rkt" "time.rkt") ;; Unsafe scheduler-cooperation functions are made available to @@ -39,8 +40,8 @@ 'current-sandman current-sandman 'schedule-info-current-exts schedule-info-current-exts 'schedule-info-did-work! schedule-info-did-work! - 'start-atomic start-atomic - 'end-atomic end-atomic + 'unsafe-start-atomic unsafe-start-atomic + 'unsafe-end-atomic unsafe-end-atomic 'start-atomic/no-interrupts start-atomic/no-interrupts 'end-atomic/no-interrupts end-atomic/no-interrupts 'in-atomic-mode? in-atomic-mode?