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

thread & io: performance improvement

Browse Source 
Part of this change restores a `++direct` that was lost in 98ae91e0ba
for "racket/src/thread" to make the atomicity state a virtual
register. Also make `display` on a byte string more directly call
`write-bytes`. That change restores a 5-10% speed improvement for
`racketcs -cl racket/base`.
This commit is contained in:
Matthew Flatt 2018-08-14 19:31:00 -06:00
parent a58d115bf2
commit a25efeb8a9
7 changed files with 96 additions and 48 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
racket/src/expander/extract/primitive-table.rkt
View File

@ -4,8 +4,8 @@
;; Replace
;; (hash-ref (or (primitive-table '<table>) ...) <id> [default])
;; with just <id> if <table> 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

6
racket/src/io/Makefile
View File

@ -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 ...`

4
racket/src/io/host/bootstrap.rkt
View File

@ -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?

84
racket/src/io/host/thread.rkt
View File

@ -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

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

@ -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)

6
racket/src/thread/Makefile
View File

@ -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 ...`

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

@ -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?